From 1f2ffbfcf19c8adb4578a519228ee7b79a46224f Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 22 Jul 2022 15:07:45 +0200 Subject: [PATCH 01/69] Remove duplicated header. --- src/daemon/driver/driverControlers.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/daemon/driver/driverControlers.ml b/src/daemon/driver/driverControlers.ml index 4432990d..2d228e2e 100644 --- a/src/daemon/driver/driverControlers.ml +++ b/src/daemon/driver/driverControlers.ml @@ -795,9 +795,7 @@ let http_add_text_header r ext = add_gzip_headers r let http_add_bin_info_header r clen = - add_reply_header r "Accept-Ranges" "bytes"; - add_reply_header r "Content-Length" (Printf.sprintf "%d" clen) - (* FIXME Content-Length is duplicated *) + add_reply_header r "Accept-Ranges" "bytes" let http_add_bin_header r ext clen = http_file_type := ext_to_file_type ext; From 2eafa001e4109594756784f41f946bb1fe4bf174 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 21 Jul 2023 18:49:59 +0200 Subject: [PATCH 02/69] Build fix: the compress_string function must be taken from the new Zlib2 module. --- src/gtk2/gui/guiArt.ml | 2 +- tools/svg_converter.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/gtk2/gui/guiArt.ml b/src/gtk2/gui/guiArt.ml index 0c03b516..4d3db8a5 100644 --- a/src/gtk2/gui/guiArt.ml +++ b/src/gtk2/gui/guiArt.ml @@ -241,7 +241,7 @@ open Zlib (* Return a pixbuf for a given svg data *) let pixb icon_name pixel_size = - let svg = uncompress_string icon_name in + let svg = Zlib2.uncompress_string icon_name in let z = float_of_int pixel_size /. 48. in let size_cb = (Rsvg.at_zoom z z) in let pb = Rsvg.render_from_string ~size_cb svg in diff --git a/tools/svg_converter.ml b/tools/svg_converter.ml index 8e3da0e5..97241d71 100644 --- a/tools/svg_converter.ml +++ b/tools/svg_converter.ml @@ -19,7 +19,7 @@ open Filename2 -open Zlib +open Zlib2 let load_svg file = Printf.printf "Converting file %s\n" file; From 497e8d76e395d8afb1eccc0248af8f3cfa5af5cb Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Tue, 4 Jun 2024 17:10:15 +0200 Subject: [PATCH 03/69] Update syslog module from upstream Ported updates from the upstream repo of the syslog module up to revision becc8c4 version 2.0.2. --- src/utils/lib/syslog.ml | 316 +++++++++++++++++++-------------------- src/utils/lib/syslog.mli | 54 ++++--- 2 files changed, 181 insertions(+), 189 deletions(-) diff --git a/src/utils/lib/syslog.ml b/src/utils/lib/syslog.ml index a5a66d47..f4c18eae 100644 --- a/src/utils/lib/syslog.ml +++ b/src/utils/lib/syslog.ml @@ -1,4 +1,5 @@ -(* syslog(3) routines for ocaml +(* syslog(3) routines for ocaml (RFC 3164) + This library is based on Shawn Wagner's original syslog library as included in annexlib, with significant modifications by by Eric Stokes . @@ -10,12 +11,12 @@ modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. - + This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. - + You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA @@ -23,96 +24,84 @@ open Unix -(** The assorted logging facilities. The default is [`LOG_USER]. You - can set a new default with openlog, or give a specific facility per - syslog call. *) -type facility = - [ `LOG_KERN | `LOG_USER | `LOG_MAIL | `LOG_DAEMON | `LOG_AUTH - | `LOG_SYSLOG | `LOG_LPR | `LOG_NEWS | `LOG_UUCP | `LOG_CRON - | `LOG_AUTHPRIV | `LOG_FTP | `LOG_NTP | `LOG_SECURITY - | `LOG_CONSOLE | `LOG_LOCAL0 | `LOG_LOCAL1 | `LOG_LOCAL2 - | `LOG_LOCAL3 | `LOG_LOCAL4 | `LOG_LOCAL5 | `LOG_LOCAL6 - | `LOG_LOCAL7 ] - -(** Flags to pass to openlog. [`LOG_CONS] isn't implemented yet. *) +type facility = + [ `LOG_KERN | `LOG_USER | `LOG_MAIL | `LOG_DAEMON | `LOG_AUTH + | `LOG_SYSLOG | `LOG_LPR | `LOG_NEWS | `LOG_UUCP | `LOG_CRON + | `LOG_AUTHPRIV | `LOG_FTP | `LOG_NTP | `LOG_SECURITY + | `LOG_CONSOLE | `LOG_LOCAL0 | `LOG_LOCAL1 | `LOG_LOCAL2 + | `LOG_LOCAL3 | `LOG_LOCAL4 | `LOG_LOCAL5 | `LOG_LOCAL6 + | `LOG_LOCAL7 ] + type flag = [ `LOG_CONS | `LOG_PERROR | `LOG_PID ] -(** The priority of the error. *) type level = [ `LOG_EMERG | `LOG_ALERT | `LOG_CRIT | `LOG_ERR | `LOG_WARNING - | `LOG_NOTICE | `LOG_INFO | `LOG_DEBUG ] + | `LOG_NOTICE | `LOG_INFO | `LOG_DEBUG ] exception Syslog_error of string -let facility_of_string s = - match String.lowercase s with - "kern" -> `LOG_KERN - | "user" -> `LOG_USER - | "mail" -> `LOG_MAIL - | "daemon" -> `LOG_DAEMON - | "auth" -> `LOG_AUTH - | "syslog" -> `LOG_SYSLOG - | "lpr" -> `LOG_LPR - | "news" -> `LOG_NEWS - | "uucp" -> `LOG_UUCP - | "cron" -> `LOG_CRON - | "authpriv" -> `LOG_AUTHPRIV - | "ftp" -> `LOG_FTP - | "ntp" -> `LOG_NTP - | "security" -> `LOG_SECURITY - | "console" -> `LOG_CONSOLE - | "local0" -> `LOG_LOCAL0 - | "local1" -> `LOG_LOCAL1 - | "local2" -> `LOG_LOCAL2 - | "local3" -> `LOG_LOCAL3 - | "local4" -> `LOG_LOCAL4 - | "local5" -> `LOG_LOCAL5 - | "local6" -> `LOG_LOCAL6 - | "local7" -> `LOG_LOCAL7 - | invalid -> raise - (Syslog_error - ("facility_of_string: invalid facility, " ^ - invalid)) +let facility_of_string s = + match String.lowercase_ascii s with + | "kern" -> `LOG_KERN + | "user" -> `LOG_USER + | "mail" -> `LOG_MAIL + | "daemon" -> `LOG_DAEMON + | "auth" -> `LOG_AUTH + | "syslog" -> `LOG_SYSLOG + | "lpr" -> `LOG_LPR + | "news" -> `LOG_NEWS + | "uucp" -> `LOG_UUCP + | "cron" -> `LOG_CRON + | "authpriv" -> `LOG_AUTHPRIV + | "ftp" -> `LOG_FTP + | "ntp" -> `LOG_NTP + | "security" -> `LOG_SECURITY + | "console" -> `LOG_CONSOLE + | "local0" -> `LOG_LOCAL0 + | "local1" -> `LOG_LOCAL1 + | "local2" -> `LOG_LOCAL2 + | "local3" -> `LOG_LOCAL3 + | "local4" -> `LOG_LOCAL4 + | "local5" -> `LOG_LOCAL5 + | "local6" -> `LOG_LOCAL6 + | "local7" -> `LOG_LOCAL7 + | x -> raise (Syslog_error ("facility_of_string: invalid facility, " ^ x)) let facility_to_num fac = - Int32.of_int (match fac with - | `LOG_KERN -> 0 lsl 3 - | `LOG_USER -> 1 lsl 3 - | `LOG_MAIL -> 2 lsl 3 - | `LOG_DAEMON -> 3 lsl 3 - | `LOG_AUTH -> 4 lsl 3 - | `LOG_SYSLOG -> 5 lsl 3 - | `LOG_LPR -> 6 lsl 3 - | `LOG_NEWS -> 7 lsl 3 - | `LOG_UUCP -> 8 lsl 3 - | `LOG_CRON -> 9 lsl 3 - | `LOG_AUTHPRIV -> 10 lsl 3 - | `LOG_FTP -> 11 lsl 3 - | `LOG_NTP -> 12 lsl 3 - | `LOG_SECURITY -> 13 lsl 3 - | `LOG_CONSOLE -> 14 lsl 3 - | `LOG_LOCAL0 -> 16 lsl 3 - | `LOG_LOCAL1 -> 17 lsl 3 - | `LOG_LOCAL2 -> 18 lsl 3 - | `LOG_LOCAL3 -> 19 lsl 3 - | `LOG_LOCAL4 -> 20 lsl 3 - | `LOG_LOCAL5 -> 21 lsl 3 - | `LOG_LOCAL6 -> 22 lsl 3 - | `LOG_LOCAL7 -> 23 lsl 3) - -let level_to_num lev = - Int32.of_int (match lev with - | `LOG_EMERG -> 0 - | `LOG_ALERT -> 1 - | `LOG_CRIT -> 2 - | `LOG_ERR -> 3 - | `LOG_WARNING -> 4 - | `LOG_NOTICE -> 5 - | `LOG_INFO -> 6 - | `LOG_DEBUG -> 7) - - -let level_mask = 0x07 -let facility_mask = 0x03f8 + Int32.of_int @@ match fac with + | `LOG_KERN -> 0 lsl 3 + | `LOG_USER -> 1 lsl 3 + | `LOG_MAIL -> 2 lsl 3 + | `LOG_DAEMON -> 3 lsl 3 + | `LOG_AUTH -> 4 lsl 3 + | `LOG_SYSLOG -> 5 lsl 3 + | `LOG_LPR -> 6 lsl 3 + | `LOG_NEWS -> 7 lsl 3 + | `LOG_UUCP -> 8 lsl 3 + | `LOG_CRON -> 9 lsl 3 + | `LOG_AUTHPRIV -> 10 lsl 3 + | `LOG_FTP -> 11 lsl 3 + | `LOG_NTP -> 12 lsl 3 + | `LOG_SECURITY -> 13 lsl 3 + | `LOG_CONSOLE -> 14 lsl 3 + | `LOG_LOCAL0 -> 16 lsl 3 + | `LOG_LOCAL1 -> 17 lsl 3 + | `LOG_LOCAL2 -> 18 lsl 3 + | `LOG_LOCAL3 -> 19 lsl 3 + | `LOG_LOCAL4 -> 20 lsl 3 + | `LOG_LOCAL5 -> 21 lsl 3 + | `LOG_LOCAL6 -> 22 lsl 3 + | `LOG_LOCAL7 -> 23 lsl 3 + +let level_to_num lev = + Int32.of_int @@ match lev with + | `LOG_EMERG -> 0 + | `LOG_ALERT -> 1 + | `LOG_CRIT -> 2 + | `LOG_ERR -> 3 + | `LOG_WARNING -> 4 + | `LOG_NOTICE -> 5 + | `LOG_INFO -> 6 + | `LOG_DEBUG -> 7 type t = { mutable fd: Unix.file_descr; @@ -121,80 +110,84 @@ type t = { mutable tag: string; mutable fac: int32; mutable logpath: string; -} +} let open_connection loginfo = - let module U = Unix.LargeFile in match loginfo.logpath with - "" -> raise (Syslog_error "unable to find the syslog socket or pipe, is syslogd running?") - | logpath -> - (match (U.stat logpath).U.st_kind with - Unix.S_SOCK -> - let logaddr = Unix.ADDR_UNIX logpath in - (try - loginfo.fd <- Unix.socket Unix.PF_UNIX SOCK_DGRAM 0; - Unix.connect loginfo.fd logaddr - with Unix.Unix_error (Unix.EPROTOTYPE, _, _) -> - (* try again with a stream socket for syslog-ng *) - loginfo.fd <- Unix.socket Unix.PF_UNIX SOCK_STREAM 0; - Unix.connect loginfo.fd logaddr); - loginfo.connected <- true; - | Unix.S_FIFO -> - loginfo.fd <- Unix.openfile logpath [Unix.O_WRONLY] 0o666; - loginfo.connected <- true; - | _ -> raise (Syslog_error "invalid log path, not a socket or pipe")) - -let openlog - ?(logpath=(try ignore (Unix.stat "/dev/log");"/dev/log" - with Unix.Unix_error (Unix.ENOENT, _, _) -> - (try ignore (Unix.stat "/var/run/syslog");"/var/run/syslog" - with Unix.Unix_error (Unix.ENOENT, _, _) -> ""))) + | "" -> raise (Syslog_error "unable to find the syslog socket or pipe, is syslogd running?") + | logpath -> + match (Unix.stat logpath).Unix.st_kind with + | Unix.S_SOCK -> + let logaddr = Unix.ADDR_UNIX logpath in + loginfo.fd <- + begin + try Unix.socket Unix.PF_UNIX SOCK_DGRAM 0 + with Unix.Unix_error (Unix.EPROTOTYPE, _, _) -> + Unix.socket Unix.PF_UNIX SOCK_STREAM 0 + end ; + Unix.connect loginfo.fd logaddr ; + loginfo.connected <- true; + | Unix.S_FIFO -> + loginfo.fd <- Unix.openfile logpath [Unix.O_WRONLY] 0o666; + loginfo.connected <- true; + | _ -> raise (Syslog_error "invalid log path, not a socket or pipe") + +let openlog + ?(logpath= + if Sys.file_exists "/dev/log" then "/dev/log" + else if Sys.file_exists "/var/run/syslog" then "/var/run/syslog" + else "") ?(facility=`LOG_USER) ?(flags=[]) ident = - let loginfo = {fd = Unix.stderr; - connected = false; - flags = flags; - tag = ident; - fac = facility_to_num facility; - logpath = logpath} - in - open_connection loginfo; - loginfo - -let log_console _msg = () + let loginfo = {fd = Unix.stderr; + connected = false; + flags = flags; + tag = (if String.length ident > 32 + then String.sub ident 0 32 + else ident); + fac = facility_to_num facility; + logpath = logpath} + in + open_connection loginfo; + loginfo + +let log_fd fd msg = + try + ignore (Unix.write fd msg 0 (Bytes.length msg)); + ignore (Unix.write fd (Bytes.unsafe_of_string "\n") 0 1) + with _ -> () let ascdate {tm_sec=sec;tm_min=min;tm_hour=hour; - tm_mday=mday;tm_mon=mon;tm_year=_; - tm_wday=_;tm_yday=_;tm_isdst=_} = + tm_mday=mday;tm_mon=mon;_} = let asc_mon = match mon with - 0 -> "Jan" - | 1 -> "Feb" - | 2 -> "Mar" - | 3 -> "Apr" - | 4 -> "May" - | 5 -> "Jun" - | 6 -> "Jul" - | 7 -> "Aug" - | 8 -> "Sep" - | 9 -> "Oct" - | 10 -> "Nov" - | 11 -> "Dec" - | _ -> raise (Syslog_error "invalid month") + | 0 -> "Jan" + | 1 -> "Feb" + | 2 -> "Mar" + | 3 -> "Apr" + | 4 -> "May" + | 5 -> "Jun" + | 6 -> "Jul" + | 7 -> "Aug" + | 8 -> "Sep" + | 9 -> "Oct" + | 10 -> "Nov" + | 11 -> "Dec" + | _ -> raise (Syslog_error "invalid month") in - (Printf.sprintf "%s %02d %02d:%02d:%02d" asc_mon mday hour min sec) + (Printf.sprintf "%s %2d %02d:%02d:%02d" asc_mon mday hour min sec) let protected_write loginfo str = let fallback _ = (try close loginfo.fd with _ -> ()); loginfo.connected <- false; (try open_connection loginfo with _ -> ()); - if List.mem `LOG_CONS loginfo.flags then log_console str + if List.mem `LOG_CONS loginfo.flags then log_fd Unix.stdout str in let prev = Sys.signal Sys.sigpipe (Sys.Signal_handle fallback) in try - ignore (write loginfo.fd str 0 (String.length str)); + ignore (write loginfo.fd str 0 (Bytes.length str)); Sys.set_signal Sys.sigpipe prev with Unix_error (_, _, _) -> (* on error, attempt to reconnect *) @@ -203,35 +196,28 @@ let protected_write loginfo str = let syslog ?fac loginfo lev str = let msg = Buffer.create 64 in - let realfac = match fac with + let realfac = match fac with | Some f -> facility_to_num f | None -> loginfo.fac in let levfac = Int32.logor realfac (level_to_num lev) and now = ascdate (localtime (Unix.time ())) in - Printf.bprintf msg "<%ld>%.15s " levfac now; - let len1 = Buffer.length msg - and len2 = String.length loginfo.tag in - if len1 + len2 < 64 then - Buffer.add_string msg loginfo.tag - else - Buffer.add_substring msg loginfo.tag 0 (64 - len1); - if List.mem `LOG_PID loginfo.flags then - Printf.bprintf msg "[%d]" (Unix.getpid()); - if String.length loginfo.tag > 0 then - Buffer.add_string msg ": "; - Buffer.add_string msg str; - let realmsg = ref (Buffer.contents msg) in - if String.length !realmsg > 1024 then begin - realmsg := String.sub !realmsg 0 1024; - String.blit "" 0 !realmsg 1012 11 - end; - protected_write loginfo !realmsg; - if List.mem `LOG_PERROR loginfo.flags then begin - try - ignore (Unix.write Unix.stderr !realmsg 0 (String.length !realmsg)); - ignore (Unix.write Unix.stderr "\n" 0 1) - with _ -> () - end + Printf.bprintf msg "<%ld>%s " levfac now; + Buffer.add_string msg loginfo.tag ; + if List.mem `LOG_PID loginfo.flags then + Printf.bprintf msg "[%d]" (Unix.getpid()); + if String.length loginfo.tag > 0 then + Buffer.add_string msg ": "; + Buffer.add_string msg str; + let msg = + if Buffer.length msg > 1024 + then begin + let m = Bytes.unsafe_of_string @@ Buffer.sub msg 0 1024 in + Bytes.blit_string "..." 0 m 1021 3 ; + m + end else Buffer.to_bytes msg + in + protected_write loginfo msg; + if List.mem `LOG_PERROR loginfo.flags then log_fd Unix.stderr msg let closelog loginfo = if loginfo.connected then @@ -241,4 +227,4 @@ let closelog loginfo = end; loginfo.flags <- []; loginfo.tag <- ""; - loginfo.fac <- facility_to_num `LOG_USER + loginfo.fac <- facility_to_num `LOG_USER \ No newline at end of file diff --git a/src/utils/lib/syslog.mli b/src/utils/lib/syslog.mli index 4a2f3076..9cd74011 100644 --- a/src/utils/lib/syslog.mli +++ b/src/utils/lib/syslog.mli @@ -1,22 +1,27 @@ -(* syslog(3) routines for ocaml +(* syslog(3) routines for ocaml (RFC 3164) + + This library is based on Shawn Wagner's original syslog + library as included in annexlib, with significant modifications + by by Eric Stokes . + Copyright (C) 2002 Shawn Wagner + Copyright (C) 2005 Eric Stokes This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. - + This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. - + You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) - (** Syslog routines *) (** These are loosely based on the unix syslog(3) function and @@ -25,39 +30,40 @@ (** The assorted logging facilities. The default is [`LOG_USER]. You can set a new default with openlog, or give a specific facility per syslog call. *) -type facility = - [ `LOG_KERN | `LOG_USER | `LOG_MAIL | `LOG_DAEMON | `LOG_AUTH - | `LOG_SYSLOG | `LOG_LPR | `LOG_NEWS | `LOG_UUCP | `LOG_CRON - | `LOG_AUTHPRIV | `LOG_FTP | `LOG_NTP | `LOG_SECURITY - | `LOG_CONSOLE | `LOG_LOCAL0 | `LOG_LOCAL1 | `LOG_LOCAL2 - | `LOG_LOCAL3 | `LOG_LOCAL4 | `LOG_LOCAL5 | `LOG_LOCAL6 - | `LOG_LOCAL7 ] - -(** Flags to pass to openlog. [`LOG_CONS] isn't implemented - yet. LOG_NDELAY is mandatory and implied *) +type facility = + [ `LOG_KERN | `LOG_USER | `LOG_MAIL | `LOG_DAEMON | `LOG_AUTH + | `LOG_SYSLOG | `LOG_LPR | `LOG_NEWS | `LOG_UUCP | `LOG_CRON + | `LOG_AUTHPRIV | `LOG_FTP | `LOG_NTP | `LOG_SECURITY + | `LOG_CONSOLE | `LOG_LOCAL0 | `LOG_LOCAL1 | `LOG_LOCAL2 + | `LOG_LOCAL3 | `LOG_LOCAL4 | `LOG_LOCAL5 | `LOG_LOCAL6 + | `LOG_LOCAL7 ] + +(** Flags to pass to openlog. LOG_NDELAY is mandatory and implied *) type flag = [ `LOG_CONS | `LOG_PERROR | `LOG_PID ] (** The priority of the error. *) type level = [ `LOG_EMERG | `LOG_ALERT | `LOG_CRIT | `LOG_ERR | `LOG_WARNING - | `LOG_NOTICE | `LOG_INFO | `LOG_DEBUG ] + | `LOG_NOTICE | `LOG_INFO | `LOG_DEBUG ] (** the type of a syslog connection *) type t (** given a string descibing a facility, return the facility. The strings consist of the name of the facility with the LOG_ chopped - off. They are not case sensitive. @raise Syslog_error when given - an invalid facility *) + off. They are not case sensitive. + @raise Syslog_error when given an invalid facility *) val facility_of_string: string -> facility -(** openlog ?(logpath=AUTODETECTED) ?(facility=`LOG_USER) ?(flags=[]) - program_name, similar to openlog(3) @raise Syslog_error on - error *) +(** [openlog ?(logpath=AUTODETECTED) ?(facility=`LOG_USER) ?(flags=[]) tag] + Similar to openlog(3). + You MUST define [tag] as 32 ABNF alphanumeric characters maximum. + @raise Syslog_error on error *) val openlog: ?logpath:string -> ?facility:facility -> ?flags:flag list -> string -> t -(** Same as syslog(3), except there's no formats. @raise Syslog_error - on error (very rare) *) +(** Same as syslog(3), except there's no formats. + @raise Syslog_error on error (very rare) *) val syslog: ?fac:facility -> t -> level -> string -> unit -(** Close the log. @raise Syslog_error on error *) -val closelog: t -> unit +(** Close the log. + @raise Syslog_error on error *) +val closelog: t -> unit \ No newline at end of file From 4f649a8045684309371b73b7fb4f33912e65c326 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Tue, 4 Jun 2024 17:28:38 +0200 Subject: [PATCH 04/69] Make the decode64 function compatible with immutable strings. --- src/utils/net/http_server.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/net/http_server.ml b/src/utils/net/http_server.ml index 4cd2c5b6..cf8cac67 100644 --- a/src/utils/net/http_server.ml +++ b/src/utils/net/http_server.ml @@ -64,7 +64,7 @@ let decode64 s = | _ -> failwith "not a base64 string" in let len = String.length s in let len_res = len * 3 / 4 in - let res = String.create len_res in + let res = Bytes.create len_res in for i=0 to len/4 - 1 do let i1 = 4*i and i2 = 3*i in let v1 = (val64 s.[i1]) lsl 18 in @@ -80,7 +80,7 @@ let decode64 s = if s.[len-1] = '=' then if s.[len-2] = '=' then 2 else 1 else 0 in - String.sub res 0 (len_res - nb_cut) + String.sub (Bytes.to_string res) 0 (len_res - nb_cut) let debug = ref false From 7cfcf83134f590ead696ca002b1fb5e0a78157ba Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Tue, 4 Jun 2024 17:58:01 +0200 Subject: [PATCH 05/69] Make strings immutable in tcpbufferedsocket. --- src/utils/net/tcpBufferedSocket.ml | 76 ++++++++++++++--------------- src/utils/net/tcpBufferedSocket.mli | 6 +-- 2 files changed, 41 insertions(+), 41 deletions(-) diff --git a/src/utils/net/tcpBufferedSocket.ml b/src/utils/net/tcpBufferedSocket.ml index 459243c3..ea637077 100644 --- a/src/utils/net/tcpBufferedSocket.ml +++ b/src/utils/net/tcpBufferedSocket.ml @@ -81,7 +81,7 @@ and connection_manager = { } type buf = { - mutable buf : string; + mutable buf : bytes; mutable pos : int; mutable len : int; mutable max_buf_size : int; @@ -352,28 +352,28 @@ let min_buffer_read = 2000 let min_read_size = min_buffer_read - 100 let old_strings_size = 20 -let old_strings = Array.make old_strings_size "" +let old_strings = Array.make old_strings_size Bytes.empty let old_strings_len = ref 0 let new_string () = if !old_strings_len > 0 then begin decr old_strings_len; let s = old_strings.(!old_strings_len) in - old_strings.(!old_strings_len) <- ""; + old_strings.(!old_strings_len) <- Bytes.empty; s end else - String.create min_buffer_read + Bytes.create min_buffer_read let delete_string s = if !old_strings_len < old_strings_size && - String.length s = min_buffer_read then begin + Bytes.length s = min_buffer_read then begin old_strings.(!old_strings_len) <- s; incr old_strings_len; end let buf_create max = { - buf = ""; + buf = Bytes.empty; pos = 0; len = 0; max_buf_size = max; @@ -386,14 +386,14 @@ let buf_used b nused = ( b.len <- 0; b.pos <- 0; delete_string b.buf; - b.buf <- ""; + b.buf <- Bytes.empty; ) else (b.len <- b.len - nused; b.pos <- b.pos + nused) let buf_size t = - (String.length t.rbuf.buf), - (String.length t.wbuf.buf) + (Bytes.length t.rbuf.buf), + (Bytes.length t.wbuf.buf) (*************************************************************************) (* *) @@ -404,17 +404,17 @@ let buf_size t = let buf_add t b s pos1 len = let curpos = b.pos + b.len in let max_len = - if b.buf = "" then + if Bytes.length b.buf = 0 then begin b.buf <- new_string (); min_buffer_read end else - String.length b.buf in + Bytes.length b.buf in if max_len - curpos < len then (* resize before blit *) if b.len + len < max_len then (* just move to 0 *) begin - String.blit b.buf b.pos b.buf 0 b.len; - String.blit s pos1 b.buf b.len len; + Bytes.blit b.buf b.pos b.buf 0 b.len; + Bytes.blit s pos1 b.buf b.len len; b.len <- b.len + len; b.pos <- 0; end @@ -424,7 +424,7 @@ let buf_add t b s pos1 len = lprintf "MESSAGE: ["; for i = pos1 to pos1 + (min len 20) - 1 do - lprintf "(%d)" (int_of_char s.[i]); + lprintf "(%d)" (int_of_char (Bytes.get s i)); done; if len > 20 then lprintf "..."; lprintf "]\n"; @@ -438,8 +438,8 @@ let buf_add t b s pos1 len = (* if t.monitored then (lprintf "Allocate new for %d\n" len; ); *) let new_buf = String.create new_len in - String.blit b.buf b.pos new_buf 0 b.len; - String.blit s pos1 new_buf b.len len; + Bytes.blit b.buf b.pos new_buf 0 b.len; + Bytes.blit s pos1 new_buf b.len len; b.len <- b.len + len; b.pos <- 0; if max_len = min_buffer_read then delete_string b.buf; @@ -447,7 +447,7 @@ let buf_add t b s pos1 len = (lprintf "new buffer allocated\n"; ); *) b.buf <- new_buf else begin - String.blit s pos1 b.buf curpos len; + Bytes.blit s pos1 b.buf curpos len; b.len <- b.len + len end @@ -494,8 +494,8 @@ end; t.closing <- true; delete_string t.rbuf.buf; delete_string t.wbuf.buf; - t.rbuf.buf <- ""; - t.wbuf.buf <- ""; + t.rbuf.buf <- Bytes.empty; + t.wbuf.buf <- Bytes.empty; if t.nread > 0 then begin register_upload t 0; forecast_download t 0; @@ -614,7 +614,7 @@ let can_read_handler t sock max_len = big_buffer, 0, big_buffer_len else let can_write_in_buffer = - if b.buf = "" then + if Bytes.length b.buf = 0 then if b.min_buf_size <= min_buffer_read then begin b.buf <- new_string (); min_buffer_read @@ -623,7 +623,7 @@ let can_read_handler t sock max_len = b.min_buf_size end else - let buf_len = String.length b.buf in + let buf_len = Bytes.length b.buf in if buf_len - curpos < min_read_size then if b.len + min_read_size > b.max_buf_size then ( @@ -635,7 +635,7 @@ let can_read_handler t sock max_len = else if b.len + min_read_size < buf_len then ( - String.blit b.buf b.pos b.buf 0 b.len; + Bytes.blit b.buf b.pos b.buf 0 b.len; b.pos <- 0; buf_len - b.len ) @@ -645,7 +645,7 @@ let can_read_handler t sock max_len = (2 * buf_len) (b.len + min_read_size)) b.max_buf_size in let new_buf = String.create new_len in - String.blit b.buf b.pos new_buf 0 b.len; + Bytes.blit b.buf b.pos new_buf 0 b.len; b.pos <- 0; b.buf <- new_buf; new_len - b.len @@ -774,7 +774,7 @@ let can_write_handler t sock max_len = if b.len = 0 then begin b.pos <- 0; delete_string b.buf; - b.buf <- ""; + b.buf <- Bytes.empty; end with Unix.Unix_error((Unix.EWOULDBLOCK | Unix.EAGAIN ), _,_) as e -> raise e @@ -1052,10 +1052,10 @@ let set_reader t f = let rcode, rstr, rstr_end = try let rcode_pos = 8 (*String.index_from b.buf b.pos ' '*) in - let rcode = String.sub b.buf (rcode_pos+1) 3 in + let rcode = Bytes.sub b.buf (rcode_pos+1) 3 in let rstr_pos = 12 (*String.index_from b.buf (rcode_pos+1) ' '*) in - let rstr_end = String.index_from b.buf (rstr_pos+1) '\n' in - let rstr = String.sub b.buf (rstr_pos+1) (rstr_end-rstr_pos-1) in + let rstr_end = Bytes.index_from b.buf (rstr_pos+1) '\n' in + let rstr = Bytes.sub b.buf (rstr_pos+1) (rstr_end-rstr_pos-1) in lprintf "From proxy for %s: %s %s\n" (Ip.to_string sock.host) rcode rstr; rcode, rstr, rstr_end @@ -1064,7 +1064,7 @@ let set_reader t f = in (match rcode with "200" -> (*lprintf "Connect to client via proxy ok\n";*) - let pos = String.index_from b.buf (rstr_end+1) '\n' in + let pos = Bytes.index_from b.buf (rstr_end+1) '\n' in let used = pos + 1 - b.pos in sock_used sock used; if nread != used then @@ -1147,14 +1147,14 @@ let dump_socket t buf = print_socket buf t.sock_in; print_socket buf t.sock_out; Printf.bprintf buf "rbuf: %d/%d wbuf: %d/%d\n" t.rbuf.len - (String.length t.rbuf.buf) t.wbuf.len (String.length t.wbuf.buf) + (Bytes.length t.rbuf.buf) t.wbuf.len (Bytes.length t.wbuf.buf) let stats buf t = BasicSocket.stats buf t.sock_in; BasicSocket.stats buf t.sock_out; - Printf.bprintf buf " rbuf size: %d/%d\n" (String.length t.rbuf.buf) + Printf.bprintf buf " rbuf size: %d/%d\n" (Bytes.length t.rbuf.buf) t.rbuf.max_buf_size; - Printf.bprintf buf " wbuf size: %d/%d\n" (String.length t.wbuf.buf) + Printf.bprintf buf " wbuf size: %d/%d\n" (Bytes.length t.wbuf.buf) t.wbuf.max_buf_size (*************************************************************************) @@ -1354,7 +1354,7 @@ let connect token name host port handler = end; Printf.bprintf buf "User-Agent: MLdonkey/%s\n" Autoconf.current_version; Printf.bprintf buf "\n"; - ignore (MlUnix.write s (Buffer.contents buf) 0 (Buffer.length buf)) + ignore (MlUnix.write s (Buffer.to_bytes buf) 0 (Buffer.length buf)) end; let t = create token name s handler in @@ -1461,12 +1461,12 @@ open LittleEndian let internal_buf = Buffer.create 17000 let simple_send_buf buf sock = - let s = Buffer.contents buf in + let s = Buffer.to_bytes buf in Buffer.reset buf; buf_int8 buf 228; - let len = String.length s in + let len = Bytes.length s in buf_int buf len; - write sock (Buffer.contents buf) 0 5; + write sock (Buffer.to_bytes buf) 0 5; write sock s 0 len let value_send sock m = @@ -1482,7 +1482,7 @@ let value_handler f sock nread = let msg_len = get_int b.buf (b.pos+1) in if b.len >= 5 + msg_len then begin - let s = String.sub b.buf (b.pos+5) msg_len in + let s = Bytes.sub b.buf (b.pos+5) msg_len in let t = Marshal.from_string s 0 in buf_used b (msg_len + 5); f t sock; @@ -1624,7 +1624,7 @@ let write t s pos len = (* *) (*************************************************************************) -let write_string t s = write t s 0 (String.length s) +let write_string t s = write t (Bytes.of_string s) 0 (String.length s) let _ = add_bandwidth_second_timer (fun _ -> @@ -1800,7 +1800,7 @@ let output_buffered t = t.wbuf.len let _ = Heap.add_memstat "tcpBufferedSocket" (fun level buf -> Printf.bprintf buf " %d latencies\n" (Hashtbl.length latencies); - Printf.bprintf buf " String.length big_buffer: %d\n" (String.length big_buffer); + Printf.bprintf buf " String.length big_buffer: %d\n" (Bytes.length big_buffer); Printf.bprintf buf " connection_managers: %d\n" (List.length !connection_managers); Printf.bprintf buf " read_bandwidth_controlers: %d\n" (List.length !read_bandwidth_controlers); Printf.bprintf buf " write_bandwidth_controlers: %d\n" (List.length !write_bandwidth_controlers); diff --git a/src/utils/net/tcpBufferedSocket.mli b/src/utils/net/tcpBufferedSocket.mli index b70bfcc3..3a2ffed4 100644 --- a/src/utils/net/tcpBufferedSocket.mli +++ b/src/utils/net/tcpBufferedSocket.mli @@ -26,7 +26,7 @@ type event = and buf = { - mutable buf : string; + mutable buf : bytes; mutable pos : int; mutable len : int; mutable max_buf_size : int; @@ -61,11 +61,11 @@ val set_reader : t -> (t -> int -> unit) -> unit val sock_used : t -> int -> unit val buf_create : int -> buf val buf_used : buf -> int -> unit -val buf_add : t -> buf -> string -> int -> int -> unit +val buf_add : t -> buf -> bytes -> int -> int -> unit val set_handler : t -> event -> (t -> unit) -> unit val set_refill : t -> (t -> unit) -> unit val set_rtimer : t -> (t -> unit) -> unit -val write: t -> string -> int -> int -> unit +val write: t -> bytes -> int -> int -> unit val write_string: t -> string -> unit val connect: token -> string -> Unix.inet_addr -> int -> handler -> t val close : t -> BasicSocket.close_reason -> unit From 0657f8c3786849c80b90c70118e6406b66a1a8b1 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Tue, 4 Jun 2024 18:29:59 +0200 Subject: [PATCH 06/69] Updated the bitstring library for string immutability. --- src/utils/bitstring/bitstring.ml.in | 347 +++-- src/utils/bitstring/bitstring.mli | 132 +- src/utils/bitstring/bitstring_c.c | 228 ++- src/utils/bitstring/bitstring_persistent.mlc4 | 2 +- src/utils/bitstring/pa_bitstring.mlt | 1361 ++++++++--------- src/utils/net/http_server.ml | 10 +- 6 files changed, 1096 insertions(+), 984 deletions(-) diff --git a/src/utils/bitstring/bitstring.ml.in b/src/utils/bitstring/bitstring.ml.in index fa89e0ce..8ba56c84 100644 --- a/src/utils/bitstring/bitstring.ml.in +++ b/src/utils/bitstring/bitstring.ml.in @@ -44,15 +44,15 @@ exception Construct_failure of string * string * int * int * bitoffset and the bitlength within the string. Note offset/length * are counted in bits, not bytes. *) -type bitstring = string * int * int +type bitstring = bytes * int * int type t = bitstring (* Functions to create and load bitstrings. *) -let empty_bitstring = "", 0, 0 +let empty_bitstring = Bytes.create 0, 0, 0 let make_bitstring len c = - if len >= 0 then String.make ((len+7) lsr 3) c, 0, len + if len >= 0 then Bytes.make ((len+7) lsr 3) c, 0, len else invalid_arg ( sprintf "make_bitstring/create_bitstring: len %d < 0" len @@ -64,65 +64,65 @@ let zeroes_bitstring = create_bitstring let ones_bitstring len = make_bitstring len '\xff' -let bitstring_of_string str = str, 0, String.length str lsl 3 +let bitstring_of_string str = Bytes.of_string str, 0, String.length str lsl 3 let bitstring_of_chan chan = let tmpsize = 16384 in let buf = Buffer.create tmpsize in - let tmp = String.create tmpsize in + let tmp = Bytes.create tmpsize in let n = ref 0 in while n := input chan tmp 0 tmpsize; !n > 0 do - Buffer.add_substring buf tmp 0 !n; + Buffer.add_subbytes buf tmp 0 !n; done; - Buffer.contents buf, 0, Buffer.length buf lsl 3 + Buffer.to_bytes buf, 0, Buffer.length buf lsl 3 let bitstring_of_chan_max chan max = let tmpsize = 16384 in let buf = Buffer.create tmpsize in - let tmp = String.create tmpsize in + let tmp = Bytes.create tmpsize in let len = ref 0 in let rec loop () = if !len < max then ( let r = min tmpsize (max - !len) in let n = input chan tmp 0 r in if n > 0 then ( - Buffer.add_substring buf tmp 0 n; - len := !len + n; - loop () + Buffer.add_subbytes buf tmp 0 n; + len := !len + n; + loop () ) ) in loop (); - Buffer.contents buf, 0, !len lsl 3 + Buffer.to_bytes buf, 0, !len lsl 3 let bitstring_of_file_descr fd = let tmpsize = 16384 in let buf = Buffer.create tmpsize in - let tmp = String.create tmpsize in + let tmp = Bytes.create tmpsize in let n = ref 0 in while n := Unix.read fd tmp 0 tmpsize; !n > 0 do - Buffer.add_substring buf tmp 0 !n; + Buffer.add_subbytes buf tmp 0 !n; done; - Buffer.contents buf, 0, Buffer.length buf lsl 3 + Buffer.to_bytes buf, 0, Buffer.length buf lsl 3 let bitstring_of_file_descr_max fd max = let tmpsize = 16384 in let buf = Buffer.create tmpsize in - let tmp = String.create tmpsize in + let tmp = Bytes.create tmpsize in let len = ref 0 in let rec loop () = if !len < max then ( let r = min tmpsize (max - !len) in let n = Unix.read fd tmp 0 r in if n > 0 then ( - Buffer.add_substring buf tmp 0 n; - len := !len + n; - loop () + Buffer.add_subbytes buf tmp 0 n; + len := !len + n; + loop () ) ) in loop (); - Buffer.contents buf, 0, !len lsl 3 + Buffer.to_bytes buf, 0, !len lsl 3 let bitstring_of_file fname = let chan = open_in_bin fname in @@ -394,18 +394,32 @@ end let extract_bit data off len _ = (* final param is always 1 *) let byteoff = off lsr 3 in let bitmask = 1 lsl (7 - (off land 7)) in - let b = Char.code data.[byteoff] land bitmask <> 0 in + let b = Char.code (Bytes.get data byteoff) land bitmask <> 0 in b (*, off+1, len-1*) (* Returns 8 bit unsigned aligned bytes from the string. * If the string ends then this returns 0's. *) let _get_byte data byteoff strlen = - if strlen > byteoff then Char.code data.[byteoff] else 0 + if strlen > byteoff then Char.code (Bytes.get data byteoff) else 0 let _get_byte32 data byteoff strlen = - if strlen > byteoff then Int32.of_int (Char.code data.[byteoff]) else 0l + if strlen > byteoff then + Int32.of_int (Char.code (Bytes.get data byteoff)) + else 0l let _get_byte64 data byteoff strlen = - if strlen > byteoff then Int64.of_int (Char.code data.[byteoff]) else 0L + if strlen > byteoff then + Int64.of_int (Char.code (Bytes.get data byteoff)) + else 0L + +(* Extend signed [2..31] bits int to 31 bits int or 63 bits int for 64 + bits platform*) +let extend_sign len v = + let b = pred Sys.word_size - len in + (v lsl b) asr b + +let extract_and_extend_sign f data off len flen = + let w = f data off len flen in + extend_sign flen w (* Extract [2..8] bits. Because the result fits into a single * byte we don't have to worry about endianness, only signedness. @@ -415,17 +429,17 @@ let extract_char_unsigned data off len flen = (* Optimize the common (byte-aligned) case. *) if off land 7 = 0 then ( - let byte = Char.code data.[byteoff] in + let byte = Char.code (Bytes.get data byteoff) in byte lsr (8 - flen) (*, off+flen, len-flen*) ) else ( (* Extract the 16 bits at byteoff and byteoff+1 (note that the * second byte might not exist in the original string). *) - let strlen = String.length data in + let strlen = Bytes.length data in let word = (_get_byte data byteoff strlen lsl 8) + - _get_byte data (byteoff+1) strlen in + _get_byte data (byteoff+1) strlen in (* Mask off the top bits. *) let bitmask = (1 lsl (16 - (off land 7))) - 1 in @@ -437,28 +451,31 @@ let extract_char_unsigned data off len flen = word (*, off+flen, len-flen*) ) +let extract_char_signed = + extract_and_extend_sign extract_char_unsigned + (* Extract [9..31] bits. We have to consider endianness and signedness. *) let extract_int_be_unsigned data off len flen = let byteoff = off lsr 3 in - let strlen = String.length data in + let strlen = Bytes.length data in let word = (* Optimize the common (byte-aligned) case. *) if off land 7 = 0 then ( let word = - (_get_byte data byteoff strlen lsl 23) + - (_get_byte data (byteoff+1) strlen lsl 15) + - (_get_byte data (byteoff+2) strlen lsl 7) + - (_get_byte data (byteoff+3) strlen lsr 1) in + (_get_byte data byteoff strlen lsl 23) + + (_get_byte data (byteoff+1) strlen lsl 15) + + (_get_byte data (byteoff+2) strlen lsl 7) + + (_get_byte data (byteoff+3) strlen lsr 1) in word lsr (31 - flen) ) else if flen <= 24 then ( (* Extract the 31 bits at byteoff .. byteoff+3. *) let word = - (_get_byte data byteoff strlen lsl 23) + - (_get_byte data (byteoff+1) strlen lsl 15) + - (_get_byte data (byteoff+2) strlen lsl 7) + - (_get_byte data (byteoff+3) strlen lsr 1) in + (_get_byte data byteoff strlen lsl 23) + + (_get_byte data (byteoff+1) strlen lsl 15) + + (_get_byte data (byteoff+2) strlen lsl 7) + + (_get_byte data (byteoff+3) strlen lsr 1) in (* Mask off the top bits. *) let bitmask = (1 lsl (31 - (off land 7))) - 1 in let word = word land bitmask in @@ -468,33 +485,45 @@ let extract_int_be_unsigned data off len flen = ) else ( (* Extract the next 31 bits, slow method. *) let word = - let c0 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c1 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c2 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c3 = extract_char_unsigned data off len 7 in - (c0 lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in + let c0 = extract_char_unsigned data off len 8 + and off = off + 8 and len = len - 8 in + let c1 = extract_char_unsigned data off len 8 + and off = off + 8 and len = len - 8 in + let c2 = extract_char_unsigned data off len 8 + and off = off + 8 and len = len - 8 in + let c3 = extract_char_unsigned data off len 7 in + (c0 lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in word lsr (31 - flen) ) in word (*, off+flen, len-flen*) +let extract_int_be_signed = + extract_and_extend_sign extract_int_be_unsigned + let extract_int_le_unsigned data off len flen = let v = extract_int_be_unsigned data off len flen in let v = I.byteswap v flen in v +let extract_int_le_signed = + extract_and_extend_sign extract_int_le_unsigned + let extract_int_ne_unsigned = if nativeendian = BigEndian then extract_int_be_unsigned else extract_int_le_unsigned +let extract_int_ne_signed = + extract_and_extend_sign extract_int_ne_unsigned + let extract_int_ee_unsigned = function | BigEndian -> extract_int_be_unsigned | LittleEndian -> extract_int_le_unsigned | NativeEndian -> extract_int_ne_unsigned +let extract_int_ee_signed e = + extract_and_extend_sign (extract_int_ee_unsigned e) + let _make_int32_be c0 c1 c2 c3 = Int32.logor (Int32.logor @@ -517,7 +546,7 @@ let _make_int32_le c0 c1 c2 c3 = let extract_int32_be_unsigned data off len flen = let byteoff = off lsr 3 in - let strlen = String.length data in + let strlen = Bytes.length data in let word = (* Optimize the common (byte-aligned) case. *) @@ -587,7 +616,7 @@ let _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 = let extract_int64_be_unsigned data off len flen = let byteoff = off lsr 3 in - let strlen = String.length data in + let strlen = Bytes.length data in let word = (* Optimize the common (byte-aligned) case. *) @@ -606,30 +635,30 @@ let extract_int64_be_unsigned data off len flen = ) else ( (* Extract the next 64 bits, slow method. *) let word = - let c0 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c1 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c2 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c3 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c4 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c5 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c6 = extract_char_unsigned data off len 8 - and off = off + 8 and len = len - 8 in - let c7 = extract_char_unsigned data off len 8 in - let c0 = Int64.of_int c0 in - let c1 = Int64.of_int c1 in - let c2 = Int64.of_int c2 in - let c3 = Int64.of_int c3 in - let c4 = Int64.of_int c4 in - let c5 = Int64.of_int c5 in - let c6 = Int64.of_int c6 in - let c7 = Int64.of_int c7 in - _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in + let c0 = extract_char_unsigned data off len 8 + and off = off + 8 and len = len - 8 in + let c1 = extract_char_unsigned data off len 8 + and off = off + 8 and len = len - 8 in + let c2 = extract_char_unsigned data off len 8 + and off = off + 8 and len = len - 8 in + let c3 = extract_char_unsigned data off len 8 + and off = off + 8 and len = len - 8 in + let c4 = extract_char_unsigned data off len 8 + and off = off + 8 and len = len - 8 in + let c5 = extract_char_unsigned data off len 8 + and off = off + 8 and len = len - 8 in + let c6 = extract_char_unsigned data off len 8 + and off = off + 8 and len = len - 8 in + let c7 = extract_char_unsigned data off len 8 in + let c0 = Int64.of_int c0 in + let c1 = Int64.of_int c1 in + let c2 = Int64.of_int c2 in + let c3 = Int64.of_int c3 in + let c4 = Int64.of_int c4 in + let c5 = Int64.of_int c5 in + let c6 = Int64.of_int c6 in + let c7 = Int64.of_int c7 in + _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in Int64.shift_right_logical word (64 - flen) ) in word (*, off+flen, len-flen*) @@ -637,7 +666,7 @@ let extract_int64_be_unsigned data off len flen = let extract_int64_le_unsigned data off len flen = let byteoff = off lsr 3 in - let strlen = String.length data in + let strlen = Bytes.length data in let word = (* Optimize the common (byte-aligned) case. *) @@ -694,93 +723,93 @@ let extract_int64_ee_unsigned = function | LittleEndian -> extract_int64_le_unsigned | NativeEndian -> extract_int64_ne_unsigned -external extract_fastpath_int16_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" "noalloc" +external extract_fastpath_int16_be_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" -external extract_fastpath_int16_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc" +external extract_fastpath_int16_le_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" -external extract_fastpath_int16_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc" +external extract_fastpath_int16_ne_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" -external extract_fastpath_int16_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc" +external extract_fastpath_int16_be_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" -external extract_fastpath_int16_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc" +external extract_fastpath_int16_le_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" -external extract_fastpath_int16_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc" +external extract_fastpath_int16_ne_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" (* -external extract_fastpath_int24_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc" +external extract_fastpath_int24_be_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" -external extract_fastpath_int24_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc" +external extract_fastpath_int24_le_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" -external extract_fastpath_int24_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc" +external extract_fastpath_int24_ne_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" -external extract_fastpath_int24_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc" +external extract_fastpath_int24_be_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" -external extract_fastpath_int24_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc" +external extract_fastpath_int24_le_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" -external extract_fastpath_int24_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc" +external extract_fastpath_int24_ne_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" *) -external extract_fastpath_int32_be_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_unsigned" "noalloc" +external extract_fastpath_int32_be_unsigned : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_unsigned" -external extract_fastpath_int32_le_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_unsigned" "noalloc" +external extract_fastpath_int32_le_unsigned : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_unsigned" -external extract_fastpath_int32_ne_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" "noalloc" +external extract_fastpath_int32_ne_unsigned : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" -external extract_fastpath_int32_be_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_signed" "noalloc" +external extract_fastpath_int32_be_signed : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_signed" -external extract_fastpath_int32_le_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_signed" "noalloc" +external extract_fastpath_int32_le_signed : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_signed" -external extract_fastpath_int32_ne_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_signed" "noalloc" +external extract_fastpath_int32_ne_signed : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_signed" (* -external extract_fastpath_int40_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned" "noalloc" +external extract_fastpath_int40_be_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned" -external extract_fastpath_int40_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned" "noalloc" +external extract_fastpath_int40_le_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned" -external extract_fastpath_int40_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" "noalloc" +external extract_fastpath_int40_ne_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" -external extract_fastpath_int40_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed" "noalloc" +external extract_fastpath_int40_be_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed" -external extract_fastpath_int40_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed" "noalloc" +external extract_fastpath_int40_le_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed" -external extract_fastpath_int40_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed" "noalloc" +external extract_fastpath_int40_ne_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed" -external extract_fastpath_int48_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned" "noalloc" +external extract_fastpath_int48_be_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned" -external extract_fastpath_int48_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned" "noalloc" +external extract_fastpath_int48_le_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned" -external extract_fastpath_int48_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" "noalloc" +external extract_fastpath_int48_ne_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" -external extract_fastpath_int48_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed" "noalloc" +external extract_fastpath_int48_be_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed" -external extract_fastpath_int48_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed" "noalloc" +external extract_fastpath_int48_le_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed" -external extract_fastpath_int48_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed" "noalloc" +external extract_fastpath_int48_ne_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed" -external extract_fastpath_int56_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned" "noalloc" +external extract_fastpath_int56_be_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned" -external extract_fastpath_int56_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned" "noalloc" +external extract_fastpath_int56_le_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned" -external extract_fastpath_int56_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" "noalloc" +external extract_fastpath_int56_ne_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" -external extract_fastpath_int56_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed" "noalloc" +external extract_fastpath_int56_be_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed" -external extract_fastpath_int56_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed" "noalloc" +external extract_fastpath_int56_le_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed" -external extract_fastpath_int56_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed" "noalloc" +external extract_fastpath_int56_ne_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed" *) -external extract_fastpath_int64_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_unsigned" "noalloc" +external extract_fastpath_int64_be_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_unsigned" -external extract_fastpath_int64_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_unsigned" "noalloc" +external extract_fastpath_int64_le_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_unsigned" -external extract_fastpath_int64_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" "noalloc" +external extract_fastpath_int64_ne_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" -external extract_fastpath_int64_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_signed" "noalloc" +external extract_fastpath_int64_be_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_signed" -external extract_fastpath_int64_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_signed" "noalloc" +external extract_fastpath_int64_le_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_signed" -external extract_fastpath_int64_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_signed" "noalloc" +external extract_fastpath_int64_ne_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_signed" (*----------------------------------------------------------------------*) (* Constructor functions. *) @@ -804,9 +833,9 @@ module Buffer = struct let contents { buf = buf; len = len; last = last } = let data = if len land 7 = 0 then - Buffer.contents buf + Buffer.to_bytes buf else - Buffer.contents buf ^ (String.make 1 (Char.chr last)) in + Bytes.cat (Buffer.to_bytes buf) (Bytes.make 1 (Char.chr last)) in data, 0, len (* Add exactly 8 bits. *) @@ -849,38 +878,40 @@ module Buffer = struct add_bit t bit done - let add_bits ({ buf = buf; len = len; last = _ } as t) str slen = + let add_bits t str slen = + let {buf; len; _} = t in if slen > 0 then ( if len land 7 = 0 then ( - if slen land 7 = 0 then + if slen land 7 = 0 then (* Common case - everything is byte-aligned. *) - Buffer.add_substring buf str 0 (slen lsr 3) - else ( + Buffer.add_subbytes buf str 0 (slen lsr 3) + else ( (* Target buffer is aligned. Copy whole bytes then leave the - * remaining bits in last. - *) + * remaining bits in last. + *) let slenbytes = slen lsr 3 in - if slenbytes > 0 then Buffer.add_substring buf str 0 slenbytes; - let last = Char.code str.[slenbytes] in (* last char *) + if slenbytes > 0 then Buffer.add_subbytes buf str 0 slenbytes; + let lastidx = min slenbytes (Bytes.length str - 1) in + let last = Char.code (Bytes.get str lastidx) in (* last char *) let mask = 0xff lsl (8 - (slen land 7)) in t.last <- last land mask - ); - t.len <- len + slen + ); + t.len <- len + slen ) else ( (* Target buffer is unaligned. Copy whole bytes using - * add_byte which knows how to deal with an unaligned - * target buffer, then call add_bit for the remaining < 8 bits. - * - * XXX This is going to be dog-slow. - *) + * add_byte which knows how to deal with an unaligned + * target buffer, then call add_bit for the remaining < 8 bits. + * + * XXX This is going to be dog-slow. + *) let slenbytes = slen lsr 3 in for i = 0 to slenbytes-1 do - let byte = Char.code str.[i] in + let byte = Char.code (Bytes.get str i) in add_byte t byte done; let bitsleft = slen - (slenbytes lsl 3) in if bitsleft > 0 then ( - let c = Char.code str.[slenbytes] in + let c = Char.code (Bytes.get str slenbytes) in for i = 0 to bitsleft - 1 do let bit = c land (0x80 lsr i) <> 0 in add_bit t bit @@ -987,7 +1018,7 @@ let construct_int64_ee_unsigned = function *) let construct_string buf str = let len = String.length str in - Buffer.add_bits buf str (len lsl 3) + Buffer.add_bits buf (Bytes.unsafe_of_string str) (len lsl 3) (* Construct from a bitstring. *) let construct_bitstring buf (data, off, len) = @@ -1000,7 +1031,7 @@ let construct_bitstring buf (data, off, len) = if blen = 0 then (off, len) else ( let b = extract_bit data off len 1 - and off = off + 1 and len = len + 1 in + and off = off + 1 and len = len - 1 in Buffer.add_bit buf b; loop off len (blen-1) ) @@ -1013,7 +1044,7 @@ let construct_bitstring buf (data, off, len) = let off = off lsr 3 in (* XXX dangerous allocation *) if off = 0 then data - else String.sub data off (String.length data - off) in + else Bytes.sub data off (Bytes.length data - off) in Buffer.add_bits buf data len @@ -1028,24 +1059,24 @@ let concat bs = let string_of_bitstring (data, off, len) = if off land 7 = 0 && len land 7 = 0 then (* Easy case: everything is byte-aligned. *) - String.sub data (off lsr 3) (len lsr 3) + String.sub (Bytes.unsafe_to_string data) (off lsr 3) (len lsr 3) else ( (* Bit-twiddling case. *) let strlen = (len + 7) lsr 3 in - let str = String.make strlen '\000' in + let str = Bytes.make strlen '\000' in let rec loop data off len i = if len >= 8 then ( let c = extract_char_unsigned data off len 8 and off = off + 8 and len = len - 8 in - str.[i] <- Char.chr c; + Bytes.set str i (Char.chr c); loop data off len (i+1) - ) else if len > 0 then ( + ) else if len > 0 then ( let c = extract_char_unsigned data off len len in - str.[i] <- Char.chr (c lsl (8-len)) + Bytes.set str i (Char.chr (c lsl (8-len))) ) in loop data off len 0; - str + Bytes.unsafe_to_string str ) (* To channel. *) @@ -1085,11 +1116,11 @@ let compare ((data1, off1, len1) as bs1) ((data2, off2, len2) as bs2) = and len1 = len1 lsr 3 and len2 = len2 lsr 3 in let rec loop i = if i < len1 && i < len2 then ( - let c1 = String.unsafe_get data1 (off1 + i) - and c2 = String.unsafe_get data2 (off2 + i) in - let r = compare c1 c2 in - if r <> 0 then r - else loop (i+1) + let c1 = Bytes.unsafe_get data1 (off1 + i) + and c2 = Bytes.unsafe_get data2 (off2 + i) in + let r = compare c1 c2 in + if r <> 0 then r + else loop (i+1) ) else len1 - len2 in @@ -1118,9 +1149,9 @@ let put (data, off, len) n v = else ( let i = off+n in let si = i lsr 3 and mask = 0x80 lsr (i land 7) in - let c = Char.code data.[si] in + let c = Char.code (Bytes.get data si) in let c = if v <> 0 then c lor mask else c land (lnot mask) in - data.[si] <- Char.unsafe_chr c + Bytes.set data si (Char.unsafe_chr c) ) let set bits n = put bits n 1 @@ -1132,7 +1163,7 @@ let get (data, off, len) n = else ( let i = off+n in let si = i lsr 3 and mask = 0x80 lsr (i land 7) in - let c = Char.code data.[si] in + let c = Char.code (Bytes.get data si) in c land mask ) @@ -1152,7 +1183,7 @@ let hexdump_bitstring chan (data, off, len) = let off = ref off in let len = ref len in let linelen = ref 0 in - let linechars = String.make 16 ' ' in + let linechars = Bytes.make 16 ' ' in fprintf chan "00000000 "; @@ -1165,21 +1196,27 @@ let hexdump_bitstring chan (data, off, len) = fprintf chan "%02x " byte; incr count; - linechars.[!linelen] <- + Bytes.set linechars !linelen (let c = Char.chr byte in if isprint c then c else '.'); incr linelen; if !linelen = 8 then fprintf chan " "; if !linelen = 16 then ( - fprintf chan " |%s|\n%08x " linechars !count; + fprintf chan " |%s|\n%08x " (Bytes.unsafe_to_string linechars) !count; linelen := 0; - for i = 0 to 15 do linechars.[i] <- ' ' done + for i = 0 to 15 do Bytes.set linechars i ' ' done ) done; if !linelen > 0 then ( let skip = (16 - !linelen) * 3 + if !linelen < 8 then 1 else 0 in - for i = 0 to skip-1 do fprintf chan " " done; - fprintf chan " |%s|\n%!" linechars + for _ = 0 to skip-1 do fprintf chan " " done; + fprintf chan " |%s|\n%!" (Bytes.unsafe_to_string linechars) ) else fprintf chan "\n%!" + +(*----------------------------------------------------------------------*) +(* Alias of functions shadowed by Core. *) + +let char_code = Char.code +let int32_of_int = Int32.of_int diff --git a/src/utils/bitstring/bitstring.mli b/src/utils/bitstring/bitstring.mli index b6654c02..f478521e 100644 --- a/src/utils/bitstring/bitstring.mli +++ b/src/utils/bitstring/bitstring.mli @@ -645,10 +645,10 @@ bitmatch bits with {3 Types} *) -type bitstring = string * int * int +type bitstring = bytes * int * int (** [bitstring] is the basic type used to store bitstrings. - The type contains the underlying data (a string), + The type contains the underlying data (a bytes), the current bit offset within the string and the current bit length of the string (counting from the bit offset). Note that the offset and length are @@ -865,7 +865,7 @@ module Buffer : sig type t val create : unit -> t val contents : t -> bitstring - val add_bits : t -> string -> int -> unit + val add_bits : t -> bytes -> int -> unit val add_bit : t -> bool -> unit val add_byte : t -> int -> unit end @@ -931,121 +931,131 @@ val nativeendian : endian (* 'extract' functions are used in bitmatch statements. *) -val extract_bit : string -> int -> int -> int -> bool +val extract_bit : bytes -> int -> int -> int -> bool -val extract_char_unsigned : string -> int -> int -> int -> int +val extract_char_unsigned : bytes -> int -> int -> int -> int -val extract_int_be_unsigned : string -> int -> int -> int -> int +val extract_char_signed : bytes -> int -> int -> int -> int -val extract_int_le_unsigned : string -> int -> int -> int -> int +val extract_int_be_unsigned : bytes -> int -> int -> int -> int -val extract_int_ne_unsigned : string -> int -> int -> int -> int +val extract_int_be_signed : bytes -> int -> int -> int -> int -val extract_int_ee_unsigned : endian -> string -> int -> int -> int -> int +val extract_int_le_unsigned : bytes -> int -> int -> int -> int -val extract_int32_be_unsigned : string -> int -> int -> int -> int32 +val extract_int_le_signed : bytes -> int -> int -> int -> int -val extract_int32_le_unsigned : string -> int -> int -> int -> int32 +val extract_int_ne_unsigned : bytes -> int -> int -> int -> int -val extract_int32_ne_unsigned : string -> int -> int -> int -> int32 +val extract_int_ne_signed : bytes -> int -> int -> int -> int -val extract_int32_ee_unsigned : endian -> string -> int -> int -> int -> int32 +val extract_int_ee_unsigned : endian -> bytes -> int -> int -> int -> int -val extract_int64_be_unsigned : string -> int -> int -> int -> int64 +val extract_int_ee_signed : endian -> bytes -> int -> int -> int -> int -val extract_int64_le_unsigned : string -> int -> int -> int -> int64 +val extract_int32_be_unsigned : bytes -> int -> int -> int -> int32 -val extract_int64_ne_unsigned : string -> int -> int -> int -> int64 +val extract_int32_le_unsigned : bytes -> int -> int -> int -> int32 -val extract_int64_ee_unsigned : endian -> string -> int -> int -> int -> int64 +val extract_int32_ne_unsigned : bytes -> int -> int -> int -> int32 -external extract_fastpath_int16_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" "noalloc" +val extract_int32_ee_unsigned : endian -> bytes -> int -> int -> int -> int32 -external extract_fastpath_int16_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc" +val extract_int64_be_unsigned : bytes -> int -> int -> int -> int64 -external extract_fastpath_int16_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc" +val extract_int64_le_unsigned : bytes -> int -> int -> int -> int64 -external extract_fastpath_int16_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc" +val extract_int64_ne_unsigned : bytes -> int -> int -> int -> int64 -external extract_fastpath_int16_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc" +val extract_int64_ee_unsigned : endian -> bytes -> int -> int -> int -> int64 -external extract_fastpath_int16_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc" +external extract_fastpath_int16_be_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_unsigned" + +external extract_fastpath_int16_le_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_unsigned" + +external extract_fastpath_int16_ne_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_unsigned" + +external extract_fastpath_int16_be_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_be_signed" + +external extract_fastpath_int16_le_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_le_signed" + +external extract_fastpath_int16_ne_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int16_ne_signed" (* -external extract_fastpath_int24_be_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc" +external extract_fastpath_int24_be_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_unsigned" -external extract_fastpath_int24_le_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc" +external extract_fastpath_int24_le_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_unsigned" -external extract_fastpath_int24_ne_unsigned : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc" +external extract_fastpath_int24_ne_unsigned : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_unsigned" -external extract_fastpath_int24_be_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc" +external extract_fastpath_int24_be_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_be_signed" -external extract_fastpath_int24_le_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc" +external extract_fastpath_int24_le_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_le_signed" -external extract_fastpath_int24_ne_signed : string -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc" +external extract_fastpath_int24_ne_signed : bytes -> int -> int = "ocaml_bitstring_extract_fastpath_int24_ne_signed" *) -external extract_fastpath_int32_be_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_unsigned" "noalloc" +external extract_fastpath_int32_be_unsigned : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_unsigned" -external extract_fastpath_int32_le_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_unsigned" "noalloc" +external extract_fastpath_int32_le_unsigned : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_unsigned" -external extract_fastpath_int32_ne_unsigned : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" "noalloc" +external extract_fastpath_int32_ne_unsigned : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" -external extract_fastpath_int32_be_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_signed" "noalloc" +external extract_fastpath_int32_be_signed : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_be_signed" -external extract_fastpath_int32_le_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_signed" "noalloc" +external extract_fastpath_int32_le_signed : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_le_signed" -external extract_fastpath_int32_ne_signed : string -> int -> int32 -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_signed" "noalloc" +external extract_fastpath_int32_ne_signed : bytes -> int -> int32 = "ocaml_bitstring_extract_fastpath_int32_ne_signed" (* -external extract_fastpath_int40_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned" "noalloc" +external extract_fastpath_int40_be_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_unsigned" -external extract_fastpath_int40_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned" "noalloc" +external extract_fastpath_int40_le_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_unsigned" -external extract_fastpath_int40_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" "noalloc" +external extract_fastpath_int40_ne_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" -external extract_fastpath_int40_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed" "noalloc" +external extract_fastpath_int40_be_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_be_signed" -external extract_fastpath_int40_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed" "noalloc" +external extract_fastpath_int40_le_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_le_signed" -external extract_fastpath_int40_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed" "noalloc" +external extract_fastpath_int40_ne_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int40_ne_signed" -external extract_fastpath_int48_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned" "noalloc" +external extract_fastpath_int48_be_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_unsigned" -external extract_fastpath_int48_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned" "noalloc" +external extract_fastpath_int48_le_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_unsigned" -external extract_fastpath_int48_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" "noalloc" +external extract_fastpath_int48_ne_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" -external extract_fastpath_int48_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed" "noalloc" +external extract_fastpath_int48_be_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_be_signed" -external extract_fastpath_int48_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed" "noalloc" +external extract_fastpath_int48_le_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_le_signed" -external extract_fastpath_int48_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed" "noalloc" +external extract_fastpath_int48_ne_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int48_ne_signed" -external extract_fastpath_int56_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned" "noalloc" +external extract_fastpath_int56_be_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_unsigned" -external extract_fastpath_int56_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned" "noalloc" +external extract_fastpath_int56_le_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_unsigned" -external extract_fastpath_int56_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" "noalloc" +external extract_fastpath_int56_ne_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" -external extract_fastpath_int56_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed" "noalloc" +external extract_fastpath_int56_be_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_be_signed" -external extract_fastpath_int56_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed" "noalloc" +external extract_fastpath_int56_le_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_le_signed" -external extract_fastpath_int56_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed" "noalloc" +external extract_fastpath_int56_ne_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int56_ne_signed" *) -external extract_fastpath_int64_be_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_unsigned" "noalloc" +external extract_fastpath_int64_be_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_unsigned" -external extract_fastpath_int64_le_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_unsigned" "noalloc" +external extract_fastpath_int64_le_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_unsigned" -external extract_fastpath_int64_ne_unsigned : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" "noalloc" +external extract_fastpath_int64_ne_unsigned : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" -external extract_fastpath_int64_be_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_signed" "noalloc" +external extract_fastpath_int64_be_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_be_signed" -external extract_fastpath_int64_le_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_signed" "noalloc" +external extract_fastpath_int64_le_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_le_signed" -external extract_fastpath_int64_ne_signed : string -> int -> int64 -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_signed" "noalloc" +external extract_fastpath_int64_ne_signed : bytes -> int -> int64 = "ocaml_bitstring_extract_fastpath_int64_ne_signed" (* 'construct' functions are used in BITSTRING constructors. *) val construct_bit : Buffer.t -> bool -> int -> exn -> unit @@ -1079,3 +1089,7 @@ val construct_int64_ee_unsigned : endian -> Buffer.t -> int64 -> int -> exn -> u val construct_string : Buffer.t -> string -> unit val construct_bitstring : Buffer.t -> bitstring -> unit + +(* Alias of functions shadowed by Core. *) +val char_code : char -> int +val int32_of_int : int -> int32 \ No newline at end of file diff --git a/src/utils/bitstring/bitstring_c.c b/src/utils/bitstring/bitstring_c.c index fb3e4064..1fec998a 100644 --- a/src/utils/bitstring/bitstring_c.c +++ b/src/utils/bitstring/bitstring_c.c @@ -1,5 +1,8 @@ -/* Bitstring library. - * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones +/* + * Bitstring library. + * + * Copyright (C) 2008-2016 Red Hat Inc., Richard W.M. Jones + * Copyright (C) 2016 Red Hat Inc, Richard W.M. Jones, Xavier R. Guerin. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -15,42 +18,121 @@ * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - * - * $Id$ */ /* This file contains hand-coded, optimized C implementations of * certain very frequently used functions. */ -#include "../../../config/config.h" +#if defined(__APPLE__) +#include +#elif defined(__FreeBSD__) +#include +#elif defined(__MINGW32__) +#include +#elif defined(_WIN32) && defined(_MSC_VER) && (defined(_M_X64) || defined (_M_IX86)) +#define BIG_ENDIAN 4321 +#define LITTLE_ENDIAN 1234 +#define BYTE_ORDER LITTLE_ENDIAN +#else +#include +#endif #include #include #include -#if defined(HAVE_BYTESWAP_H) #include -#else -#include "byteswap.h" -#endif +#include #include #include +#include +#include + +/* + * Prefix fastpath functions. + */ + +static char prefix_mask_lookup[8] = { + 0x00, 0x80, 0xC0, 0xE0, + 0xF0, 0xF8, 0xFC, 0xFE +}; + +static +int match_partial_left(int len, char source, char prefix) +{ + register char mask = ~prefix_mask_lookup[len]; + return (source & mask) == (prefix & mask); +} + +static +int match_partial_right(int len, char source, char prefix) +{ + register char mask = prefix_mask_lookup[len]; + return (source & mask) == (prefix & mask); +} -/* Fastpath functions. These are used in the common case for reading - * ints where the following conditions are known to be true: +CAMLprim value +ocaml_bitstring_is_prefix_fastpath(value b1, value o1, value b2, value o2, value l2) +{ + CAMLparam5 (b1, o1, b2, o2, l2); + int il2 = Int_val(l2); + /* + * Find the beginning of the bitstrings. + */ + int bo1 = Int_val(o1) >> 3; + int bo2 = Int_val(o2) >> 3; + char * ptr1 = &((char *)String_val(b1))[bo1]; + char * ptr2 = &((char *)String_val(b2))[bo2]; + /* + * Compute the left partial match if the offset mod 8 != 0. + */ + int sh = Int_val(o2) & 0x7; + if (sh != 0) { + if (!match_partial_left(sh, *ptr1, *ptr2)) { + CAMLreturn (Val_false); + } + il2 -= 8 - sh; + ptr1++, ptr2++; + } + /* + * Check the part of the prefix that fits in bytes using memcmp. + */ + int bl2 = il2 >> 3; + if (memcmp(ptr1, ptr2, bl2) != 0) { + CAMLreturn (Val_false); + } + /* + * Check the remainder of the prefix if there is any. + */ + int rem = il2 & 0x7; + if (rem) { + int res = match_partial_right(rem, ptr1[bl2], ptr2[bl2]); + CAMLreturn (Val_bool(res)); + } + /* + * The prefix exists. + */ + CAMLreturn (Val_true); +} + +/* + * Extract fastpath functions. + * + * These are used in the common case for reading ints where the following + * conditions are known to be true: * (a) the int size is a whole number of bytes (eg. 16, 24, 32, etc bits) * (b) the access in the match is byte-aligned * (c) the access in the underlying bitstring is byte-aligned * - * These functions are all "noalloc" meaning they must not perform - * any OCaml allocations. For this reason, when the function returns - * an int32 or int64, the OCaml code passes in the pre-allocated pointer - * to the return value. + * These functions used to all be "noalloc" meaning they must not perform any + * OCaml allocations. However starting with OCaml 4.02, a compiler optimization + * means that unforunately we now have to use ordinary alloc functions in some + * cases. * - * The final offset in the string is calculated by the OCaml (caller) - * code. All we need to do is to read the string+offset and byteswap, - * sign-extend as necessary. + * The final offset in the string is calculated by the OCaml (caller) code. All + * we need to do is to read the string+offset and byteswap, sign-extend as + * necessary. * * There is one function for every combination of: * (i) int size: 16, 32, 64 bits @@ -61,7 +143,7 @@ * requires some extra work because sign-extension won't "just happen". */ -#ifdef ARCH_BIG_ENDIAN +#if BYTE_ORDER == BIG_ENDIAN #define swap_be(size,v) #define swap_le(size,v) v = bswap_##size (v) #define swap_ne(size,v) @@ -71,71 +153,53 @@ #define swap_ne(size,v) #endif -#define fastpath1(size,endian,signed,type) \ - CAMLprim value \ - ocaml_bitstring_extract_fastpath_int##size##_##endian##_##signed \ - (value strv, value offv) \ - { \ - type *ptr = (type *) ((void *) String_val (strv) + Int_val (offv)); \ - type r; \ - r = *ptr; \ - swap_##endian(size,r); \ - return Val_int (r); \ - } +#define extract_fastpath_zero_copy(size, endian, sign, type) \ + CAMLprim value \ + ocaml_bitstring_extract_fastpath_int##size##_##endian##_##sign \ + (value strv, value offv) \ +{ \ + CAMLparam2 (strv, offv); \ + type *ptr = (type *)((char *)String_val(strv) + Int_val(offv)); \ + type r; \ + memcpy(&r, ptr, sizeof(r)); \ + swap_##endian(size,r); \ + CAMLreturn (Val_int(r)); \ +} -fastpath1(16,be,unsigned,uint16_t) -fastpath1(16,le,unsigned,uint16_t) -fastpath1(16,ne,unsigned,uint16_t) -fastpath1(16,be,signed,int16_t) -fastpath1(16,le,signed,int16_t) -fastpath1(16,ne,signed,int16_t) - -#define fastpath2(size,endian,signed,type,rval) \ - CAMLprim value \ - ocaml_bitstring_extract_fastpath_int##size##_##endian##_##signed \ - (value strv, value offv, value rv) \ - { \ - type *ptr = (type *) ((void *) String_val (strv) + Int_val (offv)); \ - type r; \ - r = *ptr; \ - swap_##endian(size,r); \ - rval(rv) = r; \ - return rv; \ - } +#define extract_fastpath_with_copy(size, endian, sign, type) \ + CAMLprim value \ + ocaml_bitstring_extract_fastpath_int##size##_##endian##_##sign \ + (value strv, value offv) \ +{ \ + CAMLparam2 (strv, offv); \ + CAMLlocal1 (rv); \ + type *ptr = (type *)((char *)String_val(strv) + Int_val(offv)); \ + type r; \ + memcpy(&r, ptr, sizeof(r)); \ + swap_##endian(size,r); \ + rv = caml_copy_int##size(r); \ + CAMLreturn(rv); \ +} -fastpath2(32,be,unsigned,uint32_t,Int32_val) -fastpath2(32,le,unsigned,uint32_t,Int32_val) -fastpath2(32,ne,unsigned,uint32_t,Int32_val) -fastpath2(32,be,signed,int32_t,Int32_val) -fastpath2(32,le,signed,int32_t,Int32_val) -fastpath2(32,ne,signed,int32_t,Int32_val) +extract_fastpath_zero_copy(16, be, unsigned, uint16_t) +extract_fastpath_zero_copy(16, le, unsigned, uint16_t) +extract_fastpath_zero_copy(16, ne, unsigned, uint16_t) +extract_fastpath_zero_copy(16, be, signed , int16_t ) +extract_fastpath_zero_copy(16, le, signed , int16_t ) +extract_fastpath_zero_copy(16, ne, signed , int16_t ) -/* Special care needs to be taken on ARCH_ALIGN_INT64 platforms - (hppa and sparc in Debian). */ +extract_fastpath_with_copy(32, be, unsigned, uint32_t) +extract_fastpath_with_copy(32, le, unsigned, uint32_t) +extract_fastpath_with_copy(32, ne, unsigned, uint32_t) +extract_fastpath_with_copy(32, be, signed , int32_t ) +extract_fastpath_with_copy(32, le, signed , int32_t ) +extract_fastpath_with_copy(32, ne, signed , int32_t ) -#ifdef ARCH_ALIGN_INT64 -#include -#include -#define fastpath3(size,endian,signed,type,rval) \ - CAMLprim value \ - ocaml_bitstring_extract_fastpath_int##size##_##endian##_##signed \ - (value strv, value offv, value rv) \ - { \ - CAMLparam3(strv, offv, rv); \ - type *ptr = (type *) ((void *) String_val (strv) + Int_val (offv)); \ - type r; \ - r = *ptr; \ - swap_##endian(size,r); \ - CAMLreturn(caml_copy_int64(r)); \ - } - -#else -#define fastpath3 fastpath2 -#endif +extract_fastpath_with_copy(64, be, unsigned, uint64_t) +extract_fastpath_with_copy(64, le, unsigned, uint64_t) +extract_fastpath_with_copy(64, ne, unsigned, uint64_t) +extract_fastpath_with_copy(64, be, signed , int64_t ) +extract_fastpath_with_copy(64, le, signed , int64_t ) +extract_fastpath_with_copy(64, ne, signed , int64_t ) -fastpath3(64,be,unsigned,uint64_t,Int64_val) -fastpath3(64,le,unsigned,uint64_t,Int64_val) -fastpath3(64,ne,unsigned,uint64_t,Int64_val) -fastpath3(64,be,signed,int64_t,Int64_val) -fastpath3(64,le,signed,int64_t,Int64_val) -fastpath3(64,ne,signed,int64_t,Int64_val) +// vim: ts=2:sts=2:sw=2:et \ No newline at end of file diff --git a/src/utils/bitstring/bitstring_persistent.mlc4 b/src/utils/bitstring/bitstring_persistent.mlc4 index ff97a653..03a2bae3 100644 --- a/src/utils/bitstring/bitstring_persistent.mlc4 +++ b/src/utils/bitstring/bitstring_persistent.mlc4 @@ -175,7 +175,7 @@ let named_to_channel chan n = Marshal.to_channel chan n [] let named_to_string n = Marshal.to_string n [] -let named_to_buffer str ofs len n = Marshal.to_buffer str ofs len n [] +let named_to_buffer str ofs len n = Marshal.to_buffer (Bytes.of_string str) ofs len n [] let named_from_channel = Marshal.from_channel diff --git a/src/utils/bitstring/pa_bitstring.mlt b/src/utils/bitstring/pa_bitstring.mlt index 9d84f388..f5456bad 100644 --- a/src/utils/bitstring/pa_bitstring.mlt +++ b/src/utils/bitstring/pa_bitstring.mlt @@ -55,16 +55,16 @@ let rec expr_is_constant = function (match expr_is_constant a, expr_is_constant b with | Some a, Some b -> (* Integer binary operations. *) let ops = ["+", (+); "-", (-); "*", ( * ); "/", (/); - (* NB: explicit fun .. -> is necessary here to work - * around a camlp4 bug in OCaml 3.10.0. - *) + (* NB: explicit fun .. -> is necessary here to work + * around a camlp4 bug in OCaml 3.10.0. + *) "land", (fun a b -> a land b); - "lor", (fun a b -> a lor b); - "lxor", (fun a b -> a lxor b); + "lor", (fun a b -> a lor b); + "lxor", (fun a b -> a lxor b); "lsl", (fun a b -> a lsl b); - "lsr", (fun a b -> a lsr b); - "asr", (fun a b -> a asr b); - "mod", (fun a b -> a mod b)] in + "lsr", (fun a b -> a lsr b); + "asr", (fun a b -> a asr b); + "mod", (fun a b -> a mod b)] in (try Some ((List.assoc op ops) a b) with Not_found -> None) | _ -> None) | _ -> None @@ -98,67 +98,67 @@ let parse_field _loc field qs = | Some qs -> let check already_set msg = if already_set then fail msg in let apply_qualifier (whatset, field) = - function + function | "endian", Some expr -> check whatset.endian_set "an endian flag has been set already"; let field = P.set_endian_expr field expr in - { whatset with endian_set = true }, field + { whatset with endian_set = true }, field | "endian", None -> - fail "qualifier 'endian' should be followed by an expression" + fail "qualifier 'endian' should be followed by an expression" | "offset", Some expr -> check whatset.offset_set "an offset has been set already"; let field = P.set_offset field expr in - { whatset with offset_set = true }, field + { whatset with offset_set = true }, field | "offset", None -> - fail "qualifier 'offset' should be followed by an expression" - | "check", Some expr -> - check whatset.check_set "a check-qualifier has been set already"; - let field = P.set_check field expr in - { whatset with check_set = true }, field - | "check", None -> - fail "qualifier 'check' should be followed by an expression" - | "bind", Some expr -> - check whatset.bind_set "a bind expression has been set already"; - let field = P.set_bind field expr in - { whatset with bind_set = true }, field - | "bind", None -> - fail "qualifier 'bind' should be followed by an expression" - | "save_offset_to", Some expr (* XXX should be a pattern *) -> - check whatset.save_offset_to_set - "a save_offset_to-qualifier has been set already"; - let id = - match expr with - | <:expr< $lid:id$ >> -> id - | _ -> - failwith "pa_bitstring: internal error: save_offset_to only supports simple identifiers at the moment. In future we should support full patterns." in - let field = P.set_save_offset_to_lident field id in - { whatset with save_offset_to_set = true }, field - | "save_offset_to", None -> - fail "qualifier 'save_offset_to' should be followed by a binding expression" + fail "qualifier 'offset' should be followed by an expression" + | "check", Some expr -> + check whatset.check_set "a check-qualifier has been set already"; + let field = P.set_check field expr in + { whatset with check_set = true }, field + | "check", None -> + fail "qualifier 'check' should be followed by an expression" + | "bind", Some expr -> + check whatset.bind_set "a bind expression has been set already"; + let field = P.set_bind field expr in + { whatset with bind_set = true }, field + | "bind", None -> + fail "qualifier 'bind' should be followed by an expression" + | "save_offset_to", Some expr (* XXX should be a pattern *) -> + check whatset.save_offset_to_set + "a save_offset_to-qualifier has been set already"; + let id = + match expr with + | <:expr< $lid:id$ >> -> id + | _ -> + failwith "pa_bitstring: internal error: save_offset_to only supports simple identifiers at the moment. In future we should support full patterns." in + let field = P.set_save_offset_to_lident field id in + { whatset with save_offset_to_set = true }, field + | "save_offset_to", None -> + fail "qualifier 'save_offset_to' should be followed by a binding expression" | s, Some _ -> - fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression") + fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression") | qual, None -> let endian_quals = ["bigendian", BigEndian; "littleendian", LittleEndian; "nativeendian", NativeEndian] in let sign_quals = ["signed", true; "unsigned", false] in let type_quals = ["int", P.set_type_int; - "string", P.set_type_string; - "bitstring", P.set_type_bitstring] in + "string", P.set_type_string; + "bitstring", P.set_type_bitstring] in if List.mem_assoc qual endian_quals then ( - check whatset.endian_set "an endian flag has been set already"; - let field = P.set_endian field (List.assoc qual endian_quals) in - { whatset with endian_set = true }, field + check whatset.endian_set "an endian flag has been set already"; + let field = P.set_endian field (List.assoc qual endian_quals) in + { whatset with endian_set = true }, field ) else if List.mem_assoc qual sign_quals then ( - check whatset.signed_set "a signed flag has been set already"; - let field = P.set_signed field (List.assoc qual sign_quals) in - { whatset with signed_set = true }, field + check whatset.signed_set "a signed flag has been set already"; + let field = P.set_signed field (List.assoc qual sign_quals) in + { whatset with signed_set = true }, field ) else if List.mem_assoc qual type_quals then ( - check whatset.type_set "a type flag has been set already"; - let field = (List.assoc qual type_quals) field in - { whatset with type_set = true }, field + check whatset.type_set "a type flag has been set already"; + let field = (List.assoc qual type_quals) field in + { whatset with type_set = true }, field ) else - fail (qual ^ ": unknown qualifier, or qualifier should be followed by an expression") in + fail (qual ^ ": unknown qualifier, or qualifier should be followed by an expression") in List.fold_left apply_qualifier (noneset, field) qs in (* If type is set to string or bitstring then endianness and @@ -168,7 +168,7 @@ let parse_field _loc field qs = let t = P.get_type field in if (t = P.Bitstring || t = P.String) && (whatset.endian_set || whatset.signed_set) then - fail "string types and endian or signed qualifiers cannot be mixed" in + fail "string types and endian or signed qualifiers cannot be mixed" in (* Default endianness, signedness, type if not set already. *) let field = @@ -192,19 +192,19 @@ let build_bitstring_call _loc functype length endian signed = | (ConstructFunc, Some 1, _, _) -> <:expr< Bitstring.construct_bit >> | (functype, Some (2|3|4|5|6|7|8), _, signed) -> let funcname = match functype with - | ExtractFunc -> "extract" - | ConstructFunc -> "construct" in + | ExtractFunc -> "extract" + | ConstructFunc -> "construct" in let sign = if signed then "signed" else "unsigned" in let call = sprintf "%s_char_%s" funcname sign in <:expr< Bitstring.$lid:call$ >> | (functype, len, endian, signed) -> let funcname = match functype with - | ExtractFunc -> "extract" - | ConstructFunc -> "construct" in + | ExtractFunc -> "extract" + | ConstructFunc -> "construct" in let t = match len with - | Some i when i <= 31 -> "int" - | Some 32 -> "int32" - | _ -> "int64" in + | Some i when i <= 31 -> "int" + | Some 32 -> "int32" + | _ -> "int64" in let sign = if signed then "signed" else "unsigned" in match endian with | P.ConstantEndian constant -> @@ -228,9 +228,9 @@ let output_constructor _loc fields = <:expr< Bitstring.Construct_failure ($`str:msg$, - $`str:Loc.file_name _loc$, - $`int:Loc.start_line _loc$, - $`int:Loc.start_off _loc - Loc.start_bol _loc$) + $`str:Loc.file_name _loc$, + $`int:Loc.start_line _loc$, + $`int:Loc.start_off _loc - Loc.start_bol _loc$) >> in let raise_construct_failure _loc msg = @@ -271,13 +271,13 @@ let output_constructor _loc fields = * a rethink in how we construct bitstrings. *) if P.get_offset field <> None then - fail "offset expressions are not supported in BITSTRING constructors"; + fail "offset expressions are not supported in BITSTRING constructors"; if P.get_check field <> None then - fail "check expressions are not supported in BITSTRING constructors"; + fail "check expressions are not supported in BITSTRING constructors"; if P.get_bind field <> None then - fail "bind expressions are not supported in BITSTRING constructors"; + fail "bind expressions are not supported in BITSTRING constructors"; if P.get_save_offset_to field <> None then - fail "save_offset_to is not supported in BITSTRING constructors"; + fail "save_offset_to is not supported in BITSTRING constructors"; (* Is flen an integer constant? If so, what is it? This * is very simple-minded and only detects simple constants. @@ -287,130 +287,130 @@ let output_constructor _loc fields = let int_construct_const (i, endian, signed) = build_bitstring_call _loc ConstructFunc (Some i) endian signed in let int_construct (endian, signed) = - build_bitstring_call _loc ConstructFunc None endian signed in + build_bitstring_call _loc ConstructFunc None endian signed in let expr = - match t, flen_is_const with - (* Common case: int field, constant flen. - * - * Range checks are done inside the construction function - * because that's a lot simpler w.r.t. types. It might - * be better to move them here. XXX - *) - | P.Int, Some i when i > 0 && i <= 64 -> - let construct_fn = int_construct_const (i,endian,signed) in - exn_used := true; - - <:expr< - $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$ - >> - - | P.Int, Some _ -> - fail "length of int field must be [1..64]" - - (* Int field, non-constant length. We need to perform a runtime - * test to ensure the length is [1..64]. - * - * Range checks are done inside the construction function - * because that's a lot simpler w.r.t. types. It might - * be better to move them here. XXX - *) - | P.Int, None -> - let construct_fn = int_construct (endian,signed) in - exn_used := true; - - <:expr< - if $flen$ >= 1 && $flen$ <= 64 then - $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$ - else - $raise_construct_failure _loc "length of int field must be [1..64]"$ - >> + match t, flen_is_const with + (* Common case: int field, constant flen. + * + * Range checks are done inside the construction function + * because that's a lot simpler w.r.t. types. It might + * be better to move them here. XXX + *) + | P.Int, Some i when i > 0 && i <= 64 -> + let construct_fn = int_construct_const (i,endian,signed) in + exn_used := true; + + <:expr< + $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$ + >> + + | P.Int, Some _ -> + fail "length of int field must be [1..64]" + + (* Int field, non-constant length. We need to perform a runtime + * test to ensure the length is [1..64]. + * + * Range checks are done inside the construction function + * because that's a lot simpler w.r.t. types. It might + * be better to move them here. XXX + *) + | P.Int, None -> + let construct_fn = int_construct (endian,signed) in + exn_used := true; + + <:expr< + if $flen$ >= 1 && $flen$ <= 64 then + $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$ + else + $raise_construct_failure _loc "length of int field must be [1..64]"$ + >> (* String, constant length > 0, must be a multiple of 8. *) - | P.String, Some i when i > 0 && i land 7 = 0 -> - let bs = gensym "bs" in - let j = i lsr 3 in - <:expr< - let $lid:bs$ = $fexpr$ in - if String.length $lid:bs$ = $`int:j$ then - Bitstring.construct_string $lid:buffer$ $lid:bs$ - else - $raise_construct_failure _loc "length of string does not match declaration"$ - >> - - (* String, constant length -1, means variable length string - * with no checks. - *) - | P.String, Some (-1) -> - <:expr< Bitstring.construct_string $lid:buffer$ $fexpr$ >> - - (* String, constant length = 0 is probably an error, and so is - * any other value. - *) - | P.String, Some _ -> - fail "length of string must be > 0 and a multiple of 8, or the special value -1" - - (* String, non-constant length. - * We check at runtime that the length is > 0, a multiple of 8, - * and matches the declared length. - *) - | P.String, None -> - let bslen = gensym "bslen" in - let bs = gensym "bs" in - <:expr< - let $lid:bslen$ = $flen$ in - if $lid:bslen$ > 0 then ( - if $lid:bslen$ land 7 = 0 then ( - let $lid:bs$ = $fexpr$ in - if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then - Bitstring.construct_string $lid:buffer$ $lid:bs$ - else - $raise_construct_failure _loc "length of string does not match declaration"$ - ) else - $raise_construct_failure _loc "length of string must be a multiple of 8"$ - ) else - $raise_construct_failure _loc "length of string must be > 0"$ - >> + | P.String, Some i when i > 0 && i land 7 = 0 -> + let bs = gensym "bs" in + let j = i lsr 3 in + <:expr< + let $lid:bs$ = $fexpr$ in + if String.length $lid:bs$ = $`int:j$ then + Bitstring.construct_string $lid:buffer$ $lid:bs$ + else + $raise_construct_failure _loc "length of string does not match declaration"$ + >> + + (* String, constant length -1, means variable length string + * with no checks. + *) + | P.String, Some (-1) -> + <:expr< Bitstring.construct_string $lid:buffer$ $fexpr$ >> + + (* String, constant length = 0 is probably an error, and so is + * any other value. + *) + | P.String, Some _ -> + fail "length of string must be > 0 and a multiple of 8, or the special value -1" + + (* String, non-constant length. + * We check at runtime that the length is > 0, a multiple of 8, + * and matches the declared length. + *) + | P.String, None -> + let bslen = gensym "bslen" in + let bs = gensym "bs" in + <:expr< + let $lid:bslen$ = $flen$ in + if $lid:bslen$ > 0 then ( + if $lid:bslen$ land 7 = 0 then ( + let $lid:bs$ = $fexpr$ in + if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then + Bitstring.construct_string $lid:buffer$ $lid:bs$ + else + $raise_construct_failure _loc "length of string does not match declaration"$ + ) else + $raise_construct_failure _loc "length of string must be a multiple of 8"$ + ) else + $raise_construct_failure _loc "length of string must be > 0"$ + >> (* Bitstring, constant length >= 0. *) - | P.Bitstring, Some i when i >= 0 -> - let bs = gensym "bs" in - <:expr< - let $lid:bs$ = $fexpr$ in - if Bitstring.bitstring_length $lid:bs$ = $`int:i$ then - Bitstring.construct_bitstring $lid:buffer$ $lid:bs$ - else - $raise_construct_failure _loc "length of bitstring does not match declaration"$ - >> - - (* Bitstring, constant length -1, means variable length bitstring - * with no checks. - *) - | P.Bitstring, Some (-1) -> - <:expr< Bitstring.construct_bitstring $lid:buffer$ $fexpr$ >> - - (* Bitstring, constant length < -1 is an error. *) - | P.Bitstring, Some _ -> - fail "length of bitstring must be >= 0 or the special value -1" - - (* Bitstring, non-constant length. - * We check at runtime that the length is >= 0 and matches - * the declared length. - *) - | P.Bitstring, None -> - let bslen = gensym "bslen" in - let bs = gensym "bs" in - <:expr< - let $lid:bslen$ = $flen$ in - if $lid:bslen$ >= 0 then ( - let $lid:bs$ = $fexpr$ in - if Bitstring.bitstring_length $lid:bs$ = $lid:bslen$ then - Bitstring.construct_bitstring $lid:buffer$ $lid:bs$ - else - $raise_construct_failure _loc "length of bitstring does not match declaration"$ - ) else - $raise_construct_failure _loc "length of bitstring must be > 0"$ - >> in + | P.Bitstring, Some i when i >= 0 -> + let bs = gensym "bs" in + <:expr< + let $lid:bs$ = $fexpr$ in + if Bitstring.bitstring_length $lid:bs$ = $`int:i$ then + Bitstring.construct_bitstring $lid:buffer$ $lid:bs$ + else + $raise_construct_failure _loc "length of bitstring does not match declaration"$ + >> + + (* Bitstring, constant length -1, means variable length bitstring + * with no checks. + *) + | P.Bitstring, Some (-1) -> + <:expr< Bitstring.construct_bitstring $lid:buffer$ $fexpr$ >> + + (* Bitstring, constant length < -1 is an error. *) + | P.Bitstring, Some _ -> + fail "length of bitstring must be >= 0 or the special value -1" + + (* Bitstring, non-constant length. + * We check at runtime that the length is >= 0 and matches + * the declared length. + *) + | P.Bitstring, None -> + let bslen = gensym "bslen" in + let bs = gensym "bs" in + <:expr< + let $lid:bslen$ = $flen$ in + if $lid:bslen$ >= 0 then ( + let $lid:bs$ = $fexpr$ in + if Bitstring.bitstring_length $lid:bs$ = $lid:bslen$ then + Bitstring.construct_bitstring $lid:buffer$ $lid:bs$ + else + $raise_construct_failure _loc "length of bitstring does not match declaration"$ + ) else + $raise_construct_failure _loc "length of bitstring must be > 0"$ + >> in expr ) fields in @@ -486,494 +486,486 @@ let output_bitmatch _loc bs cases = let rec output_field_extraction inner = function | [] -> inner | field :: fields -> - let fpatt = P.get_patt field in - let flen = P.get_length field in - let endian = P.get_endian field in - let signed = P.get_signed field in - let t = P.get_type field in - let _loc = P.get_location field in - - let fail = locfail _loc in - - (* Is flen (field len) an integer constant? If so, what is it? - * This will be [Some i] if it's a constant or [None] if it's - * non-constant or we couldn't determine. - *) - let flen_is_const = expr_is_constant flen in - - (* Surround the inner expression by check and bind clauses, so: - * if $check$ then - * let $bind...$ in - * $inner$ - * where the check and bind are switched on only if they are - * present in the field. (In the common case when neither - * clause is present, expr = inner). Note the order of the - * check & bind is visible to the user and defined in the - * documentation, so it must not change. - *) - let expr = inner in - let expr = - match P.get_bind field with - | None -> expr - | Some bind_expr -> - <:expr< let $fpatt$ = $bind_expr$ in $expr$ >> in - let expr = - match P.get_check field with - | None -> expr - | Some check_expr -> - <:expr< if $check_expr$ then $expr$ >> in - - (* Compute the offset of this field within the match, if it - * can be known at compile time. - * - * Actually, we'll compute two things: the 'natural_field_offset' - * is the offset assuming this field had no offset() qualifier - * (in other words, its position, immediately following the - * preceding field). 'field_offset' is the real field offset - * taking into account any offset() qualifier. - * - * This will be [Some i] if our current offset is known - * at compile time, or [None] if we can't determine it. - *) - let natural_field_offset, field_offset = - let has_constant_offset field = - match P.get_offset field with - | None -> false - | Some expr -> - match expr_is_constant expr with - | None -> false - | Some i -> true - in - let get_constant_offset field = - match P.get_offset field with - | None -> assert false - | Some expr -> - match expr_is_constant expr with - | None -> assert false - | Some i -> i - in - - let has_constant_len field = - match expr_is_constant (P.get_length field) with - | None -> false - | Some i when i > 0 -> true - | Some _ -> false - in - let get_constant_len field = - match expr_is_constant (P.get_length field) with - | None -> assert false - | Some i when i > 0 -> i - | Some _ -> assert false - in - - (* NB: We are looping over the PRECEDING fields in reverse order. *) - let rec loop = function - (* first field has constant offset 0 *) - | [] -> Some 0 - (* preceding field with constant offset & length *) - | f :: _ - when has_constant_offset f && has_constant_len f -> - Some (get_constant_offset f + get_constant_len f) - (* preceding field with no offset & constant length *) - | f :: fs - when P.get_offset f = None && has_constant_len f -> - (match loop fs with - | None -> None - | Some offset -> Some (offset + get_constant_len f)) - (* else, can't work out the offset *) - | _ -> None - in - - let natural_field_offset = loop fields in - - let field_offset = - match P.get_offset field with - | None -> natural_field_offset - | Some expr -> (* has an offset() clause *) - match expr_is_constant expr with - | None -> None - | i -> i in - - natural_field_offset, field_offset in - - (* Also compute if the field_offset is known to be byte-aligned at - * compile time, which is usually both the common and best possible - * case for generating optimized code. - * - * This is None if not aligned / don't know. - * Or Some byte_offset if we can work it out. - *) - let field_offset_aligned = - match field_offset with - | None -> None (* unknown, assume no *) - | Some off when off land 7 = 0 -> Some (off lsr 3) - | Some _ -> None in (* definitely no *) - - (* Now build the code which matches a single field. *) - let int_extract_const i endian signed = + let fpatt = P.get_patt field in + let flen = P.get_length field in + let endian = P.get_endian field in + let signed = P.get_signed field in + let t = P.get_type field in + let _loc = P.get_location field in + + let fail = locfail _loc in + + (* Is flen (field len) an integer constant? If so, what is it? + * This will be [Some i] if it's a constant or [None] if it's + * non-constant or we couldn't determine. + *) + let flen_is_const = expr_is_constant flen in + + (* Surround the inner expression by check and bind clauses, so: + * if $check$ then + * let $bind...$ in + * $inner$ + * where the check and bind are switched on only if they are + * present in the field. (In the common case when neither + * clause is present, expr = inner). Note the order of the + * check & bind is visible to the user and defined in the + * documentation, so it must not change. + *) + let expr = inner in + let expr = + match P.get_bind field with + | None -> expr + | Some bind_expr -> + <:expr< let $fpatt$ = $bind_expr$ in $expr$ >> in + let expr = + match P.get_check field with + | None -> expr + | Some check_expr -> + <:expr< if $check_expr$ then $expr$ >> in + + (* Compute the offset of this field within the match, if it + * can be known at compile time. + * + * Actually, we'll compute two things: the 'natural_field_offset' + * is the offset assuming this field had no offset() qualifier + * (in other words, its position, immediately following the + * preceding field). 'field_offset' is the real field offset + * taking into account any offset() qualifier. + * + * This will be [Some i] if our current offset is known + * at compile time, or [None] if we can't determine it. + *) + let natural_field_offset, field_offset = + let has_constant_offset field = + match P.get_offset field with + | None -> false + | Some expr -> + match expr_is_constant expr with + | None -> false + | Some i -> true + in + let get_constant_offset field = + match P.get_offset field with + | None -> assert false + | Some expr -> + match expr_is_constant expr with + | None -> assert false + | Some i -> i + in + + let has_constant_len field = + match expr_is_constant (P.get_length field) with + | None -> false + | Some i when i > 0 -> true + | Some _ -> false + in + let get_constant_len field = + match expr_is_constant (P.get_length field) with + | None -> assert false + | Some i when i > 0 -> i + | Some _ -> assert false + in + + (* NB: We are looping over the PRECEDING fields in reverse order. *) + let rec loop = function + (* first field has constant offset 0 *) + | [] -> Some 0 + (* preceding field with constant offset & length *) + | f :: _ + when has_constant_offset f && has_constant_len f -> + Some (get_constant_offset f + get_constant_len f) + (* preceding field with no offset & constant length *) + | f :: fs + when P.get_offset f = None && has_constant_len f -> + (match loop fs with + | None -> None + | Some offset -> Some (offset + get_constant_len f)) + (* else, can't work out the offset *) + | _ -> None + in + + let natural_field_offset = loop fields in + + let field_offset = + match P.get_offset field with + | None -> natural_field_offset + | Some expr -> (* has an offset() clause *) + match expr_is_constant expr with + | None -> None + | i -> i in + + natural_field_offset, field_offset in + + (* Also compute if the field_offset is known to be byte-aligned at + * compile time, which is usually both the common and best possible + * case for generating optimized code. + * + * This is None if not aligned / don't know. + * Or Some byte_offset if we can work it out. + *) + let field_offset_aligned = + match field_offset with + | None -> None (* unknown, assume no *) + | Some off when off land 7 = 0 -> Some (off lsr 3) + | Some _ -> None in (* definitely no *) + + (* Now build the code which matches a single field. *) + let int_extract_const i endian signed = build_bitstring_call _loc ExtractFunc (Some i) endian signed in - let int_extract endian signed = - build_bitstring_call _loc ExtractFunc None endian signed in - - let expr = - match t, flen_is_const, field_offset_aligned, endian, signed with - (* Very common cases: int field, constant 8/16/32/64 bit - * length, aligned to the match at a known offset. We - * still have to check if the bitstring is aligned (can only - * be known at runtime) but we may be able to directly access - * the bytes in the string. - *) - | P.Int, Some 8, Some field_byte_offset, _, _ -> - let extract_fn = int_extract_const 8 endian signed in + let int_extract endian signed = + build_bitstring_call _loc ExtractFunc None endian signed in + + let expr = + match t, flen_is_const, field_offset_aligned, endian, signed with + (* Very common cases: int field, constant 8/16/32/64 bit + * length, aligned to the match at a known offset. We + * still have to check if the bitstring is aligned (can only + * be known at runtime) but we may be able to directly access + * the bytes in the string. + *) + | P.Int, Some 8, Some field_byte_offset, _, signed -> + let extract_fn = int_extract_const 8 endian signed in (* The fast-path code when everything is aligned. *) let fastpath = - <:expr< + <:expr< let o = - ($lid:original_off$ lsr 3) + $`int:field_byte_offset$ in - Char.code (String.unsafe_get $lid:data$ o) + ($lid:original_off$ lsr 3) + $`int:field_byte_offset$ in + Bitstring.char_code (Bytes.unsafe_get $lid:data$ o) >> in <:expr< - if $lid:len$ >= 8 then ( + if $lid:len$ >= 8 then ( let v = - if $lid:off_aligned$ then + if not $`bool:signed$ && $lid:off_aligned$ then $fastpath$ else $extract_fn$ $lid:data$ $lid:off$ $lid:len$ 8 in let $lid:off$ = $lid:off$ + 8 and $lid:len$ = $lid:len$ - 8 in match v with $fpatt$ when true -> $expr$ | _ -> () - ) - >> - - | P.Int, Some ((16|32|64) as i), - Some field_byte_offset, (P.ConstantEndian _ as endian), signed -> - let extract_fn = int_extract_const i endian signed in - - (* The fast-path code when everything is aligned. *) - let fastpath = - let fastpath_call = - let endian = match endian with - | P.ConstantEndian BigEndian -> "be" - | P.ConstantEndian LittleEndian -> "le" - | P.ConstantEndian NativeEndian -> "ne" - | P.EndianExpr _ -> assert false in - let signed = if signed then "signed" else "unsigned" in - let name = - sprintf "extract_fastpath_int%d_%s_%s" i endian signed in - match i with - | 16 -> - <:expr< Bitstring.$lid:name$ $lid:data$ o >> - | 32 -> - <:expr< - (* must allocate a new zero each time *) - let zero = Int32.of_int 0 in - Bitstring.$lid:name$ $lid:data$ o zero - >> - | 64 -> - <:expr< - (* must allocate a new zero each time *) - let zero = Int64.of_int 0 in - Bitstring.$lid:name$ $lid:data$ o zero - >> - | _ -> assert false in - <:expr< - (* Starting offset within the string. *) - let o = - ($lid:original_off$ lsr 3) + $`int:field_byte_offset$ in - $fastpath_call$ - >> in - - let slowpath = - <:expr< - $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ - >> in - - <:expr< - if $lid:len$ >= $`int:i$ then ( - let v = - if $lid:off_aligned$ then $fastpath$ else $slowpath$ in - let $lid:off$ = $lid:off$ + $`int:i$ - and $lid:len$ = $lid:len$ - $`int:i$ in - match v with $fpatt$ when true -> $expr$ | _ -> () - ) - >> - - (* Common case: int field, constant flen *) - | P.Int, Some i, _, _, _ when i > 0 && i <= 64 -> - let extract_fn = int_extract_const i endian signed in - let v = gensym "val" in - <:expr< - if $lid:len$ >= $`int:i$ then ( - let $lid:v$ = - $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in - let $lid:off$ = $lid:off$ + $`int:i$ - and $lid:len$ = $lid:len$ - $`int:i$ in - match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> () - ) - >> - - | P.Int, Some _, _, _, _ -> - fail "length of int field must be [1..64]" - - (* Int field, non-const flen. We have to test the range of - * the field at runtime. If outside the range it's a no-match - * (not an error). - *) - | P.Int, None, _, _, _ -> - let extract_fn = int_extract endian signed in - let v = gensym "val" in - <:expr< - if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then ( - let $lid:v$ = - $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in - let $lid:off$ = $lid:off$ + $flen$ - and $lid:len$ = $lid:len$ - $flen$ in - match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> () - ) - >> + ) + >> + + | P.Int, Some ((16|32|64) as i), + Some field_byte_offset, (P.ConstantEndian _ as endian), signed -> + let extract_fn = int_extract_const i endian signed in + + (* The fast-path code when everything is aligned. *) + let fastpath = + let fastpath_call = + let endian = match endian with + | P.ConstantEndian BigEndian -> "be" + | P.ConstantEndian LittleEndian -> "le" + | P.ConstantEndian NativeEndian -> "ne" + | P.EndianExpr _ -> assert false in + let signed = if signed then "signed" else "unsigned" in + let name = + sprintf "extract_fastpath_int%d_%s_%s" i endian signed in + match i with + | 16 -> + <:expr< Bitstring.$lid:name$ $lid:data$ o >> + | 32 -> + <:expr< Bitstring.$lid:name$ $lid:data$ o >> + | 64 -> + <:expr< Bitstring.$lid:name$ $lid:data$ o >> + | _ -> assert false in + <:expr< + (* Starting offset within the string. *) + let o = + ($lid:original_off$ lsr 3) + $`int:field_byte_offset$ in + $fastpath_call$ + >> in + + let slowpath = + <:expr< + $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ + >> in + + <:expr< + if $lid:len$ >= $`int:i$ then ( + let v = + if $lid:off_aligned$ then $fastpath$ else $slowpath$ in + let $lid:off$ = $lid:off$ + $`int:i$ + and $lid:len$ = $lid:len$ - $`int:i$ in + match v with $fpatt$ when true -> $expr$ | _ -> () + ) + >> + + (* Common case: int field, constant flen *) + | P.Int, Some i, _, _, _ when i > 0 && i <= 64 -> + let extract_fn = int_extract_const i endian signed in + let v = gensym "val" in + <:expr< + if $lid:len$ >= $`int:i$ then ( + let $lid:v$ = + $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in + let $lid:off$ = $lid:off$ + $`int:i$ + and $lid:len$ = $lid:len$ - $`int:i$ in + match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> () + ) + >> + + | P.Int, Some _, _, _, _ -> + fail "length of int field must be [1..64]" + + (* Int field, non-const flen. We have to test the range of + * the field at runtime. If outside the range it's a no-match + * (not an error). + *) + | P.Int, None, _, _, _ -> + let extract_fn = int_extract endian signed in + let v = gensym "val" in + <:expr< + if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then ( + let $lid:v$ = + $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in + let $lid:off$ = $lid:off$ + $flen$ + and $lid:len$ = $lid:len$ - $flen$ in + match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> () + ) + >> (* String, constant flen > 0. - * The field is at a known byte-aligned offset so we may - * be able to optimize the substring extraction. - *) - | P.String, Some i, Some field_byte_offset, _, _ - when i > 0 && i land 7 = 0 -> - let fastpath = - <:expr< - (* Starting offset within the string. *) - let o = - ($lid:original_off$ lsr 3) + $`int:field_byte_offset$ in - String.sub $lid:data$ o $`int:(i lsr 3)$ - >> in - - let slowpath = - <:expr< - Bitstring.string_of_bitstring - ($lid:data$, $lid:off$, $`int:i$) - >> in - - let cond = - <:expr< - if $lid:off_aligned$ then $fastpath$ else $slowpath$ - >> in - - <:expr< - if $lid:len$ >= $`int:i$ then ( - let str = $cond$ in - let $lid:off$ = $lid:off$ + $`int:i$ - and $lid:len$ = $lid:len$ - $`int:i$ in - match str with - | $fpatt$ when true -> $expr$ - | _ -> () - ) - >> + * The field is at a known byte-aligned offset so we may + * be able to optimize the substring extraction. + *) + | P.String, Some i, Some field_byte_offset, _, _ + when i > 0 && i land 7 = 0 -> + let fastpath = + <:expr< + (* Starting offset within the string. *) + let o = + ($lid:original_off$ lsr 3) + $`int:field_byte_offset$ in + Bytes.sub_string $lid:data$ o $`int:(i lsr 3)$ + >> in + + let slowpath = + <:expr< + Bitstring.string_of_bitstring + ($lid:data$, $lid:off$, $`int:i$) + >> in + + let cond = + <:expr< + if $lid:off_aligned$ then $fastpath$ else $slowpath$ + >> in + + <:expr< + if $lid:len$ >= $`int:i$ then ( + let str = $cond$ in + let $lid:off$ = $lid:off$ + $`int:i$ + and $lid:len$ = $lid:len$ - $`int:i$ in + match str with + | $fpatt$ when true -> $expr$ + | _ -> () + ) + >> (* String, constant flen > 0. *) - | P.String, Some i, None, _, _ when i > 0 && i land 7 = 0 -> - <:expr< - if $lid:len$ >= $`int:i$ then ( - let str = - Bitstring.string_of_bitstring - ($lid:data$, $lid:off$, $`int:i$) in - let $lid:off$ = $lid:off$ + $`int:i$ - and $lid:len$ = $lid:len$ - $`int:i$ in - match str with - | $fpatt$ when true -> $expr$ - | _ -> () - ) - >> + | P.String, Some i, None, _, _ when i > 0 && i land 7 = 0 -> + <:expr< + if $lid:len$ >= $`int:i$ then ( + let str = + Bitstring.string_of_bitstring + ($lid:data$, $lid:off$, $`int:i$) in + let $lid:off$ = $lid:off$ + $`int:i$ + and $lid:len$ = $lid:len$ - $`int:i$ in + match str with + | $fpatt$ when true -> $expr$ + | _ -> () + ) + >> (* String, constant flen = -1, means consume all the - * rest of the input. - * XXX It should be possible to optimize this for known byte - * offset, but the optimization is tricky because the end/length - * of the string may not be byte-aligned. - *) - | P.String, Some i, _, _, _ when i = -1 -> - let str = gensym "str" in - - <:expr< - let $lid:str$ = - Bitstring.string_of_bitstring - ($lid:data$, $lid:off$, $lid:len$) in - let $lid:off$ = $lid:off$ + $lid:len$ in - let $lid:len$ = 0 in - match $lid:str$ with - | $fpatt$ when true -> $expr$ - | _ -> () - >> - - | P.String, Some _, _, _, _ -> - fail "length of string must be > 0 and a multiple of 8, or the special value -1" - - (* String field, non-const flen. We check the flen is > 0 - * and a multiple of 8 (-1 is not allowed here), at runtime. - *) - | P.String, None, _, _, _ -> - let bs = gensym "bs" in - <:expr< - if $flen$ >= 0 && $flen$ <= $lid:len$ - && $flen$ land 7 = 0 then ( - let $lid:bs$ = ($lid:data$, $lid:off$, $flen$) in - let $lid:off$ = $lid:off$ + $flen$ - and $lid:len$ = $lid:len$ - $flen$ in - match Bitstring.string_of_bitstring $lid:bs$ with - | $fpatt$ when true -> $expr$ - | _ -> () - ) - >> + * rest of the input. + * XXX It should be possible to optimize this for known byte + * offset, but the optimization is tricky because the end/length + * of the string may not be byte-aligned. + *) + | P.String, Some i, _, _, _ when i = -1 -> + let str = gensym "str" in + + <:expr< + let $lid:str$ = + Bitstring.string_of_bitstring + ($lid:data$, $lid:off$, $lid:len$) in + let $lid:off$ = $lid:off$ + $lid:len$ in + let $lid:len$ = 0 in + match $lid:str$ with + | $fpatt$ when true -> $expr$ + | _ -> () + >> + + | P.String, Some _, _, _, _ -> + fail "length of string must be > 0 and a multiple of 8, or the special value -1" + + (* String field, non-const flen. We check the flen is > 0 + * and a multiple of 8 (-1 is not allowed here), at runtime. + *) + | P.String, None, _, _, _ -> + let bs = gensym "bs" in + <:expr< + if $flen$ >= 0 && $flen$ <= $lid:len$ + && $flen$ land 7 = 0 then ( + let $lid:bs$ = ($lid:data$, $lid:off$, $flen$) in + let $lid:off$ = $lid:off$ + $flen$ + and $lid:len$ = $lid:len$ - $flen$ in + match Bitstring.string_of_bitstring $lid:bs$ with + | $fpatt$ when true -> $expr$ + | _ -> () + ) + >> (* Bitstring, constant flen >= 0. - * At the moment all we can do is assign the bitstring to an - * identifier. - *) - | P.Bitstring, Some i, _, _, _ when i >= 0 -> - let ident = - match fpatt with - | <:patt< $lid:ident$ >> -> ident - | <:patt< _ >> -> "_" - | _ -> - fail "cannot compare a bitstring to a constant" in - <:expr< - if $lid:len$ >= $`int:i$ then ( - let $lid:ident$ = ($lid:data$, $lid:off$, $`int:i$) in - let $lid:off$ = $lid:off$ + $`int:i$ - and $lid:len$ = $lid:len$ - $`int:i$ in - $expr$ - ) - >> + * At the moment all we can do is assign the bitstring to an + * identifier. + *) + | P.Bitstring, Some i, _, _, _ when i >= 0 -> + let ident = + match fpatt with + | <:patt< $lid:ident$ >> -> ident + | <:patt< _ >> -> "_" + | _ -> + fail "cannot compare a bitstring to a constant" in + <:expr< + if $lid:len$ >= $`int:i$ then ( + let $lid:ident$ = ($lid:data$, $lid:off$, $`int:i$) in + let $lid:off$ = $lid:off$ + $`int:i$ + and $lid:len$ = $lid:len$ - $`int:i$ in + $expr$ + ) + >> (* Bitstring, constant flen = -1, means consume all the - * rest of the input. - *) - | P.Bitstring, Some i, _, _, _ when i = -1 -> - let ident = - match fpatt with - | <:patt< $lid:ident$ >> -> ident - | <:patt< _ >> -> "_" - | _ -> - fail "cannot compare a bitstring to a constant" in - <:expr< - let $lid:ident$ = ($lid:data$, $lid:off$, $lid:len$) in - let $lid:off$ = $lid:off$ + $lid:len$ in - let $lid:len$ = 0 in - $expr$ - >> - - | P.Bitstring, Some _, _, _, _ -> - fail "length of bitstring must be >= 0 or the special value -1" - - (* Bitstring field, non-const flen. We check the flen is >= 0 - * (-1 is not allowed here) at runtime. - *) - | P.Bitstring, None, _, _, _ -> - let ident = - match fpatt with - | <:patt< $lid:ident$ >> -> ident - | <:patt< _ >> -> "_" - | _ -> - fail "cannot compare a bitstring to a constant" in - <:expr< - if $flen$ >= 0 && $flen$ <= $lid:len$ then ( - let $lid:ident$ = ($lid:data$, $lid:off$, $flen$) in - let $lid:off$ = $lid:off$ + $flen$ - and $lid:len$ = $lid:len$ - $flen$ in - $expr$ - ) - >> - in - - (* Computed offset: only offsets forward are supported. - * - * We try hard to optimize this based on what we know. Are - * we at a predictable offset now? (Look at the outer 'fields' - * list and see if they all have constant field length starting - * at some constant offset). Is this offset constant? - * - * Based on this we can do a lot of the computation at - * compile time, or defer it to runtime only if necessary. - * - * In all cases, the off and len fields get updated. - *) - let expr = - match P.get_offset field with - | None -> expr (* common case: there was no offset expression *) - | Some offset_expr -> - (* This will be [Some i] if offset is a constant expression - * or [None] if it's a non-constant. - *) - let requested_offset = expr_is_constant offset_expr in + * rest of the input. + *) + | P.Bitstring, Some i, _, _, _ when i = -1 -> + let ident = + match fpatt with + | <:patt< $lid:ident$ >> -> ident + | <:patt< _ >> -> "_" + | _ -> + fail "cannot compare a bitstring to a constant" in + <:expr< + let $lid:ident$ = ($lid:data$, $lid:off$, $lid:len$) in + let $lid:off$ = $lid:off$ + $lid:len$ in + let $lid:len$ = 0 in + $expr$ + >> + + | P.Bitstring, Some _, _, _, _ -> + fail "length of bitstring must be >= 0 or the special value -1" + + (* Bitstring field, non-const flen. We check the flen is >= 0 + * (-1 is not allowed here) at runtime. + *) + | P.Bitstring, None, _, _, _ -> + let ident = + match fpatt with + | <:patt< $lid:ident$ >> -> ident + | <:patt< _ >> -> "_" + | _ -> + fail "cannot compare a bitstring to a constant" in + <:expr< + if $flen$ >= 0 && $flen$ <= $lid:len$ then ( + let $lid:ident$ = ($lid:data$, $lid:off$, $flen$) in + let $lid:off$ = $lid:off$ + $flen$ + and $lid:len$ = $lid:len$ - $flen$ in + $expr$ + ) + >> + in + + (* Computed offset: only offsets forward are supported. + * + * We try hard to optimize this based on what we know. Are + * we at a predictable offset now? (Look at the outer 'fields' + * list and see if they all have constant field length starting + * at some constant offset). Is this offset constant? + * + * Based on this we can do a lot of the computation at + * compile time, or defer it to runtime only if necessary. + * + * In all cases, the off and len fields get updated. + *) + let expr = + match P.get_offset field with + | None -> expr (* common case: there was no offset expression *) + | Some offset_expr -> + (* This will be [Some i] if offset is a constant expression + * or [None] if it's a non-constant. + *) + let requested_offset = expr_is_constant offset_expr in (* Look at the field offset (if known) and requested offset - * cases and determine what code to generate. - *) - match natural_field_offset, requested_offset with - (* This is the good case: both the field offset and - * the requested offset are constant, so we can remove - * almost all the runtime checks. - *) - | Some natural_field_offset, Some requested_offset -> - let move = requested_offset - natural_field_offset in - if move < 0 then - fail (sprintf "requested offset is less than the field offset (%d < %d)" requested_offset natural_field_offset); - (* Add some code to move the offset and length by a - * constant amount, and a runtime test that len >= 0 - * (XXX possibly the runtime test is unnecessary?) - *) - <:expr< - let $lid:off$ = $lid:off$ + $`int:move$ in - let $lid:len$ = $lid:len$ - $`int:move$ in - if $lid:len$ >= 0 then $expr$ - >> - (* In any other case, we need to use runtime checks. - * - * XXX It's not clear if a backwards move detected at runtime - * is merely a match failure, or a runtime error. At the - * moment it's just a match failure since bitmatch generally - * doesn't raise runtime errors. - *) - | _ -> - let move = gensym "move" in - <:expr< - let $lid:move$ = - $offset_expr$ - ($lid:off$ - $lid:original_off$) in - if $lid:move$ >= 0 then ( - let $lid:off$ = $lid:off$ + $lid:move$ in - let $lid:len$ = $lid:len$ - $lid:move$ in - if $lid:len$ >= 0 then $expr$ - ) - >> in (* end of computed offset code *) - - (* save_offset_to(patt) saves the current offset into a variable. *) - let expr = - match P.get_save_offset_to field with - | None -> expr (* no save_offset_to *) - | Some patt -> - <:expr< - let $patt$ = $lid:off$ - $lid:original_off$ in - $expr$ - >> in - - (* Emit extra debugging code. *) - let expr = - if not debug then expr else ( - let field = P.string_of_pattern_field field in - - <:expr< - if !Bitstring.debug then ( - Printf.eprintf "PA_BITSTRING: TEST:\n"; - Printf.eprintf " %s\n" $str:field$; - Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$; - (*Bitstring.hexdump_bitstring stderr - ($lid:data$,$lid:off$,$lid:len$);*) - ); - $expr$ - >> - ) in - - output_field_extraction expr fields + * cases and determine what code to generate. + *) + match natural_field_offset, requested_offset with + (* This is the good case: both the field offset and + * the requested offset are constant, so we can remove + * almost all the runtime checks. + *) + | Some natural_field_offset, Some requested_offset -> + let move = requested_offset - natural_field_offset in + if move < 0 then + fail (sprintf "requested offset is less than the field offset (%d < %d)" requested_offset natural_field_offset); + (* Add some code to move the offset and length by a + * constant amount, and a runtime test that len >= 0 + * (XXX possibly the runtime test is unnecessary?) + *) + <:expr< + let $lid:off$ = $lid:off$ + $`int:move$ in + let $lid:len$ = $lid:len$ - $`int:move$ in + if $lid:len$ >= 0 then $expr$ + >> + (* In any other case, we need to use runtime checks. + * + * XXX It's not clear if a backwards move detected at runtime + * is merely a match failure, or a runtime error. At the + * moment it's just a match failure since bitmatch generally + * doesn't raise runtime errors. + *) + | _ -> + let move = gensym "move" in + <:expr< + let $lid:move$ = + $offset_expr$ - ($lid:off$ - $lid:original_off$) in + if $lid:move$ >= 0 then ( + let $lid:off$ = $lid:off$ + $lid:move$ in + let $lid:len$ = $lid:len$ - $lid:move$ in + if $lid:len$ >= 0 then $expr$ + ) + >> in (* end of computed offset code *) + + (* save_offset_to(patt) saves the current offset into a variable. *) + let expr = + match P.get_save_offset_to field with + | None -> expr (* no save_offset_to *) + | Some patt -> + <:expr< + let $patt$ = $lid:off$ - $lid:original_off$ in + $expr$ + >> in + + (* Emit extra debugging code. *) + let expr = + if not debug then expr else ( + let field = P.string_of_pattern_field field in + + <:expr< + if !Bitstring.debug then ( + Printf.eprintf "PA_BITSTRING: TEST:\n"; + Printf.eprintf " %s\n" $str:field$; + Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$; + (*Bitstring.hexdump_bitstring stderr + ($lid:data$,$lid:off$,$lid:len$);*) + ); + $expr$ + >> + ) in + + output_field_extraction expr fields in (* Convert each case in the match. *) @@ -981,18 +973,19 @@ let output_bitmatch _loc bs cases = fun (fields, bind, whenclause, code) -> let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in let inner = - match whenclause with - | Some whenclause -> - <:expr< if $whenclause$ then $inner$ >> - | None -> inner in + match whenclause with + | Some whenclause -> + <:expr< if $whenclause$ then $inner$ >> + | None -> inner in let inner = - match bind with - | Some name -> - <:expr< - let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in - $inner$ - >> - | None -> inner in + match bind with + | Some name -> + <:expr< + let $lid:name$ = ($lid:data$, + $lid:original_off$, $lid:original_len$) in + $inner$ + >> + | None -> inner in output_field_extraction inner (List.rev fields) ) cases in @@ -1038,7 +1031,7 @@ let output_bitmatch _loc bs cases = match ! $lid:result$ with | Some x -> x | None -> raise (Match_failure ($str:loc_fname$, - $int:loc_line$, $int:loc_char$)) + $int:loc_line$, $int:loc_char$)) >> (* Add a named pattern. *) @@ -1059,9 +1052,9 @@ let load_patterns_from_file _loc filename = (* Try current directory. *) try open_in filename with _ -> - (* Try OCaml library directory. *) - try open_in (Filename.concat Bitstring_config.ocamllibdir filename) - with exn -> Loc.raise _loc exn + (* Try OCaml library directory. *) + try open_in (Filename.concat Bitstring_config.ocamllibdir filename) + with exn -> Loc.raise _loc exn ) else ( try open_in filename with exn -> Loc.raise _loc exn @@ -1080,9 +1073,9 @@ let load_patterns_from_file _loc filename = List.iter ( function | name, P.Pattern patt -> - if patt = [] then - locfail _loc (sprintf "pattern %s: no fields" name); - add_named_pattern _loc name patt + if patt = [] then + locfail _loc (sprintf "pattern %s: no fields" name); + add_named_pattern _loc name patt | _, P.Constructor _ -> () (* just ignore these for now *) ) names *) @@ -1096,9 +1089,9 @@ EXTEND Gram *) qualifiers: [ [ LIST0 - [ q = LIDENT; - e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ] - SEP "," ] + [ q = LIDENT; + e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ] + SEP "," ] ]; (* Field used in the bitmatch operator (a pattern). This can actually @@ -1108,12 +1101,12 @@ EXTEND Gram patt_field: [ [ fpatt = patt; ":"; len = expr LEVEL "top"; qs = OPT [ ":"; qs = qualifiers -> qs ] -> - let field = P.create_pattern_field _loc in - let field = P.set_patt field fpatt in - let field = P.set_length field len in - [parse_field _loc field qs] (* Normal, single field. *) + let field = P.create_pattern_field _loc in + let field = P.set_patt field fpatt in + let field = P.set_length field len in + [parse_field _loc field qs] (* Normal, single field. *) | ":"; name = LIDENT -> - expand_named_pattern _loc name (* Named -> list of fields. *) + expand_named_pattern _loc name (* Named -> list of fields. *) ] ]; @@ -1122,7 +1115,11 @@ EXTEND Gram [ "{"; fields = LIST0 patt_field SEP ";"; "}" -> - List.concat fields + List.concat fields + | "{"; + "_"; + "}" -> + [] ] ]; @@ -1131,7 +1128,7 @@ EXTEND Gram bind = OPT [ "as"; name = LIDENT -> name ]; whenclause = OPT [ "when"; e = expr -> e ]; "->"; code = expr -> - (fields, bind, whenclause, code) + (fields, bind, whenclause, code) ] ]; @@ -1139,10 +1136,10 @@ EXTEND Gram constr_field: [ [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top"; qs = OPT [ ":"; qs = qualifiers -> qs ] -> - let field = P.create_constructor_field _loc in - let field = P.set_expr field fexpr in - let field = P.set_length field len in - parse_field _loc field qs + let field = P.create_constructor_field _loc in + let field = P.set_expr field fexpr in + let field = P.set_length field len in + parse_field _loc field qs ] ]; @@ -1150,7 +1147,7 @@ EXTEND Gram [ "{"; fields = LIST0 constr_field SEP ";"; "}" -> - fields + fields ] ]; @@ -1159,13 +1156,13 @@ EXTEND Gram [ "bitmatch"; bs = expr; "with"; OPT "|"; cases = LIST1 patt_case SEP "|" -> - output_bitmatch _loc bs cases + output_bitmatch _loc bs cases ] (* Constructor. *) | [ "BITSTRING"; fields = constr_fields -> - output_constructor _loc fields + output_constructor _loc fields ] ]; @@ -1179,13 +1176,13 @@ EXTEND Gram str_item: LEVEL "top" [ [ "let"; "bitmatch"; name = LIDENT; "="; fields = patt_fields -> - add_named_pattern _loc name fields; + add_named_pattern _loc name fields; (* The statement disappears, but we still need a str_item so ... *) <:str_item< >> (* | "open"; "bitmatch"; filename = STRING -> - load_patterns_from_file _loc filename; - <:str_item< >> + load_patterns_from_file _loc filename; + <:str_item< >> *) ] ]; diff --git a/src/utils/net/http_server.ml b/src/utils/net/http_server.ml index cf8cac67..3a33102c 100644 --- a/src/utils/net/http_server.ml +++ b/src/utils/net/http_server.ml @@ -793,17 +793,17 @@ let request_handler config sock nread = let rec iter i = let end_pos = b.pos + b.len in if i < end_pos then - if b.buf.[i] = '\n' && i <= end_pos - 2 then - let c = b.buf.[i+1] in + if Bytes.get b.buf i = '\n' && i <= end_pos - 2 then + let c = (Bytes.get b.buf (i+1)) in if c = '\n' then let len = i + 2 - b.pos in - let header = String.sub b.buf b.pos len in + let header = Bytes.sub b.buf b.pos len in buf_used b len; manage config sock header else - if c = '\r' && i <= end_pos - 3 && b.buf.[i+2] = '\n' then + if c = '\r' && i <= end_pos - 3 && Bytes.get b.buf (i+2) = '\n' then let len = i + 3 - b.pos in - let header = String.sub b.buf b.pos len in + let header = Bytes.sub b.buf b.pos len in buf_used b len; manage config sock header else From 2307ee134c5939ed8040ce248193a902036c579c Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Tue, 4 Jun 2024 18:48:02 +0200 Subject: [PATCH 07/69] Updated http client implementation for string immutability. --- src/utils/net/http_client.ml | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/src/utils/net/http_client.ml b/src/utils/net/http_client.ml index 7ccedea3..baab86ca 100644 --- a/src/utils/net/http_client.ml +++ b/src/utils/net/http_client.ml @@ -199,17 +199,17 @@ let read_header header_handler sock nread = let rec iter i = let end_pos = b.pos + b.len in if i < end_pos then - if b.buf.[i] = '\n' && i <= end_pos - 2 then - let c = b.buf.[i+1] in + if Bytes.get b.buf i = '\n' && i <= end_pos - 2 then + let c = (Bytes.get b.buf (i+1)) in if c = '\n' then let len = i + 2 - b.pos in - let header = String.sub b.buf b.pos len in + let header = Bytes.sub b.buf b.pos len |> Bytes.to_string in buf_used b len; header_handler sock header else - if c = '\r' && i <= end_pos - 3 && b.buf.[i+2] = '\n' then + if c = '\r' && i <= end_pos - 3 && (Bytes.get b.buf (i+2)) = '\n' then let len = i + 3 - b.pos in - let header = String.sub b.buf b.pos len in + let header = Bytes.sub b.buf b.pos len |> Bytes.to_string in buf_used b len; header_handler sock header else @@ -416,7 +416,7 @@ let wget r f = min (Int64.to_int (maxlen -- !file_size)) nread else nread in - Buffer.add_string file_buf (String.sub buf.buf buf.pos left); + Buffer.add_bytes file_buf (Bytes.sub buf.buf buf.pos left); buf_used buf left; file_size := !file_size ++ (Int64.of_int left); if nread > left then @@ -501,7 +501,7 @@ let wget_string r f ?(ferr=def_ferr) progress = min (Int64.to_int (maxlen -- !file_size)) nread else nread in - Buffer.add_string file_buf (String.sub buf.buf buf.pos left); + Buffer.add_bytes file_buf (Bytes.sub buf.buf buf.pos left); progress left maxlen; buf_used buf left; file_size := !file_size ++ (Int64.of_int left); @@ -525,16 +525,22 @@ let wget_string r f ?(ferr=def_ferr) progress = let split_header header = - for i = 0 to String.length header - 1 do - if header.[i] = '\r' then header.[i] <- '\n'; + let len = String.length header in + let header_bytes = Bytes.of_string header in + for i = 0 to len - 1 do + if Bytes.get header_bytes i = '\r' then + Bytes.set header_bytes i '\n' done; - for i = String.length header - 1 downto 1 do - if header.[i-1] = '\n' then - if header.[i] = ' ' then (header.[i] <- ','; header.[i-1] <- ',') - else - if header.[i] = ',' then header.[i-1] <- ','; + for i = len - 1 downto 1 do + if Bytes.get header_bytes (i - 1) = '\n' then + if Bytes.get header_bytes i = ' ' then ( + Bytes.set header_bytes i ','; + Bytes.set header_bytes (i - 1) ',' + ) else if Bytes.get header_bytes i = ',' then + Bytes.set header_bytes (i - 1) ',' done; - String2.split_simplify header '\n' + let modified_header = Bytes.to_string header_bytes in + String2.split_simplify modified_header '\n' let cut_headers headers = try From c0bb859f3afb69915b349e4d572717820e9dc3c3 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Tue, 4 Jun 2024 19:14:20 +0200 Subject: [PATCH 08/69] Ported base64 implementation to immutable strings. --- src/utils/net/base64.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/net/base64.ml b/src/utils/net/base64.ml index d3d30420..3f1d8ed7 100644 --- a/src/utils/net/base64.ml +++ b/src/utils/net/base64.ml @@ -57,7 +57,7 @@ let encode_with_options b64 equal s pos len linelen crlf = in (* l_t': length of the result with CRLF or LF characters *) - let t = String.make l_t' equal in + let t = Bytes.make l_t' equal in let j = ref 0 in let q = ref 0 in for k = 0 to len / 3 - 1 do From e997cc352493f6f19c82aee5c711be814ae5dc4c Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Tue, 4 Jun 2024 19:14:46 +0200 Subject: [PATCH 09/69] Ported commonFile to immutable strings. --- src/daemon/common/commonFile.ml | 8 +++++--- src/daemon/common/commonFile.mli | 3 ++- src/daemon/common/commonMultimedia.ml | 7 ++++--- src/daemon/common/commonSwarming.ml | 22 +++++++++++----------- 4 files changed, 22 insertions(+), 18 deletions(-) diff --git a/src/daemon/common/commonFile.ml b/src/daemon/common/commonFile.ml index 769a1749..8cd0b6d6 100644 --- a/src/daemon/common/commonFile.ml +++ b/src/daemon/common/commonFile.ml @@ -975,7 +975,7 @@ let recover_bytes file = if pos = max then iter_file_out file_pos segments else - if s.[pos] = '\000' then + if Bytes.get s pos = '\000' then iter_string_out file_pos (pos+1) max segments else let begin_pos = file_pos -- (Int64.of_int (max - pos)) in @@ -995,7 +995,7 @@ let recover_bytes file = if pos = max then iter_file_in file_pos begin_pos segments else - if s.[pos] = '\000' then + if Bytes.get s pos = '\000' then let end_pos = file_pos -- (Int64.of_int (max - pos)) in (* lprintf " 0 byte at %Ld\n" end_pos; *) iter_string_out file_pos (pos+1) max @@ -1126,7 +1126,7 @@ let _ = (* *) (*************************************************************************) -let file_write file offset s pos len = +let file_write_bytes file offset s pos len = (* lprintf "DOWNLOADED: %d/%d/%d\n" pos len (String.length s); AnyEndian.dump_sub s pos len; @@ -1137,6 +1137,8 @@ let file_write file offset s pos len = else Unix32.write (file_fd file) offset s pos len +let file_write_string file offset s pos len = file_write_bytes file offset (Bytes.of_string s) pos len + let file_verify file key begin_pos end_pos = Unix32.flush_fd (file_fd file); if !verbose_md4 then begin diff --git a/src/daemon/common/commonFile.mli b/src/daemon/common/commonFile.mli index db8abe1c..40f4a8da 100644 --- a/src/daemon/common/commonFile.mli +++ b/src/daemon/common/commonFile.mli @@ -134,7 +134,8 @@ val file_comment : CommonTypes.file -> string val file_magic : CommonTypes.file -> string option val check_magic : CommonTypes.file -> unit val recover_bytes : CommonTypes.file -> (int64 * int64) list -val file_write : CommonTypes.file -> int64 -> string -> int -> int -> unit +val file_write_bytes : CommonTypes.file -> int64 -> bytes -> int -> int -> unit +val file_write_string : CommonTypes.file -> int64 -> string -> int -> int -> unit val file_verify : CommonTypes.file -> CommonTypes.uid_type -> int64 -> int64 -> bool val file_mtime : CommonTypes.file -> float diff --git a/src/daemon/common/commonMultimedia.ml b/src/daemon/common/commonMultimedia.ml index e68bc310..88036a26 100644 --- a/src/daemon/common/commonMultimedia.ml +++ b/src/daemon/common/commonMultimedia.ml @@ -223,14 +223,15 @@ let get_theora_cs n = (* page_seek *) (* *) (**********************************************************************************) - +let ogg_bytes = Bytes.of_string "OggS" +let is_ogg_header s = (s = ogg_bytes) let rec page_seek ic s pos = if (pos_in ic - pos) > 255 then failwith "No more OGG Stream Header" else begin really_input ic s 0 4; seek_in ic (pos_in ic - 3); - if s = "OggS" + if is_ogg_header s then seek_in ic (pos_in ic + 3) else page_seek ic s pos end @@ -280,7 +281,7 @@ let rec next_ogg_stream ic ogg_infos str stream_number = seek_in ic (pos+24); let content_type = String.create 1 in really_input ic content_type 0 1; - let content_type = int_of_char content_type.[0] in + let content_type = int_of_char (Bytes.get content_type 0) in seek_in ic (pos+25); let stream_type = String.create 8 in really_input ic stream_type 0 8; diff --git a/src/daemon/common/commonSwarming.ml b/src/daemon/common/commonSwarming.ml index ba59204c..64e8396a 100644 --- a/src/daemon/common/commonSwarming.ml +++ b/src/daemon/common/commonSwarming.ml @@ -140,7 +140,7 @@ and swarmer = { mutable s_strategy : swarming_strategy; mutable s_verified_bitmap : VerificationBitmap.t; - mutable s_priorities_bitmap : string; + mutable s_priorities_bitmap : bytes; mutable s_priorities_intervals : (int64 * int) list; (* beginning, priority *) mutable s_disk_allocated : Bitv.t; @@ -579,7 +579,7 @@ let dummy_swarmer = { s_networks = []; s_strategy = AdvancedStrategy; s_verified_bitmap = VB.create 0 VB.State_missing; - s_priorities_bitmap = ""; + s_priorities_bitmap = Bytes.empty; s_priorities_intervals = [(zero, 1)]; s_disk_allocated = Bitv.create 0 false; s_blocks = [||]; @@ -639,7 +639,7 @@ let priority_zero = Char.chr 0 let swarmer_recompute_priorities_bitmap s = String.fill s.s_priorities_bitmap 0 - (String.length s.s_priorities_bitmap) priority_zero; + (Bytes.length s.s_priorities_bitmap) priority_zero; let mark interval_begin interval_end priority = if interval_end > interval_begin && s.s_size >= interval_end && interval_begin >= 0L then if priority = 0 then @@ -704,7 +704,7 @@ let create_swarmer file_name file_size = s_strategy = AdvancedStrategy; s_verified_bitmap = VB.create nblocks VB.State_missing; - s_priorities_bitmap = String.make nblocks priority_zero; + s_priorities_bitmap = Bytes.make nblocks priority_zero; s_priorities_intervals = [(zero, 1)]; (* JAVE init all prios to 1, thus all chunks will be downloaded as usual *) s_disk_allocated = Bitv.create ndiskblocks false; s_blocks = Array.make nblocks EmptyBlock ; @@ -837,7 +837,7 @@ let split_blocks s chunk_size = s.s_blocks <- Array.make nblocks EmptyBlock; s.s_verified_bitmap <- VB.create nblocks VB.State_missing; - s.s_priorities_bitmap <- String.make nblocks priority_zero; + s.s_priorities_bitmap <- Bytes.make nblocks priority_zero; s.s_block_pos <- Array.make nblocks zero; s.s_availability <- Array.make nblocks 0; (* not preserved ? *) s.s_nuploading <- Array.make nblocks 0; (* not preserved ? *) @@ -2041,7 +2041,7 @@ let linear_select_blocks up = up.up_npartial <- n-1; let t = up.up_t in let s = t.t_s in - if s.s_priorities_bitmap.[b] = priority_zero then iter_partial up else + if (Bytes.get s.s_priorities_bitmap b) = priority_zero then iter_partial up else let chunk = t.t_chunk_of_block.(b) in match s.s_blocks.(b) with | CompleteBlock | VerifiedBlock -> @@ -2067,7 +2067,7 @@ let linear_select_blocks up = up.up_ncomplete <- n-1; let t = up.up_t in let s = t.t_s in - if s.s_priorities_bitmap.[b] = priority_zero then iter_complete up else + if (Bytes.get s.s_priorities_bitmap b) = priority_zero then iter_complete up else let chunk = t.t_chunk_of_block.(b) in match s.s_blocks.(b) with | CompleteBlock | VerifiedBlock -> @@ -2238,7 +2238,7 @@ let select_blocks up = { choice_num = n; choice_block = b; - choice_user_priority = Char.code s.s_priorities_bitmap.[b]; + choice_user_priority = Char.code (Bytes.get s.s_priorities_bitmap b); choice_remaining = remaining; choice_preallocated = is_fully_preallocated t block_begin block_end; choice_unselected_remaining = unselected_remaining; @@ -2387,7 +2387,7 @@ let select_blocks up = Array2.subarray_fold_lefti (fun ((current_chunk_num, current_chunk_blocks_indexes, best_choices, specimen) as acc) n b -> - if s.s_priorities_bitmap.[b] = priority_zero || + if (Bytes.get s.s_priorities_bitmap b) = priority_zero || not (should_download_block s b) then acc else let chunk_num = t.t_chunk_of_block.(b) in @@ -2733,7 +2733,7 @@ let find_range up range_size = let block = up.up_complete_blocks.(i) in if not (List.exists (fun b -> b.up_block.block_num = block ) up.up_blocks) then - if s.s_priorities_bitmap.[block] <> priority_zero && + if (Bytes.get s.s_priorities_bitmap block) <> priority_zero && should_download_block s block then let partial_found = match s.s_blocks.(block) with | EmptyBlock -> true @@ -2909,7 +2909,7 @@ let received up file_begin str string_begin string_len = (Printexc2.to_string e) r.range_begin file_end (file_best_name t.t_file)); - file_write tprim.t_file + file_write_bytes tprim.t_file r.range_begin str string_pos string_length; range_received (Some t) r r.range_begin file_end; From 28f5791a7f5f543ad4faa8faf4aa8859ce4dfddc Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 00:15:48 +0200 Subject: [PATCH 10/69] Ported commonUploads to immutable strings. --- src/daemon/common/commonUploads.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/daemon/common/commonUploads.ml b/src/daemon/common/commonUploads.ml index d63fc1fc..4d171d0d 100644 --- a/src/daemon/common/commonUploads.ml +++ b/src/daemon/common/commonUploads.ml @@ -300,7 +300,7 @@ let md4_of_list md4s = iter tail (i+16) in iter md4s 0; - Md4.string s + Md4.string (Bytes.to_string s) let rec tiger_of_array array pos block = if block = 1 then @@ -316,7 +316,7 @@ let rec tiger_of_array array pos block = s.[0] <- '\001'; String.blit (TigerTree.direct_to_string d1) 0 s 1 Tiger.length; String.blit (TigerTree.direct_to_string d2) 0 s (1+Tiger.length) Tiger.length; - let t = Tiger.string s in + let t = Tiger.string (Bytes.to_string s) in let t = TigerTree.direct_of_string (Tiger.direct_to_string t) in t @@ -349,7 +349,7 @@ let tiger_node d1 d2 = s.[0] <- '\001'; String.blit (TigerTree.direct_to_string d1) 0 s 1 Tiger.length; String.blit (TigerTree.direct_to_string d2) 0 s (1+Tiger.length) Tiger.length; - let t = Tiger.string s in + let t = Tiger.string (Bytes.to_string s) in let t = TigerTree.direct_of_string (Tiger.direct_to_string t) in t @@ -416,7 +416,7 @@ let build_tiger_tree_file uid ttr = let s = make_tiger_tree ttr in Unix2.safe_mkdir "ttr"; Unix2.can_write_to_directory "ttr"; - File.from_string (Filename.concat "ttr" (Uid.to_file_string uid)) s + File.from_string (Filename.concat "ttr" (Uid.to_file_string uid)) (Bytes.to_string s) let rec start_job_for sh (wanted_id, handler) = let info = IndexedSharedFiles.get_result sh.shared_info in @@ -506,7 +506,7 @@ computation ??? *) let len = Int64.to_int len64 in let s = String.create len in Unix32.read fd zero s 0 len; - Md5Ext.string s + Md5Ext.string (Bytes.to_string s) with e -> current_job := None; raise e From 48d5f5fb1e85dc9de56597e23c100f8e6769f849 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 00:16:13 +0200 Subject: [PATCH 11/69] Ported commonWeb to immutable strings. --- src/daemon/common/commonWeb.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/daemon/common/commonWeb.ml b/src/daemon/common/commonWeb.ml index d109d115..4cae772c 100755 --- a/src/daemon/common/commonWeb.ml +++ b/src/daemon/common/commonWeb.ml @@ -265,7 +265,7 @@ let _ = while true do let nread = Unix.read pipe_out buffer 0 buffersize in if nread = 0 then raise End_of_file; - Buffer.add_substring output buffer 0 nread + Buffer.add_subbytes output buffer 0 nread done with | End_of_file -> () From 8476c2d621380a82e455bbb673fb5d04d3a771be Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 00:35:38 +0200 Subject: [PATCH 12/69] Ported giftDecoding to immutable strings. --- src/daemon/common/giftDecoding.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/daemon/common/giftDecoding.ml b/src/daemon/common/giftDecoding.ml index 8e9fe8af..06ded55d 100755 --- a/src/daemon/common/giftDecoding.ml +++ b/src/daemon/common/giftDecoding.ml @@ -11,11 +11,11 @@ let gui_cut_messages f sock nread = try let rec iter pos len = if len = 0 then raise Not_found; - if b.buf.[pos] = ';' && ( + if Bytes.get b.buf pos = ';' && ( pos = b.pos || - (pos > b.pos && b.buf.[pos-1] <> '\\')) then begin + (pos > b.pos && Bytes.get b.buf (pos-1) <> '\\')) then begin let len = pos - b.pos+1 in - let s = String.sub b.buf b.pos len in + let s = Bytes.sub b.buf b.pos len in buf_used b len; f s; iter b.pos b.len From b7fa734842fe63c5cd878e2287dbebebd6035fa4 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 01:44:54 +0200 Subject: [PATCH 13/69] Ported gui encoding/decoding to immutable strings. --- src/daemon/common/guiDecoding.ml | 4 ++-- src/daemon/common/guiEncoding.ml | 4 ++-- src/utils/net/littleEndian.ml | 3 +++ 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/daemon/common/guiDecoding.ml b/src/daemon/common/guiDecoding.ml index 4fc5af22..203c95a5 100644 --- a/src/daemon/common/guiDecoding.ml +++ b/src/daemon/common/guiDecoding.ml @@ -42,10 +42,10 @@ let gui_cut_messages f sock nread = let b = buf sock in try while b.len >= 4 do - let msg_len = get_int b.buf b.pos in + let msg_len = get_int_bytes b.buf b.pos in if b.len >= 4 + msg_len then begin - let s = String.sub b.buf (b.pos+4) msg_len in + let s = Bytes.sub b.buf (b.pos+4) msg_len in buf_used b (msg_len + 4); let opcode = get_int16 s 0 in (f opcode s : unit) diff --git a/src/daemon/common/guiEncoding.ml b/src/daemon/common/guiEncoding.ml index eddfbd39..25847f7a 100644 --- a/src/daemon/common/guiEncoding.ml +++ b/src/daemon/common/guiEncoding.ml @@ -44,8 +44,8 @@ let gui_send writer sock t = Buffer.reset buf; buf_int buf 0; writer buf t; - let s = Buffer.contents buf in - let len = String.length s - 4 in + let s = Buffer.to_bytes buf in + let len = Bytes.length s - 4 in str_int s 0 len; write_string sock s; with UnsupportedGuiMessage -> () diff --git a/src/utils/net/littleEndian.ml b/src/utils/net/littleEndian.ml index 8df399d1..01fc9bb5 100644 --- a/src/utils/net/littleEndian.ml +++ b/src/utils/net/littleEndian.ml @@ -93,6 +93,9 @@ let get_int s pos = let x = c1 lor (c2 lsl 8) lor (c3 lsl 16) lor (c4 lsl 24) in x +let get_int_bytes s pos = + get_int (Bytes.unsafe_to_string s) pos + (******** Operations on 32 bits integers ******* let buf_int32 oc i = From 90c7d8bee1f0e32507dd1e6303596060b8336a9c Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 02:04:43 +0200 Subject: [PATCH 14/69] Ported driverCommands to immutable strings. --- src/daemon/driver/driverCommands.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/daemon/driver/driverCommands.ml b/src/daemon/driver/driverCommands.ml index 731789bc..7d0f4cae 100644 --- a/src/daemon/driver/driverCommands.ml +++ b/src/daemon/driver/driverCommands.ml @@ -1394,7 +1394,7 @@ let _ = while true do let nread = Unix.read pipe_out buffer 0 buffersize in if nread = 0 then raise End_of_file; - Buffer.add_substring output buffer 0 nread + Buffer.add_subbytes output buffer 0 nread done with | End_of_file -> () @@ -3897,7 +3897,7 @@ let _ = let downloaded = CommonSwarming.get_swarmer_block_verified swarmer in pr "\\"; pr "priorities: "; - String.iter (fun c -> + Bytes.iter (fun c -> let c = max 0 (min 9 (Char.code c)) in let c = Char.chr (c + Char.code '0') in Buffer.add_char buf c) prio; From 422ade2dc1a4be42e4e667bebf3729b081d1ec1a Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 02:17:49 +0200 Subject: [PATCH 15/69] Ported daemon drivers to immutable strings. --- src/daemon/driver/driverControlers.ml | 14 +++++++------- src/daemon/driver/driverInterface.ml | 2 +- src/daemon/driver/driverMain.ml | 2 +- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/daemon/driver/driverControlers.ml b/src/daemon/driver/driverControlers.ml index af1ca2ed..0f026a96 100644 --- a/src/daemon/driver/driverControlers.ml +++ b/src/daemon/driver/driverControlers.ml @@ -464,7 +464,7 @@ let user_reader o telnet sock nread = let b = TcpBufferedSocket.buf sock in let rec iter () = if b.len > 0 then - let c = b.buf.[b.pos] in + let c = Bytes.get b.buf b.pos in buf_used b 1; (* lprintf "char %d\n" (int_of_char c); *) if c = '\255' && not telnet.telnet_iac then begin @@ -766,9 +766,9 @@ let read_theme_page page = let theme_page = get_theme_page page in Unix2.tryopen_read theme_page (fun file -> let size = (Unix.stat theme_page).Unix.st_size in - let s = String.make size ' ' in + let s = Bytes.make size ' ' in really_input file s 0 size; - s) + (Bytes.to_string s)) let http_add_gen_header r = add_reply_header r "Server" ("MLdonkey/"^Autoconf.current_version); @@ -928,7 +928,7 @@ let send_preview r file fd size filename exten = add_reply_header r "Content-Disposition" (Printf.sprintf "inline;filename=\"%s\"" (Filename.basename filename)); let s = String.create 200000 in - set_max_output_buffer r.sock (String.length s); + set_max_output_buffer r.sock (Bytes.length s); set_rtimeout r.sock 10000.; let rec stream_file file pos sock = let max = (max_refill sock) - 1 in @@ -1557,11 +1557,11 @@ let http_handler o t r = let s = match !http_file_type with - HTM -> html_close_page buf false; dollar_escape o true (Buffer.contents buf) - | MLHTM -> html_close_page buf true; dollar_escape o true (Buffer.contents buf) + HTM -> html_close_page buf false; dollar_escape o true (Buffer.to_bytes buf) + | MLHTM -> html_close_page buf true; dollar_escape o true (Buffer.to_bytes buf) | TXT | UNK - | BIN -> Buffer.contents buf + | BIN -> Buffer.to_bytes buf in r.reply_content <- if !http_file_type <> BIN && !!html_use_gzip then diff --git a/src/daemon/driver/driverInterface.ml b/src/daemon/driver/driverInterface.ml index abd5e044..d280e9a6 100644 --- a/src/daemon/driver/driverInterface.ml +++ b/src/daemon/driver/driverInterface.ml @@ -1250,7 +1250,7 @@ let gift_handler t event = TcpBufferedSocket.set_max_output_buffer sock !!interface_buffer; TcpBufferedSocket.set_reader sock (GiftDecoding.gui_cut_messages (fun s -> - let m = GiftDecoding.from_gui gui s in + let m = GiftDecoding.from_gui gui (Bytes.to_string s) in gui_reader gui m sock; )); TcpBufferedSocket.set_closer sock (gui_closed gui); diff --git a/src/daemon/driver/driverMain.ml b/src/daemon/driver/driverMain.ml index 81d0eedc..97e24e7d 100644 --- a/src/daemon/driver/driverMain.ml +++ b/src/daemon/driver/driverMain.ml @@ -685,7 +685,7 @@ for config files at the end. *) try let oc = Unix.openfile security_space_filename [Unix.O_WRONLY; Unix.O_CREAT] 0o600 in let len = 32768 in - let s = String.make len ' ' in + let s = Bytes.make len ' ' in let pos = ref zero in for i = 1 to !!config_files_security_space do for j = 1 to 32 do (* 32 = 1 MB / 32kB *) From b2bd7d73e2d4577d085ccefbfac0d6488ce007e3 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 02:20:51 +0200 Subject: [PATCH 16/69] Ported mailer to immutable strings. --- src/utils/net/mailer.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/utils/net/mailer.ml b/src/utils/net/mailer.ml index f22bf0c2..8777da94 100644 --- a/src/utils/net/mailer.ml +++ b/src/utils/net/mailer.ml @@ -143,9 +143,9 @@ let canon_addr s = iter_end s (len - 1) let string_xor s1 s2 = - assert (String.length s1 = String.length s2); - let s = String.create (String.length s1) in - for i = 0 to String.length s - 1 do + assert (Bytes.length s1 = Bytes.length s2); + let s = Bytes.create (Bytes.length s1) in + for i = 0 to Bytes.length s - 1 do s.[i] <- Char.chr (Char.code s1.[i] lxor Char.code s2.[i]); done; s @@ -157,7 +157,7 @@ let hmac_md5 = let md5 s = Md5.direct_to_string (Md5.string s) in fun secret challenge -> let secret = if String.length secret > 64 then md5 secret else secret in - let k = String.make 64 '\x00' in + let k = Bytes.make 64 '\x00' in String.blit secret 0 k 0 (String.length secret); md5 (string_xor k opad ^ md5 (string_xor k ipad ^ challenge)) From 044bd3910fc996538d7bf69e54dfc240381e0466 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 02:30:54 +0200 Subject: [PATCH 17/69] Ported udpsocket to immutable strings. --- src/utils/net/littleEndian.ml | 8 +++++++- src/utils/net/udpSocket.ml | 32 ++++++++++++++++---------------- src/utils/net/udpSocket.mli | 4 ++-- 3 files changed, 25 insertions(+), 19 deletions(-) diff --git a/src/utils/net/littleEndian.ml b/src/utils/net/littleEndian.ml index 01fc9bb5..70d6ba43 100644 --- a/src/utils/net/littleEndian.ml +++ b/src/utils/net/littleEndian.ml @@ -58,7 +58,10 @@ let get_int16 s pos = let c1 = int_of_char s.[pos] in let c2 = int_of_char s.[pos+1] in c1 lor (c2 lsl 8) - + +let get_int16_bytes s pos = + get_int16 (Bytes.unsafe_to_string s) pos + let str_int24 s pos i = s.[pos] <- char_of_int (i land 255); s.[pos+1] <- char_of_int ((i lsr 8) land 255); @@ -165,6 +168,9 @@ let get_ip s pos = let c4 = int_of_char s.[pos+3] in Ip.of_ints (c1, c2, c3, c4) +let get_ip_bytes s pos = + get_ip (Bytes.unsafe_to_string s) pos + let buf_ip buf ip = let (ip0,ip1,ip2,ip3) = Ip.to_ints ip in buf_int8 buf ip0; diff --git a/src/utils/net/udpSocket.ml b/src/utils/net/udpSocket.ml index 5246bfeb..1959ffb5 100644 --- a/src/utils/net/udpSocket.ml +++ b/src/utils/net/udpSocket.ml @@ -92,7 +92,7 @@ let declare_pong = exn_log "declare_pong" declare_pong type udp_packet = { udp_ping : bool; - udp_content: string; + udp_content: bytes; udp_addr: Unix.sockaddr; (* val sendto : Unix.file_descr -> string -> int -> int -> @@ -110,13 +110,13 @@ let local_sendto sock p = declare_ping ip | _ -> () end; - Unix.sendto sock p.udp_content 0 (String.length p.udp_content) [] p.udp_addr + Unix.sendto sock p.udp_content 0 (Bytes.length p.udp_content) [] p.udp_addr module PacketSet = Set.Make (struct type t = int * udp_packet let compare (t1,p1) (t2,p2) = - compare (t1, String.length p1.udp_content,p1) (t2, String.length p2.udp_content,p2) + compare (t1, Bytes.length p1.udp_content,p1) (t2, Bytes.length p2.udp_content,p2) end) type socks_proxy = { @@ -220,8 +220,8 @@ let write t ping s ip port = buf_int8 buf 1; buf_ip buf ip; buf_int16 buf port; - Buffer.add_string buf s; - Buffer.contents buf, Unix.ADDR_INET(Ip.to_inet_addr ip, port) + Buffer.add_bytes buf s; + Buffer.to_bytes buf, Unix.ADDR_INET(Ip.to_inet_addr ip, port) in match t.write_controler with None -> @@ -229,7 +229,7 @@ let write t ping s ip port = begin let sock = sock t in try - let len = String.length s in + let len = Bytes.length s in let _ = try @@ -255,7 +255,7 @@ lprintf_nl "UDP sent [%s]" (String.escaped udp_content = s ; udp_addr = addr; }) t.wlist; - t.wlist_size <- t.wlist_size + String.length s; + t.wlist_size <- t.wlist_size + Bytes.length s; must_write sock true; | e -> lprintf_nl "Exception %s in sendto" @@ -269,7 +269,7 @@ lprintf_nl "UDP sent [%s]" (String.escaped udp_content = s ; udp_addr = addr; }) t.wlist; - t.wlist_size <- t.wlist_size + String.length s; + t.wlist_size <- t.wlist_size + Bytes.length s; must_write t.sock true; end | Some bc -> @@ -280,7 +280,7 @@ lprintf_nl "UDP sent [%s]" (String.escaped udp_content = s; udp_addr = addr; }) t.wlist; - t.wlist_size <- t.wlist_size + String.length s; + t.wlist_size <- t.wlist_size + Bytes.length s; must_write t.sock true; end else @@ -295,8 +295,8 @@ let read_buf = String.create 66000 let rec iter_write_no_bc t sock = let (time,p) = PacketSet.min_elt t.wlist in t.wlist <- PacketSet.remove (time,p) t.wlist; - t.wlist_size <- t.wlist_size - String.length p.udp_content; - let len = String.length p.udp_content in + t.wlist_size <- t.wlist_size - Bytes.length p.udp_content; + let len = Bytes.length p.udp_content in begin try ignore (local_sendto (fd sock) p); udp_uploaded_bytes := !udp_uploaded_bytes ++ (Int64.of_int len); @@ -326,14 +326,14 @@ let rec iter_write t sock bc = let _ = () in let (time,p) = PacketSet.min_elt t.wlist in t.wlist <- PacketSet.remove (time,p) t.wlist; - t.wlist_size <- t.wlist_size - String.length p.udp_content; + t.wlist_size <- t.wlist_size - Bytes.length p.udp_content; if time < bc.base_time then begin if !debug then begin lprintf_nl "UDP DROPPED in iter_write"; end; iter_write t sock bc end else - let len = String.length p.udp_content in + let len = Bytes.length p.udp_content in begin try ignore (local_sendto (fd sock) p); udp_uploaded_bytes := !udp_uploaded_bytes ++ (Int64.of_int len); @@ -368,10 +368,10 @@ let udp_handler t sock event = | CAN_READ -> let (len, addr) = Unix.recvfrom (fd sock) read_buf 0 66000 [] in let s, addr = match t.socks_proxy with - None -> String.sub read_buf 0 len, addr + None -> Bytes.sub read_buf 0 len, addr | Some _ -> - String.sub read_buf 10 (len-10), - Unix.ADDR_INET(Ip.to_inet_addr (get_ip read_buf 4), get_int16 read_buf 8) + Bytes.sub read_buf 10 (len-10), + Unix.ADDR_INET(Ip.to_inet_addr (get_ip_bytes read_buf 4), get_int16_bytes read_buf 8) in udp_downloaded_bytes := !udp_downloaded_bytes ++ (Int64.of_int len); t.rlist <- { diff --git a/src/utils/net/udpSocket.mli b/src/utils/net/udpSocket.mli index 8ee55809..2168b238 100644 --- a/src/utils/net/udpSocket.mli +++ b/src/utils/net/udpSocket.mli @@ -22,7 +22,7 @@ type event = | READ_DONE | BASIC_EVENT of BasicSocket.event type udp_packet = { - udp_ping: bool; udp_content : string; udp_addr : Unix.sockaddr; } + udp_ping: bool; udp_content : bytes; udp_addr : Unix.sockaddr; } type t (* type t = { @@ -41,7 +41,7 @@ val set_reader : t -> (t -> unit) -> unit val sock : t -> BasicSocket.t val closed : t -> bool val close : t -> BasicSocket.close_reason -> unit -val write : t -> bool -> string -> Ip.t -> int -> unit +val write : t -> bool -> bytes -> Ip.t -> int -> unit val create : Unix.inet_addr -> int -> handler -> t val create_sendonly : unit -> t val can_write : t -> bool From 59984149b65c691bad2e065373c0b65ac8f435f8 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 02:38:51 +0200 Subject: [PATCH 18/69] Ported mp3tag to immutable strings. --- src/utils/mp3tagui/mp3_info.ml | 16 ++++++++-------- src/utils/mp3tagui/mp3_tag.ml | 16 ++++++++-------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/utils/mp3tagui/mp3_info.ml b/src/utils/mp3tagui/mp3_info.ml index 6d64df9a..ae7ac5da 100644 --- a/src/utils/mp3tagui/mp3_info.ml +++ b/src/utils/mp3tagui/mp3_info.ml @@ -38,9 +38,9 @@ type t = } let check_head h = - let h0 = Char.code h.[0] - and h1 = Char.code h.[1] - and h2 = Char.code h.[2] in + let h0 = Char.code (Bytes.get h 0) + and h1 = Char.code (Bytes.get h 1) + and h2 = Char.code (Bytes.get h 2) in h0 = 0xFF && h1 land 0xE0 = 0xE0 && h1 land 0x18 <> 0x08 && @@ -80,7 +80,7 @@ let get_xing_header ic header = seek_in ic (pos_in ic + offset); let buf = String.create 4 in really_input ic buf 0 4; - if buf <> "Xing" then raise Not_found; + if buf <> (Bytes.of_string "Xing") then raise Not_found; let flags = read_i4 ic in (* 3 = FRAMES_FLAG | BYTES_FLAG *) if flags land 3 <> 3 then raise Not_found; @@ -93,13 +93,13 @@ let for_channel ic = let buf = String.create 4 in really_input ic buf 0 4; while not (check_head buf) do - String.blit buf 1 buf 0 3; + Bytes.blit buf 1 buf 0 3; buf.[3] <- input_char ic done; let header = - (Char.code buf.[1] lsl 16) lor - (Char.code buf.[2] lsl 8) lor - (Char.code buf.[3]) in + (Char.code (Bytes.get buf 1) lsl 16) lor + (Char.code (Bytes.get buf 2) lsl 8) lor + (Char.code (Bytes.get buf 3)) in let (lsf, mpeg25) = if header land 0x100000 <> 0 then ((if header land 0x80000 = 0 then 1 else 0), false) diff --git a/src/utils/mp3tagui/mp3_tag.ml b/src/utils/mp3tagui/mp3_tag.ml index f5dd6bbc..633df6f7 100644 --- a/src/utils/mp3tagui/mp3_tag.ml +++ b/src/utils/mp3tagui/mp3_tag.ml @@ -48,7 +48,7 @@ module Id3v1 = seek_in ic (len - 128); let buffer = String.create 3 in really_input ic buffer 0 3; - buffer = "TAG" + buffer = (Bytes.of_string "TAG") end in close_in ic; res @@ -60,7 +60,7 @@ let read_channel ic = let readstring len = let buf = String.create len in really_input ic buf 0 len; - Mp3_misc.chop_whitespace buf 0 in + Mp3_misc.chop_whitespace (Bytes.to_string buf) 0 in if readstring 3 <> "TAG" then raise Not_found; let title = readstring 30 in let artist = readstring 30 in @@ -161,7 +161,7 @@ module Id3v2 = struct for i = 1 to n do ignore(input_byte ic) done let valid_header header = - String.sub header 0 3 = "ID3" + Bytes.sub header 0 3 = "ID3" && (Char.code header.[3] = 3 || Char.code header.[3] = 4) && Char.code header.[5] land 0b00111111 = 0 && Char.code header.[6] land 0b10000000 = 0 @@ -188,7 +188,7 @@ module Id3v2 = struct let read_channel ic = try - let header = String.create 10 in + let header = Bytes.create 10 in really_input ic header 0 10; if not (valid_header header) then raise Not_found; let len = length_header header in @@ -202,11 +202,11 @@ module Id3v2 = struct (* Collect frames *) let tags = ref [] in while pos_in ic < startpos + len do - let frameid = input_buffer ic 4 in + let frameid = (Bytes.to_string (input_buffer ic 4)) in let framelen = input_int4 ic in let flags1 = input_byte ic in let flags2 = input_byte ic in - let framedata = input_buffer ic framelen in + let framedata = (Bytes.to_string (input_buffer ic framelen)) in if flags1 land 0b00011111 = 0 && flags2 = 0 then begin try tags := (frameid, decode_framedata frameid framedata) :: !tags @@ -280,7 +280,7 @@ module Id3v2 = struct let ic = open_in_bin filename in try begin try - let header = String.create 10 in + let header = Bytes.create 10 in really_input ic header 0 10; if not (valid_header header) then raise Not_found; seek_in ic (pos_in ic + length_header header) @@ -289,7 +289,7 @@ module Id3v2 = struct end; let buffer = String.create 4096 in let rec copy_file () = - let n = input ic buffer 0 (String.length buffer) in + let n = input ic buffer 0 (Bytes.length buffer) in if n = 0 then () else begin output oc buffer 0 n; copy_file () end in copy_file (); close_in ic From ba4764bf5dfae43bc68d40cb379d99b27391b5f0 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 03:14:20 +0200 Subject: [PATCH 19/69] Ported utils to string immutability. --- src/utils/lib/bitv.ml | 4 +-- src/utils/lib/magiclib.ml | 2 +- src/utils/lib/md4.ml | 42 ++++++++++++++-------------- src/utils/lib/misc.ml | 2 +- src/utils/lib/misc2.mlcpp | 2 +- src/utils/lib/options.ml4 | 2 +- src/utils/lib/store.ml | 4 +-- src/utils/lib/unix32.ml | 14 +++++----- src/utils/lib/unix32.mli | 4 +-- src/utils/lib/url.ml | 4 +-- src/utils/lib/verificationBitmap.ml | 32 ++++++++++----------- src/utils/lib/verificationBitmap.mli | 2 +- 12 files changed, 57 insertions(+), 57 deletions(-) diff --git a/src/utils/lib/bitv.ml b/src/utils/lib/bitv.ml index 707a06d3..78225879 100644 --- a/src/utils/lib/bitv.ml +++ b/src/utils/lib/bitv.ml @@ -455,11 +455,11 @@ let all_ones v = let to_string v = let n = v.length in - let s = String.make n '0' in + let s = Bytes.make n '0' in for i = 0 to n - 1 do if unsafe_get v i then s.[i] <- '1' done; - s + (Bytes.to_string s) let print fmt v = Format.pp_print_string fmt (to_string v) diff --git a/src/utils/lib/magiclib.ml b/src/utils/lib/magiclib.ml index b8e19b2b..f07a221a 100644 --- a/src/utils/lib/magiclib.ml +++ b/src/utils/lib/magiclib.ml @@ -75,7 +75,7 @@ let escape_colon s = if s.[i] = ':' then (s'.[!j] <- '\\'; incr j); s'.[!j] <- s.[i]; incr j done; - s' + Bytes.to_string s' (* Concatenate the filenames with ":". If ":" is present in a filename, escape it. *) diff --git a/src/utils/lib/md4.ml b/src/utils/lib/md4.ml index 40bb0282..3b2418e4 100644 --- a/src/utils/lib/md4.ml +++ b/src/utils/lib/md4.ml @@ -54,7 +54,7 @@ module Base16 = struct p.[2 * i] <- hexa_digit i0; p.[2 * i+1] <- hexa_digit i1; done; - p + (Bytes.to_string p) let hexa_digit_case upper x = if x >= 10 then Char.chr (Char.code ( @@ -71,7 +71,7 @@ module Base16 = struct p.[2 * i] <- hexa_digit_case upper i0; p.[2 * i+1] <- hexa_digit_case upper i1; done; - p + (Bytes.to_string p) let digit_hexa c = let i = int_of_char c in @@ -88,7 +88,7 @@ module Base16 = struct let c1 = s.[2*i+1] in p.[i] <- char_of_int ((16 * digit_hexa c0) + digit_hexa c1); done; - p + (Bytes.to_string p) end @@ -107,7 +107,7 @@ module Base32 = struct let of_string hash_length r = let len = String.length r in assert (len = (hash_length * 8 + 4)/5); - let s = String.make hash_length '\000' in + let s = String.create hash_length in for i = 0 to len - 1 do let pos = i * 5 in let byte = pos / 8 in @@ -115,15 +115,15 @@ module Base32 = struct let c = int5_of_char r.[i] in if bit < 3 then let x = c lsl (3-bit) in - s.[byte] <- char_of_int (int_of_char s.[byte] lor x); + s.[byte] <- char_of_int (int_of_char (Bytes.to_string s).[byte] lor x); else let x = (c lsr (bit - 3)) land 0xff in - s.[byte] <- char_of_int (int_of_char s.[byte] lor x); + s.[byte] <- char_of_int (int_of_char (Bytes.to_string s).[byte] lor x); if byte+1 < hash_length then let y = (c lsl (11 - bit)) land 0xff in - s.[byte+1] <- char_of_int (int_of_char s.[byte+1] lor y); + s.[byte+1] <- char_of_int (int_of_char (Bytes.to_string s).[byte+1] lor y); done; - s + (Bytes.to_string s) let to_string hash_length s = assert (String.length s = hash_length); @@ -145,7 +145,7 @@ module Base32 = struct let c = (x lsr (11 - bit)) land 0x1f in r.[i] <- char_of_int5 c done; - r + (Bytes.to_string r) let char_of_int5 upper n = char_of_int (if n < 26 then (if upper then 65 else 97)+n else @@ -171,7 +171,7 @@ module Base32 = struct let c = (x lsr (11 - bit)) land 0x1f in r.[i] <- char_of_int5 upper c done; - r + (Bytes.to_string r) end @@ -198,7 +198,7 @@ module Base6427 = struct done done; hash64.[!j-1] <- '='; - String.sub hash64 0 !j + Bytes.sub hash64 0 !j let base64tbl_inv = String.create 126 let _ = @@ -207,10 +207,10 @@ module Base6427 = struct done let of_string _ hash64 = - let hashbin = String.make 20 '\000' in + let hashbin = Bytes.make 20 '\000' in let hash64 n = let c = hash64.[n] in - int_of_char base64tbl_inv.[int_of_char c] + int_of_char (Bytes.get base64tbl_inv (int_of_char c)) in let j = ref 0 in for i = 0 to 6 do @@ -233,7 +233,7 @@ module Base6427 = struct hashbin.[!j+1] <- char_of_int ((!tmp lsr 8) land 0xff); j := !j + 2; done; - hashbin + (Bytes.to_string hashbin) let to_string_case _ = to_string end @@ -314,7 +314,7 @@ module Make(M: sig let string s = let len = String.length s in - let digest = String.create hash_length in + let digest = Bytes.create hash_length in unsafe_string digest s len; digest @@ -329,29 +329,29 @@ module Make(M: sig done done; - digest + (Bytes.to_string digest) external xor_c : t -> t -> t -> unit = "md4_xor" "noalloc" let xor m1 m2 = - let m3 = String.create hash_length in + let m3 = Bytes.create hash_length in xor_c m1 m2 m3; m3 let file s = - let digest = String.create hash_length in + let digest = Bytes.create hash_length in let file_size = Unix32.getsize s in unsafe_file digest s file_size; digest let digest_subfile fd pos len = - let digest = String.create hash_length in + let digest = Bytes.create hash_length in Unix32.apply_on_chunk fd pos len (fun fd pos -> digest_subfile digest fd pos len); digest - let create () = String.create hash_length + let create () = Bytes.create hash_length let direct_to_string s = s let direct_of_string s = s @@ -361,7 +361,7 @@ module Make(M: sig for i = 0 to hash_length - 1 do s.[i] <- char_of_int (Random.int 256) done; - s + (Bytes.to_string s) let of_string = Base.of_string hash_length let to_string = Base.to_string hash_length diff --git a/src/utils/lib/misc.ml b/src/utils/lib/misc.ml index b670e1e4..c8800b11 100644 --- a/src/utils/lib/misc.ml +++ b/src/utils/lib/misc.ml @@ -98,7 +98,7 @@ let gz_extract filename = Unix2.tryopen_read_gzip filename (fun ic -> Unix2.tryopen_write_bin file_out (fun oc -> let rec decompress () = - let n = Gzip.input ic buffer 0 (String.length buffer) in + let n = Gzip.input ic buffer 0 (Bytes.length buffer) in if n = 0 then () else begin diff --git a/src/utils/lib/misc2.mlcpp b/src/utils/lib/misc2.mlcpp index 9ba2f447..2f66a393 100644 --- a/src/utils/lib/misc2.mlcpp +++ b/src/utils/lib/misc2.mlcpp @@ -33,7 +33,7 @@ let bz2_extract filename = in let oc = open_out_bin file_out in let rec decompress () = - let n = Bzip2.input ic buffer 0 (String.length buffer) in + let n = Bzip2.input ic buffer 0 (Bytes.length buffer) in if n = 0 then () else begin diff --git a/src/utils/lib/options.ml4 b/src/utils/lib/options.ml4 index 823372bf..5095d2b8 100644 --- a/src/utils/lib/options.ml4 +++ b/src/utils/lib/options.ml4 @@ -208,7 +208,7 @@ and parse_option = parser | [< 'Int i >] -> IntValue i | [< 'Float f >] -> FloatValue f | [< 'Kwd "@"; 'Int i; v = parse_once_value i >] -> OnceValue v -| [< 'Char c >] -> StringValue (let s = String.create 1 in s.[0] <- c; s) +| [< 'Char c >] -> StringValue (let s = String.make 1 c in s) | [< 'Kwd "["; v = parse_list [] >] -> List v | [< 'Kwd "("; v = parse_list [] >] -> List v diff --git a/src/utils/lib/store.ml b/src/utils/lib/store.ml index ffebeeb5..18cbc302 100644 --- a/src/utils/lib/store.ml +++ b/src/utils/lib/store.ml @@ -33,7 +33,7 @@ type 'a file = { mutable file_all_pos : int array; mutable file_cache : 'a Weak.t; mutable file_next_pos : int; - file_chunk : string; + file_chunk : bytes; } type index = int @@ -207,7 +207,7 @@ let get t doc = let str = file_retrieve file pos in begin try - Marshal.from_string str 0 + Marshal.from_bytes str 0 with e -> lprintf_nl "Marshal.from_string error"; raise e diff --git a/src/utils/lib/unix32.ml b/src/utils/lib/unix32.ml index 044ba7c9..458332de 100644 --- a/src/utils/lib/unix32.ml +++ b/src/utils/lib/unix32.ml @@ -318,7 +318,7 @@ module FDCache = struct file_pos len string_pos - (String.length string) + (Bytes.length string) (Printexc2.to_string e); raise e @@ -327,7 +327,7 @@ module FDCache = struct check_destroyed t2; let buffer_len = 128 * 1024 in let buffer_len64 = Int64.of_int buffer_len in - let buffer = String.make buffer_len '\001' in + let buffer = Bytes.make buffer_len '\001' in let rec iter remaining pos1 pos2 = let len64 = min remaining buffer_len64 in let len = Int64.to_int len64 in @@ -363,8 +363,8 @@ module type File = sig val mtime64 : t -> float val exists : t -> bool val remove : t -> unit - val read : t -> int64 -> string -> int -> int -> unit - val write : t -> int64 -> string -> int -> int -> unit + val read : t -> int64 -> bytes -> int -> int -> unit + val write : t -> int64 -> bytes -> int -> int -> unit val destroy : t -> unit val is_closed : t -> bool end @@ -1221,9 +1221,9 @@ let buffer = Buffer.create 65000 let flush_buffer t offset = if !verbose then lprintf_nl "flush_buffer"; - let s = Buffer.contents buffer in + let s = Buffer.to_bytes buffer in Buffer.reset buffer; - let len = String.length s in + let len = Bytes.length s in try if !verbose then lprintf_nl "seek64 %Ld" offset; if len > 0 then write t offset s 0 len; @@ -1349,7 +1349,7 @@ let copy_chunk t1 t2 pos1 pos2 len = flush_fd t1; flush_fd t2; let buffer_size = 128 * 1024 in - let buffer = String.make buffer_size '\001' in + let buffer = Bytes.make buffer_size '\001' in let rec iter remaining pos1 pos2 = let len = mini remaining buffer_size in if len > 0 then begin diff --git a/src/utils/lib/unix32.mli b/src/utils/lib/unix32.mli index 026362db..10b15c00 100644 --- a/src/utils/lib/unix32.mli +++ b/src/utils/lib/unix32.mli @@ -54,11 +54,11 @@ val flush : unit -> unit val flush_fd : t -> unit val buffered_write : t -> int64 -> string -> int -> int -> unit val buffered_write_copy : t -> int64 -> string -> int -> int -> unit -val write : t -> int64 -> string -> int -> int -> unit +val write : t -> int64 -> bytes -> int -> int -> unit val max_buffered : int64 ref val remove : t -> unit -val read : t -> int64 -> string -> int -> int -> unit +val read : t -> int64 -> bytes -> int -> int -> unit (*val allocate_chunk : t -> int64 -> int -> unit*) val copy_chunk : t -> t -> int64 -> int64 -> int -> unit diff --git a/src/utils/lib/url.ml b/src/utils/lib/url.ml index 03ff7e6c..818ab87d 100644 --- a/src/utils/lib/url.ml +++ b/src/utils/lib/url.ml @@ -50,7 +50,7 @@ let encode s = res.[!pos+2] <- hexa_digit (Char.code c mod 16); pos := !pos + 3 done; - String.sub res 0 !pos + Bytes.sub res 0 !pos (** decodes a sting according RFC 1738 or x-www-form-urlencoded ('+' with ' ') @@ -304,4 +304,4 @@ open Options let option = define_option_class "URL" (fun v -> of_string (value_to_string v)) - (fun url -> string_to_value (to_string url)) \ No newline at end of file + (fun url -> string_to_value (to_string url)) diff --git a/src/utils/lib/verificationBitmap.ml b/src/utils/lib/verificationBitmap.ml index fe5c3a40..a8f5d25d 100644 --- a/src/utils/lib/verificationBitmap.ml +++ b/src/utils/lib/verificationBitmap.ml @@ -1,4 +1,4 @@ -type t = string +type t = bytes type part_state = State_missing | State_partial | State_complete | State_verified @@ -15,24 +15,24 @@ let char_to_state = function | '3' -> State_verified | _ -> assert false -let create n c = String.make n (state_to_char c) -let get x i = (char_to_state x.[i]) -let set x i c = x.[i] <- state_to_char c -let length = String.length +let create n c = Bytes.make n (state_to_char c) +let get x i = (char_to_state (Bytes.get x i)) +let set (x : Bytes.t) i c = Bytes.set x i (state_to_char c) +let length = Bytes.length let init n f = - let s = String.create n in + let s = Bytes.create n in for i = 0 to n - 1 do - set s i (f i) + Bytes.set s i (state_to_char (f i)) done; s -let to_string x = x -let of_string x = x +let to_string x = Bytes.to_string x +let of_string x = Bytes.of_string x let iteri f x = - let l = String.length x in + let l = Bytes.length x in let rec aux i = if i < l then begin - f i (char_to_state x.[i]); + f i (char_to_state (Bytes.get x i)); aux (i+1) end in aux 0 @@ -41,20 +41,20 @@ let mapi f x = Array.init (length x) (fun i -> f i (get x i)) let fold_lefti f acc x = - let l = String.length x in + let l = Bytes.length x in let rec aux acc i = if i = l then acc else aux (f acc i (get x i)) (i + 1) in aux acc 0 let existsi p x = - let l = String.length x in + let l = Bytes.length x in let rec aux i = - i < l && (p i (char_to_state x.[i]) || aux (i+1)) in + i < l && (p i (char_to_state (Bytes.get x i)) || aux (i+1)) in aux 0 let for_all p s = - let l = String.length s in + let l = Bytes.length s in let rec aux i = - i >= l || p (char_to_state s.[i]) && aux (i+1) in + i >= l || p (char_to_state (Bytes.get s i)) && aux (i+1) in aux 0 diff --git a/src/utils/lib/verificationBitmap.mli b/src/utils/lib/verificationBitmap.mli index d48f32a3..aed84e67 100644 --- a/src/utils/lib/verificationBitmap.mli +++ b/src/utils/lib/verificationBitmap.mli @@ -2,7 +2,7 @@ type t type part_state = State_missing | State_partial | State_complete | State_verified -val init : int -> (int -> part_state) -> t +val init : int -> (int -> part_state) -> t val create : int -> part_state -> t val get : t -> int -> part_state val set : t -> int -> part_state -> unit From 2f853338985037c32d8a394aa1a2b08fe1567dd1 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 10:48:29 +0200 Subject: [PATCH 20/69] Ported cdk to string immutability. --- src/utils/cdk/bzip2.ml | 22 +++--- src/utils/cdk/bzip2.mli | 6 +- src/utils/cdk/bzlib.ml | 2 +- src/utils/cdk/bzlib.mli | 4 +- src/utils/cdk/file.ml | 4 +- src/utils/cdk/filename2.ml | 27 +++---- src/utils/cdk/gzip.ml | 10 +-- src/utils/cdk/string2.ml | 34 ++++----- src/utils/cdk/tar.mlcpp | 51 +++++++------ src/utils/cdk/tar.mli | 2 +- src/utils/cdk/unix2.ml | 6 +- src/utils/cdk/zlib2.ml | 40 +++++------ src/utils/cdk/zlib2.mli | 6 +- src/utils/extlib/IO.ml | 143 ++++++++++++++++++++++--------------- src/utils/extlib/IO.mli | 82 +++++++++++++-------- 15 files changed, 249 insertions(+), 190 deletions(-) diff --git a/src/utils/cdk/bzip2.ml b/src/utils/cdk/bzip2.ml index 07ca4192..694f82af 100644 --- a/src/utils/cdk/bzip2.ml +++ b/src/utils/cdk/bzip2.ml @@ -7,7 +7,7 @@ let buffer_size = 1024 type in_channel = { in_chan: Pervasives.in_channel; - in_buffer: string; + in_buffer: bytes; mutable in_pos: int; mutable in_avail: int; mutable in_eof: bool; @@ -16,7 +16,7 @@ type in_channel = let open_in_chan ic = { in_chan = ic; - in_buffer = String.create buffer_size; + in_buffer = Bytes.create buffer_size; in_pos = 0; in_avail = 0; in_eof = false; @@ -32,12 +32,12 @@ let open_in filename = let read_byte iz = if iz.in_avail = 0 then begin let n = Pervasives.input iz.in_chan iz.in_buffer 0 - (String.length iz.in_buffer) in + (Bytes.length iz.in_buffer) in if n = 0 then raise End_of_file; iz.in_pos <- 0; iz.in_avail <- n end; - let c = iz.in_buffer.[iz.in_pos] in + let c = Bytes.get iz.in_buffer iz.in_pos in iz.in_pos <- iz.in_pos + 1; iz.in_avail <- iz.in_avail - 1; Char.code c @@ -53,12 +53,12 @@ let read_int32 iz = (Int32.shift_left (Int32.of_int b4) 24))) let rec input iz buf pos len = - if pos < 0 || len < 0 || pos + len > String.length buf then + if pos < 0 || len < 0 || pos + len > Bytes.length buf then invalid_arg "Bzip2.input"; if iz.in_eof then 0 else begin if iz.in_avail = 0 then begin let n = Pervasives.input iz.in_chan iz.in_buffer 0 - (String.length iz.in_buffer) in + (Bytes.length iz.in_buffer) in if n = 0 then raise(Error("truncated file")); iz.in_pos <- 0; iz.in_avail <- n @@ -91,7 +91,7 @@ let rec really_input iz buf pos len = let char_buffer = String.create 1 let input_char iz = - if input iz char_buffer 0 1 = 0 then raise End_of_file else char_buffer.[0] + if input iz char_buffer 0 1 = 0 then raise End_of_file else Bytes.get char_buffer 0 let input_byte iz = Char.code (input_char iz) @@ -106,7 +106,7 @@ let close_in iz = type out_channel = { out_chan: Pervasives.out_channel; - out_buffer: string; + out_buffer: bytes; mutable out_pos: int; mutable out_avail: int; out_stream: Bzlib.stream; @@ -125,14 +125,14 @@ let open_out ?(level = 6) filename = open_out_chan ~level (Pervasives.open_out_bin filename) let rec output oz buf pos len = - if pos < 0 || len < 0 || pos + len > String.length buf then + if pos < 0 || len < 0 || pos + len > Bytes.length buf then invalid_arg "Bzlib2.output"; (* If output buffer is full, flush it *) if oz.out_avail = 0 then begin (* Printf.printf "Flushing out_avail\n"; *) Pervasives.output oz.out_chan oz.out_buffer 0 oz.out_pos; oz.out_pos <- 0; - oz.out_avail <- String.length oz.out_buffer + oz.out_avail <- Bytes.length oz.out_buffer end; let (_, used_in, used_out) = try @@ -159,7 +159,7 @@ let flush oz = if oz.out_avail = 0 then begin Pervasives.output oz.out_chan oz.out_buffer 0 oz.out_pos; oz.out_pos <- 0; - oz.out_avail <- String.length oz.out_buffer + oz.out_avail <- Bytes.length oz.out_buffer end; let (finished, _, used_out) = Bzlib.compress oz.out_stream oz.out_buffer 0 0 diff --git a/src/utils/cdk/bzip2.mli b/src/utils/cdk/bzip2.mli index 40ddf405..04287079 100644 --- a/src/utils/cdk/bzip2.mli +++ b/src/utils/cdk/bzip2.mli @@ -22,7 +22,7 @@ val input_byte: in_channel -> int (* Same as [Bzip2.input_char], but return the 8-bit integer representing the character. Raise [End_of_file] if no more compressed data is available. *) -val input: in_channel -> string -> int -> int -> int +val input: in_channel -> bytes -> int -> int -> int (* [input ic buf pos len] uncompresses up to [len] characters from the given channel [ic], storing them in string [buf], starting at character number [pos]. @@ -38,7 +38,7 @@ val input: in_channel -> string -> int -> int -> int exactly [len] characters.) Exception [Invalid_argument "Bzip2.input"] is raised if [pos] and [len] do not designate a valid substring of [buf]. *) -val really_input: in_channel -> string -> int -> int -> unit +val really_input: in_channel -> bytes -> int -> int -> unit (* [really_input ic buf pos len] uncompresses [len] characters from the given channel, storing them in string [buf], starting at character number [pos]. @@ -82,7 +82,7 @@ val output_char: out_channel -> char -> unit val output_byte: out_channel -> int -> unit (* Same as [Bzip2.output_char], but the output character is given by its code. The given integer is taken modulo 256. *) -val output: out_channel -> string -> int -> int -> unit +val output: out_channel -> bytes -> int -> int -> unit (* [output oc buf pos len] compresses and writes [len] characters from string [buf], starting at offset [pos], and writes the compressed data to the channel [oc]. diff --git a/src/utils/cdk/bzlib.ml b/src/utils/cdk/bzlib.ml index ff17e9ec..37800080 100644 --- a/src/utils/cdk/bzlib.ml +++ b/src/utils/cdk/bzlib.ml @@ -23,7 +23,7 @@ type action = BZ_RUN | BZ_FLUSH | BZ_FINISH external compress_init: int -> int -> int -> stream = "camlzip_bzCompressInit" external compress: - stream -> string -> int -> int -> string -> int -> int -> action + stream -> bytes -> int -> int -> bytes -> int -> int -> action -> bool * int * int = "camlzip_bzCompress_bytecode" "camlzip_bzCompress" external compress_end: stream -> unit = "camlzip_bzCompressEnd" diff --git a/src/utils/cdk/bzlib.mli b/src/utils/cdk/bzlib.mli index 74f6d09f..a5dbdb9c 100644 --- a/src/utils/cdk/bzlib.mli +++ b/src/utils/cdk/bzlib.mli @@ -10,7 +10,7 @@ type action = BZ_RUN | BZ_FLUSH | BZ_FINISH external compress_init: int -> int -> int -> stream = "camlzip_bzCompressInit" external compress: - stream -> string -> int -> int -> string -> int -> int -> action + stream -> bytes -> int -> int -> bytes -> int -> int -> action -> bool * int * int = "camlzip_bzCompress_bytecode" "camlzip_bzCompress" external compress_end: stream -> unit = "camlzip_bzCompressEnd" @@ -18,7 +18,7 @@ external compress_end: stream -> unit = "camlzip_bzCompressEnd" external decompress_init: int -> bool -> stream = "camlzip_bzDecompressInit" external decompress: - stream -> string -> int -> int -> string -> int -> int -> bool * int * int + stream -> bytes -> int -> int -> bytes -> int -> int -> bool * int * int = "camlzip_bzDecompress_bytecode" "camlzip_bzDecompress" external decompress_end: stream -> unit = "camlzip_bzDecompressEnd" diff --git a/src/utils/cdk/file.ml b/src/utils/cdk/file.ml index c25e50d1..c0105e0f 100644 --- a/src/utils/cdk/file.ml +++ b/src/utils/cdk/file.ml @@ -23,11 +23,11 @@ let to_string name = let buf_size = 1024 in let buf = String.create buf_size in let rec iter buf nb_read = - let buf_size = String.length buf in + let buf_size = Bytes.length buf in let to_read = min (buf_size - nb_read) 8192 in let tmp = input chan buf nb_read to_read in if tmp = 0 then - String.sub buf 0 nb_read + Bytes.sub buf 0 nb_read else let nb_read = nb_read + tmp in let buf = diff --git a/src/utils/cdk/filename2.ml b/src/utils/cdk/filename2.ml index 38032f2f..a0c67057 100644 --- a/src/utils/cdk/filename2.ml +++ b/src/utils/cdk/filename2.ml @@ -116,16 +116,17 @@ let to_string filename = List.fold_left (fun file f -> f file) filename !to_strings let path_of_filename filename = - let filename = String.copy filename in - let len = String.length filename in + let filename = Bytes.of_string filename in + let len = Bytes.length filename in for i = 0 to len - 1 do - if filename.[i] = '\\' then filename.[i] <- '/'; + if Bytes.get filename i = '\\' then Bytes.set filename i '/' done; - let filename = - if len > 2 && filename.[1] = ':' && - match filename.[0] with - 'a' .. 'z' | 'A' .. 'Z' -> true - | _ -> false then + let filename = Bytes.to_string filename in + let filename = + if len > 2 && filename.[1] = ':' && + (match filename.[0] with + | 'a' .. 'z' | 'A' .. 'Z' -> true + | _ -> false) then Printf.sprintf "%s/%s" (String.sub filename 0 2) (String.sub filename 2 (len-2)) else filename @@ -142,11 +143,11 @@ let filesystem_compliant name fstype namemax = (* replace all illegal characters with a valid one. assumes all filesystems accept '_'s in filenames *) let escape_chars p filename = - let s = String.copy filename in - for i = 0 to String.length filename - 1 do - if p s.[i] then s.[i] <- '_' - done; - s in + let s = Bytes.of_string filename in + for i = 0 to Bytes.length s - 1 do + if p (Bytes.get s i) then Bytes.set s i '_' + done; + Bytes.to_string s in (* remove all illegal characters at the beginning of filename *) let trim_left p filename = diff --git a/src/utils/cdk/gzip.ml b/src/utils/cdk/gzip.ml index d170263b..bd9e4fc7 100644 --- a/src/utils/cdk/gzip.ml +++ b/src/utils/cdk/gzip.ml @@ -28,7 +28,7 @@ type in_channel = in_stream: Zlib.stream; mutable in_size: int32; mutable in_crc: int32; - char_buffer: string } + char_buffer: bytes } let open_in ic = (* Superficial parsing of header *) @@ -73,7 +73,7 @@ let open_in ic = in_stream = Zlib.inflate_init false; in_size = Int32.zero; in_crc = Int32.zero; - char_buffer = String.create 1 } + char_buffer = Bytes.create 1 } let open_in_file filename = let ic = Pervasives.open_in_bin filename in @@ -153,9 +153,9 @@ let rec really_input iz buf pos len = end let input_char iz = - if input iz iz.char_buffer 0 1 = 0 + if input iz (Bytes.of_string iz.char_buffer) 0 1 = 0 then raise End_of_file - else Bytes.get iz.char_buffer 0 + else Bytes.get (Bytes.of_string iz.char_buffer) 0 let input_byte iz = Char.code (input_char iz) @@ -195,7 +195,7 @@ let open_out ?(level = 6) oc = out_stream = Zlib.deflate_init level false; out_size = Int32.zero; out_crc = Int32.zero; - char_buffer = String.create 1 } + char_buffer = Bytes.create 1 } let open_out_file ?level filename = let oc = Pervasives.open_out_bin filename in diff --git a/src/utils/cdk/string2.ml b/src/utils/cdk/string2.ml index 1e0e0ed3..efed116f 100644 --- a/src/utils/cdk/string2.ml +++ b/src/utils/cdk/string2.ml @@ -164,8 +164,8 @@ let check_suffix s suffix = let upp_initial s = if String.length s > 0 then - let s = String.copy s in - s.[0] <- Char.uppercase s.[0]; s + let first_char = Char.uppercase_ascii s.[0] in + String.make 1 first_char ^ String.sub s 1 (String.length s - 1) else s @@ -198,11 +198,12 @@ let of_char c = String.make 1 c let resize s newlen = let len = String.length s in - if len > newlen then String.sub s 0 newlen + if len > newlen then + String.sub s 0 newlen else - let str = String.create newlen in - String.blit s 0 str 0 len; - str + let str = Bytes.create newlen in + Bytes.blit_string s 0 str 0 len; + Bytes.to_string str let init len f = let s = String.create len in @@ -267,19 +268,20 @@ let starts_with s1 s2 = len2 <= len1 && strneql s1 s2 len2 let replace_char s c1 c2 = - for i = 0 to String.length s - 1 do - if s.[i] == c1 then s.[i] <- c2 - done + let rep c = if c == c1 then c2 else c in + String.map rep s; + () let stem s = - let s = String.lowercase (String.copy s) in - for i = 0 to String.length s - 1 do - let c = s.[i] in + let s = String.lowercase_ascii s in + let result = Bytes.of_string s in + for i = 0 to Bytes.length result - 1 do + let c = Bytes.get result i in match c with - 'a'..'z' | '0' .. '9' -> () - | _ -> s.[i] <- ' '; + | 'a'..'z' | '0'..'9' -> () + | _ -> Bytes.set result i ' ' done; - split_simplify s ' ' + split_simplify (Bytes.to_string result) ' ' let map f s = let len = String.length s in @@ -302,7 +304,7 @@ let init n f = for i = 0 to n - 1 do s.[i] <- f i done; - s + Bytes.to_string s let exists p s = let l = String.length s in diff --git a/src/utils/cdk/tar.mlcpp b/src/utils/cdk/tar.mlcpp index 2c2f2b6a..f39ba538 100644 --- a/src/utils/cdk/tar.mlcpp +++ b/src/utils/cdk/tar.mlcpp @@ -146,6 +146,9 @@ let extract_int32 raw pos len = Int32.of_string ("0o" ^ trim_spaces raw pos len) with Failure x -> raise (Error "Invalid number in header") +let extract_int32_bytes raw pos len = + extract_int32 (Bytes.unsafe_to_string raw) pos len + let typeflag = function | '0' | '\000' -> REGULAR | '1' -> LINK @@ -178,14 +181,15 @@ let align_at_header t = t.last_header <- None let empty_block = String.make blocksize '\000' +let empty_bytes = Bytes.create blocksize let compute_chksum buf = let chksum = ref 256 in (* 256 is the sum of 8 ' ' characters for the chksum field *) for i = 0 to 147 do - chksum := !chksum + Char.code buf.[i] + chksum := !chksum + Char.code (Bytes.get buf i) done; for i = 156 to 511 do - chksum := !chksum + Char.code buf.[i] + chksum := !chksum + Char.code (Bytes.get buf i) done; !chksum @@ -208,32 +212,33 @@ let read_oldgnu_header header = let read_gnu_header t = let buf = String.create blocksize in t.chan#really_input buf 0 blocksize; - { t_atime = extract_int32 buf 0 12; - t_ctime = extract_int32 buf 12 12; - t_offset = extract_int32 buf 24 12; - t_realsize = extract_int32 buf 36 12; + { t_atime = extract_int32_bytes buf 0 12; + t_ctime = extract_int32_bytes buf 12 12; + t_offset = extract_int32_bytes buf 24 12; + t_realsize = extract_int32_bytes buf 36 12; } let read_header t = align_at_header t; let buf = String.create blocksize in t.chan#really_input buf 0 blocksize; - if buf = empty_block then raise End_of_file; - let head1 = { t_name = c_string buf 0; - t_mode = extract_num buf 100 8; - t_uid = extract_num buf 108 8; - t_gid = extract_num buf 116 8; - t_size = extract_num buf 124 12; - t_mtime = extract_int32 buf 136 12; - t_chksum = extract_num buf 148 8; - t_typeflag = typeflag buf.[156]; - t_linkname = c_string buf 157; - t_format = read_magic buf buf.[156]; - t_uname = c_string buf 265; - t_gname = c_string buf 297; - t_devmajor = extract_num buf 329 8; - t_devminor = extract_num buf 337 8; - t_prefix = String.sub buf 345 155; + if buf = empty_bytes then raise End_of_file; + let sbuf = Bytes.to_string buf in + let head1 = { t_name = c_string sbuf 0; + t_mode = extract_num sbuf 100 8; + t_uid = extract_num sbuf 108 8; + t_gid = extract_num sbuf 116 8; + t_size = extract_num sbuf 124 12; + t_mtime = extract_int32 sbuf 136 12; + t_chksum = extract_num sbuf 148 8; + t_typeflag = typeflag sbuf.[156]; + t_linkname = c_string sbuf 157; + t_format = read_magic sbuf sbuf.[156]; + t_uname = c_string sbuf 265; + t_gname = c_string sbuf 297; + t_devmajor = extract_num sbuf 329 8; + t_devminor = extract_num sbuf 337 8; + t_prefix = String.sub sbuf 345 155; t_gnu = None; } in let chksum = compute_chksum buf in @@ -241,7 +246,7 @@ let read_header t = raise (Error (Printf.sprintf "Invalid checksum in tar header. Calculated %d, expected %d" chksum head1.t_chksum)); let head = if head1.t_format = OLDGNU_FORMAT then - {head1 with t_gnu = Some (read_oldgnu_header buf) } + {head1 with t_gnu = Some (read_oldgnu_header sbuf) } else if head1.t_format = GNU_FORMAT then {head1 with t_gnu = Some (read_gnu_header t) } else diff --git a/src/utils/cdk/tar.mli b/src/utils/cdk/tar.mli index 0d4e2a13..1c1d3f4e 100644 --- a/src/utils/cdk/tar.mli +++ b/src/utils/cdk/tar.mli @@ -95,7 +95,7 @@ val open_out_chan: ?compress:[<`Plain|`Gzip|`Bzip2>`Plain] -> out_channel -> t_o body. [header.t_size] is set based on the length of the string that's used as the file. [header.t_chksum] is also filled in automatically. *) -val output: t_out -> header -> string -> unit +val output: t_out -> header -> bytes -> unit (** Flush out the tar archive but don't close the underlying [out_channel] *) diff --git a/src/utils/cdk/unix2.ml b/src/utils/cdk/unix2.ml index b3f56b22..60fc85a5 100644 --- a/src/utils/cdk/unix2.ml +++ b/src/utils/cdk/unix2.ml @@ -205,18 +205,18 @@ let rec remove_all_directory dirname = Unix.rmdir dirname let random () = - let s = String.create 7 in + let s = Bytes.create 7 in for i = 0 to 6 do s.[i] <- char_of_int (97 + Random.int 26) done; - s + (Bytes.to_string s) let can_write_to_directory dirname = let temp_file = Filename.concat dirname "tmp_" ^ random () ^ "_mld.tmp" in let check () = with_remove temp_file (fun _ -> tryopen_openfile temp_file [O_WRONLY; O_CREAT] 0o600 (fun fd -> let test_string = "mldonkey accesstest - this file can be deleted\n" in - really_write fd test_string 0 (String.length test_string))) + really_write fd (Bytes.of_string test_string) 0 (String.length test_string))) in try check () diff --git a/src/utils/cdk/zlib2.ml b/src/utils/cdk/zlib2.ml index d2d25abf..4813ba26 100644 --- a/src/utils/cdk/zlib2.ml +++ b/src/utils/cdk/zlib2.ml @@ -10,15 +10,15 @@ let zlib_version_num () = end let grow_buffer s = - let s' = String.create (2 * String.length s) in - String.blit s 0 s' 0 (String.length s); + let s' = String.create (2 * Bytes.length s) in + Bytes.blit s 0 s' 0 (Bytes.length s); s' let compress_string ?(level = 6) inbuf = let zs = deflate_init level true in let rec compr inpos outbuf outpos = - let inavail = String.length inbuf - inpos in - let outavail = String.length outbuf - outpos in + let inavail = Bytes.length inbuf - inpos in + let outavail = Bytes.length outbuf - outpos in if outavail = 0 then compr inpos (grow_buffer outbuf) outpos else begin @@ -26,23 +26,23 @@ let compress_string ?(level = 6) inbuf = deflate zs inbuf inpos inavail outbuf outpos outavail (if inavail = 0 then Z_FINISH else Z_NO_FLUSH) in if finished then - String.sub outbuf 0 (outpos + used_out) + Bytes.sub outbuf 0 (outpos + used_out) else compr (inpos + used_in) outbuf (outpos + used_out) end in - let res = compr 0 (String.create (String.length inbuf)) 0 in + let res = compr 0 (String.create (Bytes.length inbuf)) 0 in deflate_end zs; res (* header info from camlzip/gpl *) let gzip_string ?(level = 6) inbuf = - if String.length inbuf <= 0 then "" else + if Bytes.length inbuf <= 0 then "" else begin let zs = deflate_init level false in let out_crc = ref Int32.zero in let rec compr inpos outbuf outpos = - let inavail = String.length inbuf - inpos in - let outavail = String.length outbuf - outpos in + let inavail = Bytes.length inbuf - inpos in + let outavail = Bytes.length outbuf - outpos in if outavail = 0 then compr inpos (grow_buffer outbuf) outpos else begin @@ -51,13 +51,13 @@ let gzip_string ?(level = 6) inbuf = (if inavail = 0 then Z_FINISH else Z_NO_FLUSH) in out_crc := update_crc !out_crc inbuf inpos used_in; if finished then - String.sub outbuf 0 (outpos + used_out) + Bytes.sub outbuf 0 (outpos + used_out) else compr (inpos + used_in) outbuf (outpos + used_out) end in - let res = compr 0 (String.create (String.length inbuf)) 0 in + let res = compr 0 (String.create (Bytes.length inbuf)) 0 in deflate_end zs; - let buf = Buffer.create (18 + String.length res) in + let buf = Buffer.create (18 + Bytes.length res) in let write_int wbuf n = Buffer.add_char wbuf (char_of_int n) in @@ -75,28 +75,28 @@ let gzip_string ?(level = 6) inbuf = for i = 1 to 4 do write_int buf 0 done; write_int buf 0; write_int buf 0xFF; - Buffer.add_string buf res; + Buffer.add_bytes buf res; write_int32 buf !out_crc; - write_int32 buf (Int32.of_int (String.length inbuf)); + write_int32 buf (Int32.of_int (Bytes.length inbuf)); Buffer.contents buf end let uncompress_string2 inbuf = let zs = inflate_init true in let rec uncompr inpos outbuf outpos = - let inavail = String.length inbuf - inpos in - let outavail = String.length outbuf - outpos in + let inavail = Bytes.length inbuf - inpos in + let outavail = Bytes.length outbuf - outpos in if outavail = 0 then uncompr inpos (grow_buffer outbuf) outpos else begin let (finished, used_in, used_out) = inflate zs inbuf inpos inavail outbuf outpos outavail Z_SYNC_FLUSH in if finished then - String.sub outbuf 0 (outpos + used_out) + Bytes.sub outbuf 0 (outpos + used_out) else uncompr (inpos + used_in) outbuf (outpos + used_out) end in - let res = uncompr 0 (String.create (2 * String.length inbuf)) 0 in + let res = uncompr 0 (String.create (2 * Bytes.length inbuf)) 0 in inflate_end zs; res @@ -105,12 +105,12 @@ let uncompress_string s = let pos = ref 0 in let len = String.length s in uncompress ~header: true (fun b -> - let n = min (String.length b) (len - !pos) in + let n = min (Bytes.length b) (len - !pos) in if n < 1 then 0 else begin String.blit s !pos b 0 n; pos := !pos + n; n end - ) (fun s len -> Buffer.add_string buf (String.sub s 0 len)); + ) (fun s len -> Buffer.add_bytes buf (Bytes.sub s 0 len)); Buffer.contents buf diff --git a/src/utils/cdk/zlib2.mli b/src/utils/cdk/zlib2.mli index 6e27f954..5f985937 100644 --- a/src/utils/cdk/zlib2.mli +++ b/src/utils/cdk/zlib2.mli @@ -1,7 +1,7 @@ val uncompress_string : string -> string -val uncompress_string2 : string -> string -val compress_string : ?level:int -> string -> string -val gzip_string : ?level:int -> string -> string +val uncompress_string2 : bytes -> bytes +val compress_string : ?level:int -> bytes -> bytes +val gzip_string : ?level:int -> bytes -> string val zlib_version_num : unit -> string diff --git a/src/utils/extlib/IO.ml b/src/utils/extlib/IO.ml index e77f3809..bcbe288b 100644 --- a/src/utils/extlib/IO.ml +++ b/src/utils/extlib/IO.ml @@ -20,13 +20,13 @@ type input = { mutable in_read : unit -> char; - mutable in_input : string -> int -> int -> int; + mutable in_input : Bytes.t -> int -> int -> int; mutable in_close : unit -> unit; } type 'a output = { mutable out_write : char -> unit; - mutable out_output : string -> int -> int -> int; + mutable out_output : Bytes.t -> int -> int -> int; mutable out_close : unit -> 'a; mutable out_flush : unit -> unit; } @@ -59,10 +59,9 @@ let read i = i.in_read() let nread i n = if n < 0 then invalid_arg "IO.nread"; - if n = 0 then - "" + if n = 0 then Bytes.empty else - let s = String.create n in + let s = Bytes.create n in let l = ref n in let p = ref 0 in try @@ -76,14 +75,19 @@ let nread i n = with No_more_input as e -> if !p = 0 then raise e; - String.sub s 0 !p + Bytes.sub s 0 !p + +let nread_string i n = + (* [nread] transfers ownership of the returned string, so + [unsafe_to_string] is safe here *) + Bytes.unsafe_to_string (nread i n) let really_output o s p l' = - let sl = String.length s in + let sl = Bytes.length s in if p + l' > sl || p < 0 || l' < 0 then invalid_arg "IO.really_output"; let l = ref l' in let p = ref p in - while !l > 0 do + while !l > 0 do let w = o.out_output s !p !l in if w = 0 then raise Sys_blocked_io; p := !p + w; @@ -92,7 +96,7 @@ let really_output o s p l' = l' let input i s p l = - let sl = String.length s in + let sl = Bytes.length s in if p + l > sl || p < 0 || l < 0 then invalid_arg "IO.input"; if l = 0 then 0 @@ -100,7 +104,7 @@ let input i s p l = i.in_input s p l let really_input i s p l' = - let sl = String.length s in + let sl = Bytes.length s in if p + l' > sl || p < 0 || l' < 0 then invalid_arg "IO.really_input"; let l = ref l' in let p = ref p in @@ -114,12 +118,16 @@ let really_input i s p l' = let really_nread i n = if n < 0 then invalid_arg "IO.really_nread"; - if n = 0 then "" + if n = 0 then Bytes.empty else - let s = String.create n + let s = Bytes.create n in ignore(really_input i s 0 n); s +let really_nread_string i n = + (* [really_nread] transfers ownership of the returned string, + so [unsafe_to_string] is safe here *) + Bytes.unsafe_to_string (really_nread i n) let close_in i = let f _ = raise Input_closed in @@ -132,7 +140,7 @@ let write o x = o.out_write x let nwrite o s = let p = ref 0 in - let l = ref (String.length s) in + let l = ref (Bytes.length s) in while !l > 0 do let w = o.out_output s !p !l in if w = 0 then raise Sys_blocked_io; @@ -140,13 +148,18 @@ let nwrite o s = l := !l - w; done +let nwrite_string o s = + (* [nwrite] does not mutate or capture its [bytes] input, + so using [Bytes.unsafe_of_string] is safe here *) + nwrite o (Bytes.unsafe_of_string s) + let output o s p l = - let sl = String.length s in + let sl = Bytes.length s in if p + l > sl || p < 0 || l < 0 then invalid_arg "IO.output"; o.out_output s p l let printf o fmt = - Printf.kprintf (fun s -> nwrite o s) fmt + Printf.kprintf (fun s -> nwrite_string o s) fmt let flush o = o.out_flush() @@ -166,18 +179,19 @@ let read_all i = let rec loop() = let s = nread i maxlen in str := (s,!pos) :: !str; - pos := !pos + String.length s; + pos := !pos + Bytes.length s; loop() in try loop() with No_more_input -> - let buf = String.create !pos in + let buf = Bytes.create !pos in List.iter (fun (s,p) -> - String.unsafe_blit s 0 buf p (String.length s) + Bytes.blit s 0 buf p (Bytes.length s) ) !str; - buf + (* 'buf' doesn't escape, it won't be mutated again *) + Bytes.unsafe_to_string buf let pos_in i = let p = ref 0 in @@ -214,39 +228,42 @@ let pos_out o = (* -------------------------------------------------------------- *) (* Standard IO *) -let input_string s = +let input_bytes s = let pos = ref 0 in - let len = String.length s in + let len = Bytes.length s in { in_read = (fun () -> if !pos >= len then raise No_more_input; - let c = String.unsafe_get s !pos in + let c = Bytes.unsafe_get s !pos in incr pos; c ); in_input = (fun sout p l -> if !pos >= len then raise No_more_input; let n = (if !pos + l > len then len - !pos else l) in - String.unsafe_blit s !pos sout p n; + Bytes.unsafe_blit s !pos sout p n; pos := !pos + n; n ); in_close = (fun () -> ()); } -let output_string() = - let b = Buffer.create 0 in - { - out_write = (fun c -> - Buffer.add_char b c - ); - out_output = (fun s p l -> - Buffer.add_substring b s p l; - l - ); - out_close = (fun () -> Buffer.contents b); - out_flush = (fun () -> ()); - } +let input_string s = + (* Bytes.unsafe_of_string is safe here as input_bytes does not + mutate the byte sequence *) + input_bytes (Bytes.unsafe_of_string s) + +let output_buffer close = + let b = Buffer.create 0 in + { + out_write = (fun c -> Buffer.add_char b c); + out_output = (fun s p l -> Buffer.add_subbytes b s p l; l); + out_close = (fun () -> close b); + out_flush = (fun () -> ()); + } + +let output_string () = output_buffer Buffer.contents +let output_bytes () = output_buffer Buffer.to_bytes let input_channel ch = { @@ -291,7 +308,7 @@ let input_enum e = match Enum.get e with | None -> l | Some c -> - String.unsafe_set s p c; + Bytes.unsafe_set s p c; loop (p + 1) (l - 1) in let k = loop p l in @@ -308,7 +325,7 @@ let output_enum() = Buffer.add_char b x ); out_output = (fun s p l -> - Buffer.add_substring b s p l; + Buffer.add_subbytes b s p l; l ); out_close = (fun () -> @@ -346,7 +363,7 @@ let pipe() = Buffer.add_char output c in let output s p l = - Buffer.add_substring output s p l; + Buffer.add_subbytes output s p l; l in let input = { @@ -378,17 +395,25 @@ let read_signed_byte i = else c +let read_string_into_buffer i = + let b = Buffer.create 8 in + let rec loop() = + let c = i.in_read() in + if c <> '\000' then begin + Buffer.add_char b c; + loop(); + end; + in + loop(); + b + let read_string i = - let b = Buffer.create 8 in - let rec loop() = - let c = i.in_read() in - if c <> '\000' then begin - Buffer.add_char b c; - loop(); - end; - in - loop(); - Buffer.contents b + Buffer.contents + (read_string_into_buffer i) + +let read_bytes i = + Buffer.to_bytes + (read_string_into_buffer i) let read_line i = let b = Buffer.create 8 in @@ -474,11 +499,15 @@ let write_byte o n = write o (Char.unsafe_chr (n land 0xFF)) let write_string o s = + nwrite_string o s; + write o '\000' + +let write_bytes o s = nwrite o s; write o '\000' let write_line o s = - nwrite o s; + nwrite_string o s; write o '\n' let write_ui16 ch n = @@ -646,7 +675,7 @@ let rec read_bits b n = b.bits <- k; b.nbits <- c; d - end else begin + end else begin b.bits <- (b.bits lsl 8) lor k; b.nbits <- b.nbits + 8; read_bits b n; @@ -708,11 +737,11 @@ class out_chars ch = end let from_in_channel ch = - let cbuf = String.create 1 in + let cbuf = Bytes.create 1 in let read() = try if ch#input cbuf 0 1 = 0 then raise Sys_blocked_io; - String.unsafe_get cbuf 0 + Bytes.unsafe_get cbuf 0 with End_of_file -> raise No_more_input in @@ -725,9 +754,9 @@ let from_in_channel ch = ~close:ch#close_in let from_out_channel ch = - let cbuf = String.create 1 in + let cbuf = Bytes.create 1 in let write c = - String.unsafe_set cbuf 0 c; + Bytes.unsafe_set cbuf 0 c; if ch#output cbuf 0 1 = 0 then raise Sys_blocked_io; in let output s p l = @@ -744,7 +773,7 @@ let from_in_chars ch = let i = ref 0 in try while !i < l do - String.unsafe_set s (p + !i) (ch#get()); + Bytes.unsafe_set s (p + !i) (ch#get()); incr i done; l @@ -760,7 +789,7 @@ let from_in_chars ch = let from_out_chars ch = let output s p l = for i = p to p + l - 1 do - ch#put (String.unsafe_get s i) + ch#put (Bytes.unsafe_get s i) done; l in diff --git a/src/utils/extlib/IO.mli b/src/utils/extlib/IO.mli index 5f205de9..c288ed03 100644 --- a/src/utils/extlib/IO.mli +++ b/src/utils/extlib/IO.mli @@ -1,4 +1,4 @@ -(* +(* * IO - Abstract input/output * Copyright (C) 2003 Nicolas Cannasse * @@ -49,29 +49,35 @@ val read : input -> char (** Read a single char from an input or raise [No_more_input] if no input available. *) -val nread : input -> int -> string -(** [nread i n] reads a string of size up to [n] from an input. +val nread : input -> int -> Bytes.t +(** [nread i n] reads a byte sequence of size up to [n] from an input. The function will raise [No_more_input] if no input is available. It will raise [Invalid_argument] if [n] < 0. *) -val really_nread : input -> int -> string -(** [really_nread i n] reads a string of exactly [n] characters +val really_nread : input -> int -> Bytes.t +(** [really_nread i n] reads a byte sequence of exactly [n] characters from the input. Raises [No_more_input] if at least [n] characters are not available. Raises [Invalid_argument] if [n] < 0. *) -val input : input -> string -> int -> int -> int +val nread_string : input -> int -> string +(** as [nread], but reads a string. *) + +val really_nread_string : input -> int -> string +(** as [really_nread], but reads a string. *) + +val input : input -> Bytes.t -> int -> int -> int (** [input i s p l] reads up to [l] characters from the given input, storing - them in string [s], starting at character number [p]. It returns the actual + them in buffer [b], starting at character number [p]. It returns the actual number of characters read or raise [No_more_input] if no character can be read. It will raise [Invalid_argument] if [p] and [l] do not designate a - valid substring of [s]. *) + valid sequence of [b]. *) -val really_input : input -> string -> int -> int -> int -(** [really_input i s p l] reads exactly [l] characters from the given input, - storing them in the string [s], starting at position [p]. For consistency with +val really_input : input -> Bytes.t -> int -> int -> int +(** [really_input i b p l] reads exactly [l] characters from the given input, + storing them in the buffer [b], starting at position [p]. For consistency with {!IO.input} it returns [l]. Raises [No_more_input] if at [l] characters are not available. Raises [Invalid_argument] if [p] and [l] do not designate a - valid substring of [s]. *) + valid subsequence of [b]. *) val close_in : input -> unit (** Close the input. It can no longer be read from. *) @@ -79,19 +85,22 @@ val close_in : input -> unit val write : 'a output -> char -> unit (** Write a single char to an output. *) -val nwrite : 'a output -> string -> unit +val nwrite : 'a output -> Bytes.t -> unit +(** Write a byte sequence to an output. *) + +val nwrite_string : 'a output -> string -> unit (** Write a string to an output. *) -val output : 'a output -> string -> int -> int -> int -(** [output o s p l] writes up to [l] characters from string [s], starting at +val output : 'a output -> Bytes.t -> int -> int -> int +(** [output o b p l] writes up to [l] characters from byte sequence [b], starting at offset [p]. It returns the number of characters written. It will raise - [Invalid_argument] if [p] and [l] do not designate a valid substring of [s]. *) + [Invalid_argument] if [p] and [l] do not designate a valid subsequence of [b]. *) -val really_output : 'a output -> string -> int -> int -> int -(** [really_output o s p l] writes exactly [l] characters from string [s] onto +val really_output : 'a output -> Bytes.t -> int -> int -> int +(** [really_output o b p l] writes exactly [l] characters from byte sequence [b] onto the the output, starting with the character at offset [p]. For consistency with {!IO.output} it returns [l]. Raises [Invalid_argument] if [p] and [l] do not - designate a valid substring of [s]. *) + designate a valid subsequence of [b]. *) val flush : 'a output -> unit (** Flush an output. *) @@ -105,33 +114,40 @@ val close_out : 'a output -> 'a val input_string : string -> input (** Create an input that will read from a string. *) +val input_bytes : Bytes.t -> input +(** Create an input that will read from a byte sequence. *) + val output_string : unit -> string output (** Create an output that will write into a string in an efficient way. When closed, the output returns all the data written into it. *) +val output_bytes : unit -> Bytes.t output +(** Create an output that will write into a byte sequence in an efficient way. + When closed, the output returns all the data written into it. *) + val input_channel : in_channel -> input (** Create an input that will read from a channel. *) val output_channel : out_channel -> unit output -(** Create an output that will write into a channel. *) +(** Create an output that will write into a channel. *) (* val input_enum : char Enum.t -> input (** Create an input that will read from an [enum]. *) val output_enum : unit -> char Enum.t output -(** Create an output that will write into an [enum]. The +(** Create an output that will write into an [enum]. The final enum is returned when the output is closed. *) *) val create_in : read:(unit -> char) -> - input:(string -> int -> int -> int) -> close:(unit -> unit) -> input + input:(Bytes.t -> int -> int -> int) -> close:(unit -> unit) -> input (** Fully create an input by giving all the needed functions. *) val create_out : write:(char -> unit) -> - output:(string -> int -> int -> int) -> + output:(Bytes.t -> int -> int -> int) -> flush:(unit -> unit) -> close:(unit -> 'a) -> 'a output (** Fully create an output by giving all the needed functions. *) @@ -148,15 +164,15 @@ val pipe : unit -> input * unit output the output can be read from the input. *) val pos_in : input -> input * (unit -> int) -(** Create an input that provide a count function of the number of bytes +(** Create an input that provide a count function of the number of Bytes.t read from it. *) val pos_out : 'a output -> 'a output * (unit -> int) -(** Create an output that provide a count function of the number of bytes +(** Create an output that provide a count function of the number of Bytes.t written through it. *) external cast_output : 'a output -> unit output = "%identity" -(** You can safely transform any output to an unit output in a safe way +(** You can safely transform any output to an unit output in a safe way by using this function. *) (** {6 Binary files API} @@ -198,6 +214,9 @@ val read_double : input -> float val read_string : input -> string (** Read a null-terminated string. *) +val read_bytes : input -> Bytes.t +(** Read a null-terminated byte sequence. *) + val read_line : input -> string (** Read a LF or CRLF terminated string. *) @@ -211,7 +230,7 @@ val write_i16 : 'a output -> int -> unit (** Write a signed 16-bit word. *) val write_i32 : 'a output -> int -> unit -(** Write a signed 32-bit integer. *) +(** Write a signed 32-bit integer. *) val write_real_i32 : 'a output -> int32 -> unit (** Write an OCaml int32. *) @@ -225,6 +244,9 @@ val write_double : 'a output -> float -> unit val write_string : 'a output -> string -> unit (** Write a string and append an null character. *) +val write_bytes : 'a output -> Bytes.t -> unit +(** Write a byte sequence and append an null character. *) + val write_line : 'a output -> string -> unit (** Write a line and append a LF (it might be converted to CRLF on some systems depending on the underlying IO). *) @@ -239,7 +261,7 @@ sig val read_real_i32 : input -> int32 val read_i64 : input -> int64 val read_double : input -> float - + val write_ui16 : 'a output -> int -> unit val write_i16 : 'a output -> int -> unit val write_i32 : 'a output -> int -> unit @@ -293,13 +315,13 @@ val drop_bits : in_bits -> unit class in_channel : input -> object - method input : string -> int -> int -> int + method input : Bytes.t -> int -> int -> int method close_in : unit -> unit end class out_channel : 'a output -> object - method output : string -> int -> int -> int + method output : Bytes.t -> int -> int -> int method flush : unit -> unit method close_out : unit -> unit end From d39b60b5e84a2366997cbb019128fb6e0a184208 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 11:07:45 +0200 Subject: [PATCH 21/69] Ported gnutella to string immutability. --- src/networks/gnutella/gnutellaClients.ml | 4 ++-- src/networks/gnutella/gnutellaFunctions.ml | 17 +++++++++-------- src/networks/gnutella/gnutellaHandler.ml | 2 +- src/networks/gnutella/gnutellaOptions.ml | 2 +- src/networks/gnutella/gnutellaTypes.ml | 2 +- 5 files changed, 14 insertions(+), 13 deletions(-) diff --git a/src/networks/gnutella/gnutellaClients.ml b/src/networks/gnutella/gnutellaClients.ml index 733b1ab7..ec433244 100644 --- a/src/networks/gnutella/gnutellaClients.ml +++ b/src/networks/gnutella/gnutellaClients.ml @@ -215,7 +215,7 @@ save it on disk in the next version. *) end; let buf = Buffer.create 100 in let read_ttr counter_pos b to_read_int = - Buffer.add_substring buf b.buf b.pos to_read_int + Buffer.add_subbytes buf b.buf b.pos to_read_int in let read_more () = if !verbose_msg_clients then @@ -266,7 +266,7 @@ and read_some d c counter_pos b to_read_int = begin try CommonSwarming.received up - counter_pos b.buf b.pos to_read_int; + counter_pos (Bytes.to_string b.buf) b.pos to_read_int; with e -> lprintf "FT: Exception %s in CommonSwarming.received\n" (Printexc2.to_string e); diff --git a/src/networks/gnutella/gnutellaFunctions.ml b/src/networks/gnutella/gnutellaFunctions.ml index ff83b287..ba97909f 100644 --- a/src/networks/gnutella/gnutellaFunctions.ml +++ b/src/networks/gnutella/gnutellaFunctions.ml @@ -104,12 +104,13 @@ let handlers info gconn = let b = TcpBufferedSocket.buf sock in if monitored sock || !verbose_msg_raw then lprintf "iter_read %s :%d/%d\n%s\n" (Ip.to_string (peer_ip sock)) nread b.len - (String.escaped (String.sub b.buf b.pos b.len)); + (String.escaped (String.sub (Bytes.to_string b.buf) b.pos b.len)); if b.len > 0 then match gconn.gconn_handler with | HttpReader (n, hs, default) -> if b.len >= n then - let head = String.sub b.buf b.pos n in + let head = Bytes.sub b.buf b.pos n in + let head = Bytes.to_string head in (try let rec iter hs = match hs with @@ -133,9 +134,9 @@ let handlers info gconn = | (proto, h) :: tail -> if String2.starts_with head proto then begin - let i = find_header_end b.buf b.pos b.len in + let i = find_header_end (Bytes.to_string b.buf) b.pos b.len in if i <> 0 then - let header = String.sub b.buf b.pos (i - b.pos) in + let header = Bytes.to_string (Bytes.sub b.buf b.pos (i - b.pos)) in let first_line, headers = match Http_client.split_header header with [] -> "", [] @@ -197,17 +198,17 @@ let handlers info gconn = | CipherReader (cipher, h) -> if monitored sock || !verbose_msg_raw then lprintf "CipherReader %d: [%s]\n" nread - (String.escaped (String.sub b.buf b.pos b.len)); + (String.escaped (String.sub (Bytes.to_string b.buf) b.pos b.len)); if nread > 0 then begin (* AnyEndian.dump_sub b.buf (b.pos + b.len - nread) nread; *) - apply_cipher cipher b.buf (b.pos + b.len - nread) nread; + apply_cipher cipher (Bytes.to_string b.buf) (b.pos + b.len - nread) nread; log (LogReceive(peer_ip sock, peer_port sock, - String.sub b.buf (b.pos + b.len - nread) nread)); + String.sub (Bytes.to_string b.buf) (b.pos + b.len - nread) nread)); if monitored sock || !verbose_msg_raw then lprintf " deciphered: [%s]\n" - (String.escaped (String.sub b.buf b.pos b.len)); + (String.escaped (String.sub (Bytes.to_string b.buf) b.pos b.len)); end; let len = b.len in (try diff --git a/src/networks/gnutella/gnutellaHandler.ml b/src/networks/gnutella/gnutellaHandler.ml index 8cb1b394..3b0abcbf 100644 --- a/src/networks/gnutella/gnutellaHandler.ml +++ b/src/networks/gnutella/gnutellaHandler.ml @@ -356,7 +356,7 @@ let init s sock gconn = let udp_client_handler ip port buf = if !verbose then - lprintf "Unexpected UDP packet: \n%s\n" (String.escaped buf) + lprintf "Unexpected UDP packet: \n%s\n" (String.escaped (Bytes.to_string buf)) let update_shared_files () = () diff --git a/src/networks/gnutella/gnutellaOptions.ml b/src/networks/gnutella/gnutellaOptions.ml index 4395c6da..401f1d36 100644 --- a/src/networks/gnutella/gnutellaOptions.ml +++ b/src/networks/gnutella/gnutellaOptions.ml @@ -94,7 +94,7 @@ let client_uid = define_option gnutella_section ["client_uid"] let _ = option_hook client_uid (fun _ -> - let s = Md4.direct_to_string !!client_uid in + let s = Bytes.of_string (Md4.direct_to_string !!client_uid) in s.[8] <- '\255'; s.[15] <- '\000'; ) diff --git a/src/networks/gnutella/gnutellaTypes.ml b/src/networks/gnutella/gnutellaTypes.ml index c9ee3fbe..8eda3461 100644 --- a/src/networks/gnutella/gnutellaTypes.ml +++ b/src/networks/gnutella/gnutellaTypes.ml @@ -100,7 +100,7 @@ and client = { and upload_client = { uc_sock : TcpBufferedSocket.t; uc_partial : bool; - uc_reader : (int64 -> string -> int -> int -> unit); + uc_reader : (int64 -> bytes -> int -> int -> unit); mutable uc_chunk_pos : int64; uc_chunk_len : int64; uc_chunk_end : int64; From ef7cc73636c42a048ed7269d24ba38779a62c180 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 11:21:05 +0200 Subject: [PATCH 22/69] Ported filetp to string immutability. --- src/networks/fileTP/fileTPFTP.ml | 19 ++++++++++--------- src/networks/fileTP/fileTPHTTP.ml | 2 +- src/networks/fileTP/fileTPProtocol.ml | 6 +++--- src/networks/fileTP/fileTPSSH.ml | 16 ++++++++-------- 4 files changed, 22 insertions(+), 21 deletions(-) diff --git a/src/networks/fileTP/fileTPFTP.ml b/src/networks/fileTP/fileTPFTP.ml index f5ba897b..7d51d9a4 100644 --- a/src/networks/fileTP/fileTPFTP.ml +++ b/src/networks/fileTP/fileTPFTP.ml @@ -79,7 +79,7 @@ end_pos !counter_pos b.len to_read; let old_downloaded = CommonSwarming.downloaded swarmer in - CommonSwarming.received up !counter_pos b.buf b.pos to_read_int; + CommonSwarming.received up !counter_pos (Bytes.to_string b.buf) b.pos to_read_int; let new_downloaded = CommonSwarming.downloaded swarmer in c.client_total_downloaded <- c.client_total_downloaded ++ (new_downloaded -- old_downloaded); @@ -183,15 +183,16 @@ let ftp_send_range_request c (x,y) sock d = TcpBufferedSocket.set_reader sock (fun sock nread -> let b = TcpBufferedSocket.buf sock in if !verbose then - AnyEndian.dump_hex (String.sub b.buf b.pos b.len); + AnyEndian.dump_hex (Bytes.to_string (Bytes.sub b.buf b.pos b.len)); let rec iter i = if i < b.len then - if b.buf.[b.pos + i] = '\n' then begin - let slen = if i > 0 && b.buf.[b.pos + i - 1] = '\r' + if (Bytes.get b.buf (b.pos + i)) = '\n' then begin + let slen = if i > 0 && (Bytes.get b.buf (b.pos + i - 1)) = '\r' then i - 1 else i in - let line = String.sub b.buf b.pos slen in + let line = Bytes.sub b.buf b.pos slen in + let line = Bytes.to_string line in if !verbose then lprintf_nl "SRR LINE [%s]" line; buf_used b (i+1); if slen > 3 then begin @@ -382,16 +383,16 @@ let ftp_check_size file url start_download_file = TcpBufferedSocket.set_reader sock (fun sock nread -> let b = TcpBufferedSocket.buf sock in if !verbose then - AnyEndian.dump_hex (String.sub b.buf b.pos b.len); + AnyEndian.dump_hex (String.sub (Bytes.to_string b.buf) b.pos b.len); let rec iter i = if i < b.len then - if b.buf.[b.pos + i] = '\n' then begin - let slen = if i > 0 && b.buf.[b.pos + i - 1] = '\r' + if (Bytes.get b.buf (b.pos + i)) = '\n' then begin + let slen = if i > 0 && (Bytes.get b.buf (b.pos + i - 1)) = '\r' then i - 1 else i in - let line = String.sub b.buf b.pos slen in + let line = String.sub (Bytes.to_string b.buf) b.pos slen in if !verbose then lprintf_nl "CS LINE [%s]" line; buf_used b (i+1); if slen > 3 then begin diff --git a/src/networks/fileTP/fileTPHTTP.ml b/src/networks/fileTP/fileTPHTTP.ml index 62f3ac18..981c20e7 100644 --- a/src/networks/fileTP/fileTPHTTP.ml +++ b/src/networks/fileTP/fileTPHTTP.ml @@ -264,7 +264,7 @@ let rec client_parse_header c gconn sock header = let old_downloaded = CommonSwarming.downloaded swarmer in - CommonSwarming.received up !counter_pos b.buf b.pos to_read_int; + CommonSwarming.received up !counter_pos (Bytes.to_string b.buf) b.pos to_read_int; let new_downloaded = CommonSwarming.downloaded swarmer in c.client_total_downloaded <- c.client_total_downloaded ++ (new_downloaded -- old_downloaded); diff --git a/src/networks/fileTP/fileTPProtocol.ml b/src/networks/fileTP/fileTPProtocol.ml index 0cc46b8c..0b9b1998 100644 --- a/src/networks/fileTP/fileTPProtocol.ml +++ b/src/networks/fileTP/fileTPProtocol.ml @@ -48,12 +48,12 @@ let handlers info gconn = let begin_pos = b.pos in let rec iter i n_read = if i < end_pos then - if b.buf.[i] = '\r' then + if (Bytes.get b.buf i) = '\r' then iter (i+1) n_read else - if b.buf.[i] = '\n' then + if (Bytes.get b.buf i) = '\n' then if n_read then begin - let header = String.sub b.buf b.pos (i - b.pos) in + let header = Bytes.sub b.buf b.pos (i - b.pos) in (* if info then begin lprintf "HEADER : "; dump header; lprint_newline (); diff --git a/src/networks/fileTP/fileTPSSH.ml b/src/networks/fileTP/fileTPSSH.ml index a08184b5..b54acfd1 100644 --- a/src/networks/fileTP/fileTPSSH.ml +++ b/src/networks/fileTP/fileTPSSH.ml @@ -182,14 +182,14 @@ let ssh_check_size file url start_download_file = close sock s); TcpBufferedSocket.set_reader sock (fun sock nread -> let b = TcpBufferedSocket.buf sock in - lprintf "SSH reader %d [%s]\n" nread (String.escaped (String.sub b.buf b.pos b.len)); + lprintf "SSH reader %d [%s]\n" nread (String.escaped (String.sub (Bytes.to_string b.buf) b.pos b.len)); let rec iter i = if i < b.len then - if b.buf.[b.pos + i] = '\n' then begin - let slen = if i > 0 && b.buf.[b.pos + i - 1] = '\r' then + if (Bytes.get b.buf (b.pos + i)) = '\n' then begin + let slen = if i > 0 && (Bytes.get b.buf (b.pos + i - 1)) = '\r' then i - 1 else i in - let line = String.sub b.buf b.pos slen in + let line = String.sub (Bytes.to_string b.buf) b.pos slen in lprintf "SSH LINE [%s]\n" line; buf_used b (i+1); if String2.starts_with line "[SIZE " then begin @@ -245,7 +245,7 @@ let ssh_connect token c f = if b.len >= elen then begin segment := SegmentX (file_num, pos, len, elen, - String.sub b.buf b.pos elen); + String.sub (Bytes.to_string b.buf) b.pos elen); buf_used b elen; iter0 0 end @@ -255,11 +255,11 @@ let ssh_connect token c f = and iter0 i = if i < b.len then - if b.buf.[b.pos + i] = '\n' then begin - let slen = if i > 0 && b.buf.[b.pos + i - 1] = '\r' then + if (Bytes.get b.buf (b.pos + i)) = '\n' then begin + let slen = if i > 0 && (Bytes.get b.buf (b.pos + i - 1)) = '\r' then i - 1 else i in - let line = String.sub b.buf b.pos slen in + let line = String.sub (Bytes.to_string b.buf) b.pos slen in (* lprintf "SSH LINE [%s]\n" line; *) buf_used b (i+1); From 46643d88b902ecad8ba1c9365c8288187ccb2e25 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 11:28:04 +0200 Subject: [PATCH 23/69] Ported fasttrack to string immutability. --- src/networks/fasttrack/fasttrackPandora.ml | 36 ++++++++++----------- src/networks/fasttrack/fasttrackProto.ml | 9 +++--- src/networks/fasttrack/fasttrackProtocol.ml | 4 +-- src/networks/fasttrack/fasttrackServers.ml | 25 +++++++------- 4 files changed, 38 insertions(+), 36 deletions(-) diff --git a/src/networks/fasttrack/fasttrackPandora.ml b/src/networks/fasttrack/fasttrackPandora.ml index ac4a8892..9eb3ba1f 100644 --- a/src/networks/fasttrack/fasttrackPandora.ml +++ b/src/networks/fasttrack/fasttrackPandora.ml @@ -135,15 +135,15 @@ type cnx = { let connections = Hashtbl.create 13 let rec parse_packets pos s ciphers = - let len = String.length s - pos in + let len = Bytes.length s - pos in if len > 0 then let size = TcpMessages.packet_size ciphers s pos len in match size with None -> () | Some size -> if len >= size then - let msg = String.sub s pos size in - let addr, t = TcpMessages.parse ciphers msg in + let msg = Bytes.sub s pos size in + let addr, t = TcpMessages.parse ciphers (Bytes.to_string msg) in lprintf "MESSAGE: %s\n %s\n" (TcpMessages.string_of_path addr) (TcpMessages.to_string t); @@ -152,12 +152,12 @@ let rec parse_packets pos s ciphers = lprintf "Packet too short\n" let parse_netname start_pos s ciphers = - let len = String.length s in + let len = Bytes.length s in let rec iter pos = if pos < len then - if s.[pos] = '\000' then begin - let netname = String.sub s start_pos (pos-start_pos) in - lprintf "netname: [%s]\n" (String.escaped netname); + if (Bytes.get s pos) = '\000' then begin + let netname = Bytes.sub s start_pos (pos-start_pos) in + lprintf "netname: [%s]\n" (String.escaped (Bytes.to_string netname)); (* test_xinu s (pos+1) len 0x51L; *) parse_packets (pos+1) s ciphers @@ -242,13 +242,13 @@ let parse (s_out : string) (s_in : string) = ; begin - let s = String.create 8 in + let s = String.make 8 '\000' in cipher_packet_set ciphers.out_cipher s 0; lprintf "OUT CIPHER: [%s]\n" (String.escaped s); end; begin - let s = String.create 8 in + let s = String.make 8 '\000' in cipher_packet_set ciphers.in_cipher s 0; lprintf "IN CIPHER: [%s]\n" (String.escaped s); end; @@ -274,10 +274,10 @@ let parse (s_out : string) (s_in : string) = lprintf "---------------------------------------------->\n"; lprintf " HEADER[%s]\n" (String.escaped (String.sub s_out 0 4)); - parse_netname 12 s_out { ciphers with + parse_netname 12 (Bytes.of_string s_out) { ciphers with in_xinu = ciphers.out_xinu; in_cipher = ciphers.out_cipher }; lprintf "<----------------------------------------------\n"; - parse_netname 8 s_in ciphers; + parse_netname 8 (Bytes.of_string s_in) ciphers; parsed := true; (* (* @@ -616,7 +616,7 @@ let rec parse_packets c = let len = String.length s - pos in if len > 0 then try - let size = TcpMessages.packet_size c.c_ciphers s pos len in + let size = TcpMessages.packet_size c.c_ciphers (Bytes.of_string s) pos len in match size with None -> () | Some size -> @@ -704,13 +704,13 @@ let read_trace () = and iter_log pos len = if len > 13 then - let size = get_int s (pos + 10) in - let ip = LittleEndian.get_ip s pos in - let port = get_int16 s (pos+4) in - let time = get_int s (pos+6) in + let size = get_int_bytes s (pos + 10) in + let ip = LittleEndian.get_ip_bytes s pos in + let port = get_int16_bytes s (pos+4) in + let time = get_int_bytes s (pos+6) in let item_len = size + 14 in if item_len <= len then - let p = String.sub s (pos+14) size in + let p = Bytes.sub s (pos+14) size in received ip port time p; iter_log (pos + item_len) (len - item_len) else iter_read pos len @@ -720,7 +720,7 @@ let read_trace () = if pos = 0 then iter len else begin - String.blit s pos s 0 len; + Bytes.blit s pos s 0 len; iter len end in diff --git a/src/networks/fasttrack/fasttrackProto.ml b/src/networks/fasttrack/fasttrackProto.ml index 71057f5b..81358d90 100644 --- a/src/networks/fasttrack/fasttrackProto.ml +++ b/src/networks/fasttrack/fasttrackProto.ml @@ -1360,15 +1360,16 @@ dec: [(0)(35)(31)(147)(72)(36)(60)(179)(137)(93)(0)(40)(0)(184)(102)(10)(138)(31 (*************************************************************************) let packet_size ciphers s pos len = + let ss = Bytes.to_string s in if len > 0 then - match int_of_char s.[pos] with + match int_of_char (Bytes.get s pos) with 0x50 -> Some 1 | 0x52 -> Some 1 | 0x4b -> (* lprintf "We have got a real packet\n"; *) if len > 4 then (* dump_sub s b.pos b.len; *) - let msg_type, size = parse_head ciphers s pos in + let msg_type, size = parse_head ciphers ss pos in Some (size + 5) else None @@ -1377,7 +1378,7 @@ dec: [(0)(35)(31)(147)(72)(36)(60)(179)(137)(93)(0)(40)(0)(184)(102)(10)(138)(31 if len > 4 then begin (* dump_sub s b.pos b.len; *) lprintf "Trying to continue...\n"; - let msg_type, size = parse_head ciphers s pos in + let msg_type, size = parse_head ciphers ss pos in Some (size + 5) end else None @@ -1800,7 +1801,7 @@ module UdpMessages = struct try let s = write msg in - UdpSocket.write t ping s ip port + UdpSocket.write t ping (Bytes.of_string s) ip port with e -> lprintf "FT: Exception %s in udp_send\n" (Printexc2.to_string e) diff --git a/src/networks/fasttrack/fasttrackProtocol.ml b/src/networks/fasttrack/fasttrackProtocol.ml index fe64101f..ce5d3e15 100644 --- a/src/networks/fasttrack/fasttrackProtocol.ml +++ b/src/networks/fasttrack/fasttrackProtocol.ml @@ -93,7 +93,7 @@ let rec iter len n = let buf_dynint b data = let data = Int64.logand bits32 data in - Buffer.add_string b (iter 0 data) + Buffer.add_bytes b (iter 0 data) let buf_dynint b data = let data = Int64.logand bits32 data in @@ -116,7 +116,7 @@ let buf_dynint b data = (Int64.logand !data int64_7f))); data := Int64.shift_right_logical !data 7; done; - Buffer.add_string b (String.sub buf 0 len) + Buffer.add_bytes b (Bytes.sub buf 0 len) let dynint v = let b = Buffer.create 10 in diff --git a/src/networks/fasttrack/fasttrackServers.ml b/src/networks/fasttrack/fasttrackServers.ml index 556f11c0..b5eb5a36 100644 --- a/src/networks/fasttrack/fasttrackServers.ml +++ b/src/networks/fasttrack/fasttrackServers.ml @@ -97,9 +97,9 @@ let server_parse_after s gconn sock = None -> () | Some size -> if len >= size then - let msg = String.sub b.buf b.pos size in + let msg = Bytes.sub b.buf b.pos size in buf_used b size; - let addr, t = TcpMessages.parse ciphers msg in + let addr, t = TcpMessages.parse ciphers (Bytes.to_string msg) in FasttrackHandler.server_msg_handler sock s addr t; iter () in @@ -129,15 +129,15 @@ let server_parse_netname s gconn sock = let start_pos = b.pos in let end_pos = start_pos + len in let buf = b.buf in - let net = String.sub buf start_pos len in + let net = Bytes.sub buf start_pos len in if !verbose_msg_raw then - lprintf "net:[%s]\n" (String.escaped net); + lprintf "net:[%s]\n" (String.escaped (Bytes.to_string net)); let rec iter pos = if pos < end_pos then - if buf.[pos] = '\000' then begin - let netname = String.sub buf start_pos (pos-start_pos) in + if (Bytes.get buf pos) = '\000' then begin + let netname = Bytes.sub buf start_pos (pos-start_pos) in if !verbose_msg_raw then - lprintf "netname: [%s]\n" (String.escaped netname); + lprintf "netname: [%s]\n" (String.escaped (Bytes.to_string netname)); buf_used b (pos-start_pos+1); match s.server_ciphers with None -> assert false @@ -159,7 +159,7 @@ let server_parse_cipher s gconn sock = | Some ciphers -> if !verbose_msg_raw then lprintf "Cipher received from server\n"; - get_cipher_from_packet b.buf b.pos ciphers.in_cipher; + get_cipher_from_packet (Bytes.to_string b.buf) b.pos ciphers.in_cipher; init_cipher ciphers.in_cipher; xor_ciphers ciphers.out_cipher ciphers.in_cipher; @@ -251,13 +251,14 @@ let connect_server h = s.[3] <- '\043'; | Some f -> f s); - cipher_packet_set out_cipher s 4; + let ss = Bytes.to_string s in + cipher_packet_set out_cipher ss 4; if !verbose_msg_raw then begin - lprintf "SENDING %s\n" (String.escaped s); - AnyEndian.dump s; + lprintf "SENDING %s\n" (String.escaped ss); + AnyEndian.dump ss; end; - write_string sock s; + write_string sock ss; with _ -> disconnect_from_server nservers s Closed_connect_failed ) From b746d8181dde50bb174aa4e91782880d5b8769f7 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 11:38:45 +0200 Subject: [PATCH 24/69] Ported direct_connect to string immutability. --- src/networks/direct_connect/dcClients.ml | 10 +++++----- src/networks/direct_connect/dcProtocol.ml | 18 ++++++++++-------- src/networks/direct_connect/dcShared.ml | 6 +++--- 3 files changed, 18 insertions(+), 16 deletions(-) diff --git a/src/networks/direct_connect/dcClients.ml b/src/networks/direct_connect/dcClients.ml index ccd70c52..701bf0ff 100644 --- a/src/networks/direct_connect/dcClients.ml +++ b/src/networks/direct_connect/dcClients.ml @@ -1324,8 +1324,8 @@ let client_downloaded c sock nread = (* TODO check tth while loading, abort if e let check_buffer = String.create check_bytes in Unix32.read (file_fd file) (c.client_pos -- (Int64.of_int c.client_preread_bytes_left)) check_buffer 0 check_bytes; - let str2 = String.sub b.buf b.pos check_bytes in - if (String.compare check_buffer str2) = 0 then begin (* if downloaded is ok *) + let str2 = Bytes.sub b.buf b.pos check_bytes in + if (Bytes.compare check_buffer str2) = 0 then begin (* if downloaded is ok *) c.client_preread_bytes_left <- c.client_preread_bytes_left - check_bytes; if c.client_preread_bytes_left = 0 then begin (* if checked all preread bytes *) let downloaded = b.len - check_bytes in @@ -1456,7 +1456,7 @@ let udp_send ip port m = Buffer.reset buf; dc_write buf m; Buffer.add_char buf '|'; - let s = Buffer.contents buf in + let s = Buffer.to_bytes buf in (match !dc_udp_sock with | Some sock -> (*if !verbose_udp || !verbose_msg_clients then lprintf_nl "UDP Send: (%s)" s;*) @@ -1473,9 +1473,9 @@ let udp_handler sock event = UdpSocket.read_packets sock (fun p -> (try let pbuf = p.UdpSocket.udp_content in - let len = String.length pbuf in + let len = Bytes.length pbuf in if len > 0 then - udp_parse pbuf sock + udp_parse (Bytes.to_string pbuf) sock with e -> () ) ) | _ -> () diff --git a/src/networks/direct_connect/dcProtocol.ml b/src/networks/direct_connect/dcProtocol.ml index f79fa3f6..b77e6314 100644 --- a/src/networks/direct_connect/dcProtocol.ml +++ b/src/networks/direct_connect/dcProtocol.ml @@ -1129,14 +1129,15 @@ let dc_handler_server f sock nread = (try let rec iter nread = if nread > 0 then begin - let pos = String.index_from b.buf b.pos '|' in + let pos = Bytes.index_from b.buf b.pos '|' in if pos < (b.pos + b.len) then begin let len = pos - b.pos in - let s = String.sub b.buf b.pos len in + let s = Bytes.sub b.buf b.pos len in buf_used b (len+1); begin - try f (dc_parse true s) sock - with exn -> lprintf_nl "server handler %S : %s" s (Printexc2.to_string exn) + let ss = Bytes.to_string s in + try f (dc_parse true ss) sock + with exn -> lprintf_nl "server handler %S : %s" ss (Printexc2.to_string exn) end; iter b.len end @@ -1157,17 +1158,18 @@ let dc_handler_client c fm nm dm sock nread = (* fm = (read_first_message false) | Some c when c.client_receiving <> Int64.zero -> (* if we are downloading from client ...*) dm c sock nread | _ -> (* or message is a new connection ... *) - let pos = String.index_from b.buf b.pos '|' in + let pos = Bytes.index_from b.buf b.pos '|' in if pos < (b.pos + b.len) then begin let len = pos - b.pos in - let s = String.sub b.buf b.pos len in - let msg = dc_parse false s in + let s = Bytes.sub b.buf b.pos len in + let ss = Bytes.to_string s in + let msg = dc_parse false ss in buf_used b (len+1); begin try (match !c with | None -> c := fm msg sock (* do this only once per new non-existing client eg. we are in ACTIVE mode *) | Some c -> nm c msg sock); (* after initial connection is established *) - with exn -> lprintf_nl "client handler %S : %s" s (Printexc2.to_string exn) + with exn -> lprintf_nl "client handler %S : %s" ss (Printexc2.to_string exn) end; iter b.len end ) diff --git a/src/networks/direct_connect/dcShared.ml b/src/networks/direct_connect/dcShared.ml index 8d5744e5..3391452f 100644 --- a/src/networks/direct_connect/dcShared.ml +++ b/src/networks/direct_connect/dcShared.ml @@ -100,7 +100,7 @@ let file_to_che3_to_string filename = let npos = Int64.add pos (Int64.of_int rlen) in let str = String.create slen in Unix32.read file_fd pos str 0 rlen; - Buffer.add_string buf str; + Buffer.add_bytes buf str; if npos < flen then read npos in read Int64.zero; @@ -147,11 +147,11 @@ let file_to_bz2_to_buffer filename = in getchar ();*) let rec decompress () = let str = String.create 4096 in - let n = Bzip2.input ic str 0 (String.length str) in + let n = Bzip2.input ic str 0 (Bytes.length str) in if n = 0 then () else begin (*let ss = (String.sub str 0 n) in*) - Buffer.add_string buf (String.sub str 0 n); + Buffer.add_bytes buf (Bytes.sub str 0 n); (*lprintf_nl "(%s)" ss;*) decompress () end From 6ade6dbf776fb577324a3fa2c884b10a9e91ff4d Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 11:39:29 +0200 Subject: [PATCH 25/69] Ported svg_converter to string immutability. --- tools/svg_converter.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tools/svg_converter.ml b/tools/svg_converter.ml index 97241d71..fed5b70d 100644 --- a/tools/svg_converter.ml +++ b/tools/svg_converter.ml @@ -19,7 +19,7 @@ open Filename2 -open Zlib2 +open Zlib let load_svg file = Printf.printf "Converting file %s\n" file; @@ -29,7 +29,7 @@ let load_svg file = let buf = String.create len in really_input ic buf 0 len; close_in ic; - let bufz = compress_string buf in + let bufz = Zlib2.compress_string buf in let basename = basename file in let extension = last_extension basename in let dirname = String.sub file 0 (String.length file - String.length basename) in @@ -37,7 +37,7 @@ let load_svg file = let name = String.sub basename 0 len in let oc = open_out_bin (dirname ^ name ^ "_svg.ml") in output_string oc (Printf.sprintf "let t =" ); - output_string oc (Printf.sprintf "%S" bufz); + output_string oc (Printf.sprintf "%S" (Bytes.to_string bufz)); close_out oc let _ = From 99b55ca3407a9ff1ca3f66cba7fbbae76467058d Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 11:54:40 +0200 Subject: [PATCH 26/69] Ported donkey protocol to string immutability. --- src/networks/donkey/donkeyClient.ml | 4 +- src/networks/donkey/donkeyFiles.ml | 4 +- src/networks/donkey/donkeyGlobals.ml | 2 +- src/networks/donkey/donkeyImport.ml | 2 +- src/networks/donkey/donkeyInteractive.ml | 2 +- src/networks/donkey/donkeyMftp.ml | 2 +- src/networks/donkey/donkeyOptions.ml | 4 +- src/networks/donkey/donkeyOvernetImport.ml | 2 +- src/networks/donkey/donkeyPandora.ml | 2 +- src/networks/donkey/donkeyProtoClient.ml | 4 +- src/networks/donkey/donkeyProtoCom.ml | 78 +++++++++++----------- src/networks/donkey/donkeyProtoCom.mli | 2 +- src/networks/donkey/donkeyProtoKademlia.ml | 38 ++++++----- src/networks/donkey/donkeyProtoOvernet.ml | 12 ++-- src/networks/donkey/donkeyProtoServer.ml | 4 +- src/utils/net/anyEndian.ml | 4 +- src/utils/net/littleEndian.ml | 3 + 17 files changed, 88 insertions(+), 81 deletions(-) diff --git a/src/networks/donkey/donkeyClient.ml b/src/networks/donkey/donkeyClient.ml index 8d439a9b..56500ddf 100644 --- a/src/networks/donkey/donkeyClient.ml +++ b/src/networks/donkey/donkeyClient.ml @@ -1617,10 +1617,10 @@ is checked for the file. assert (pos = comp.comp_len); let s = Zlib2.uncompress_string2 s in if !verbose_download then - lprintf_nl "Decompressed: %d/%d" (String.length s) comp.comp_len; + lprintf_nl "Decompressed: %d/%d" (Bytes.length s) comp.comp_len; DonkeyOneFile.block_received c comp.comp_md4 - comp.comp_pos s 0 (String.length s); + comp.comp_pos (Bytes.to_string s) 0 (Bytes.length s); c.client_comp <- None; end else diff --git a/src/networks/donkey/donkeyFiles.ml b/src/networks/donkey/donkeyFiles.ml index b9b2af84..9a6e9419 100644 --- a/src/networks/donkey/donkeyFiles.ml +++ b/src/networks/donkey/donkeyFiles.ml @@ -87,7 +87,7 @@ module NewUpload = struct let slen = String.length s in let upload_buffer = String.create (slen + len_int) in String.blit s 0 upload_buffer 0 slen; - DonkeyProtoCom.new_string msg upload_buffer; + DonkeyProtoCom.new_string msg (Bytes.to_string upload_buffer); Unix32.read (file_fd file) begin_pos upload_buffer slen len_int; let uploaded = Int64.of_int len_int in count_upload c uploaded; @@ -98,7 +98,7 @@ module NewUpload = struct impl.impl_shared_uploaded <- impl.impl_shared_uploaded ++ uploaded); - write_string sock upload_buffer; + write_string sock (Bytes.to_string upload_buffer); check_end_upload c sock with | End_of_file -> lprintf_nl "Can not send file %s to %s, file removed?" diff --git a/src/networks/donkey/donkeyGlobals.ml b/src/networks/donkey/donkeyGlobals.ml index fee7f679..a67add12 100644 --- a/src/networks/donkey/donkeyGlobals.ml +++ b/src/networks/donkey/donkeyGlobals.ml @@ -298,7 +298,7 @@ let md4_of_array md4s = Array.iteri (fun i v -> String.blit (Md4.direct_to_string v) 0 s (i*16) 16 ) md4s; - Md4.string s + Md4.string (Bytes.to_string s) (* compute the name used to save the file *) diff --git a/src/networks/donkey/donkeyImport.ml b/src/networks/donkey/donkeyImport.ml index f337d181..372490ea 100644 --- a/src/networks/donkey/donkeyImport.ml +++ b/src/networks/donkey/donkeyImport.ml @@ -37,7 +37,7 @@ let dump_file filename = let n = input ic s 0 20 in lprintf "pos = %d\n" !pos; if n = 0 then raise Exit; - dump (String.sub s 0 n); + dump (String.sub (Bytes.to_string s) 0 n); pos := !pos + n; done with End_of_file | Exit -> ()) diff --git a/src/networks/donkey/donkeyInteractive.ml b/src/networks/donkey/donkeyInteractive.ml index fbe412ac..64cfefd0 100644 --- a/src/networks/donkey/donkeyInteractive.ml +++ b/src/networks/donkey/donkeyInteractive.ml @@ -469,7 +469,7 @@ let broadcast msg = let s = msg ^ "\n" in let len = String.length s in List.iter (fun sock -> - TcpBufferedSocket.write sock s 0 len + TcpBufferedSocket.write sock (Bytes.of_string s) 0 len ) !user_socks (* diff --git a/src/networks/donkey/donkeyMftp.ml b/src/networks/donkey/donkeyMftp.ml index 0f3d3d64..6f9f2140 100644 --- a/src/networks/donkey/donkeyMftp.ml +++ b/src/networks/donkey/donkeyMftp.ml @@ -128,7 +128,7 @@ let read_request ic = lprintf "read_request %d [%s]" len (String.escaped s); lprint_newline (); *) - s + Bytes.to_string s let output_request oc s = output_char oc (char_of_int 227); diff --git a/src/networks/donkey/donkeyOptions.ml b/src/networks/donkey/donkeyOptions.ml index 51a8cb6c..17a74580 100644 --- a/src/networks/donkey/donkeyOptions.ml +++ b/src/networks/donkey/donkeyOptions.ml @@ -132,10 +132,10 @@ let keep_sources = define_expert_option donkey_section ["keep_sources"] open Md4 let mldonkey_md4 md4 = - let md4 = Md4.direct_to_string md4 in + let md4 = (Bytes.of_string (Md4.direct_to_string md4)) in md4.[5] <- Char.chr 14; md4.[14] <- Char.chr 111; - Md4.direct_of_string md4 + Md4.direct_of_string (Bytes.to_string md4) let client_md4 = define_option donkey_section ["client_md4"] "The MD4 of this client" diff --git a/src/networks/donkey/donkeyOvernetImport.ml b/src/networks/donkey/donkeyOvernetImport.ml index ff21f58f..bfecddbf 100644 --- a/src/networks/donkey/donkeyOvernetImport.ml +++ b/src/networks/donkey/donkeyOvernetImport.ml @@ -32,7 +32,7 @@ let dump_file filename = let n = input ic s 0 20 in lprintf "pos = %d\n" !pos; if n = 0 then raise Exit; - dump (String.sub s 0 n); + dump (String.sub (Bytes.to_string s) 0 n); pos := !pos + n; done with End_of_file -> ()) diff --git a/src/networks/donkey/donkeyPandora.ml b/src/networks/donkey/donkeyPandora.ml index 19934ac2..aba691e4 100644 --- a/src/networks/donkey/donkeyPandora.ml +++ b/src/networks/donkey/donkeyPandora.ml @@ -185,7 +185,7 @@ let client_parse c opcode s = let pos = iter comp.comp_blocs in assert (pos = comp.comp_len); let s = Zlib2.uncompress_string2 s in - lprintf "Decompressed: %d/%d\n" (String.length s) comp.comp_len; + lprintf "Decompressed: %d/%d\n" (Bytes.length s) comp.comp_len; c.client_comp <- None; end else diff --git a/src/networks/donkey/donkeyProtoClient.ml b/src/networks/donkey/donkeyProtoClient.ml index 64b70cce..e7935bb0 100644 --- a/src/networks/donkey/donkeyProtoClient.ml +++ b/src/networks/donkey/donkeyProtoClient.ml @@ -1488,8 +1488,8 @@ and parse emule_version magic s = | 0xD4 -> (* 212 *) - let s = Zlib2.uncompress_string2 (String.sub s 1 (len-1)) in - let s = Printf.sprintf "%c%s" (char_of_int opcode) s in + let s = Zlib2.uncompress_string2 (Bytes.of_string (String.sub s 1 (len-1))) in + let s = Printf.sprintf "%c%s" (char_of_int opcode) (Bytes.to_string s) in begin try parse_emule_packet emule_version opcode (String.length s) s with diff --git a/src/networks/donkey/donkeyProtoCom.ml b/src/networks/donkey/donkeyProtoCom.ml index bc03edf7..05ef0817 100644 --- a/src/networks/donkey/donkeyProtoCom.ml +++ b/src/networks/donkey/donkeyProtoCom.ml @@ -42,11 +42,11 @@ let client_msg_to_string emule_version msg = buf_int8 buf 0; buf_int buf 0; let magic = DonkeyProtoClient.write emule_version buf msg in - let s = Buffer.contents buf in - let len = String.length s - 5 in + let s = Buffer.to_bytes buf in + let len = Bytes.length s - 5 in s.[0] <- char_of_int magic; str_int s 1 len; - s + (Bytes.to_string s) let server_msg_to_string msg = Buffer.reset buf; @@ -60,10 +60,10 @@ let server_msg_to_string msg = lprint_newline (); end; - let s = Buffer.contents buf in - let len = String.length s - 5 in + let s = Buffer.to_bytes buf in + let len = Bytes.length s - 5 in str_int s 1 len; - s + (Bytes.to_string s) let server_send sock m = (* @@ -102,12 +102,12 @@ let client_handler2 c ff f = | Some c -> c.client_emule_proto in let opcode = get_uint8 b.buf b.pos in - let msg_len = get_int b.buf (b.pos+1) in + let msg_len = get_int_bytes b.buf (b.pos+1) in if b.len >= 5 + msg_len then begin - let s = String.sub b.buf (b.pos+5) msg_len in + let s = Bytes.sub b.buf (b.pos+5) msg_len in buf_used b (msg_len + 5); - let t = M.parse emule_version opcode s in + let t = M.parse emule_version opcode (Bytes.to_string s) in (* M.print t; lprint_newline (); *) incr msgs; @@ -124,13 +124,13 @@ let cut_messages parse f sock nread = let b = TcpBufferedSocket.buf sock in try while b.len >= 5 do - let opcode = get_uint8 b.buf b.pos in - let msg_len = get_int b.buf (b.pos+1) in + let opcode = get_uint8_bytes b.buf b.pos in + let msg_len = get_int_bytes b.buf (b.pos+1) in if b.len >= 5 + msg_len then begin - let s = String.sub b.buf (b.pos+5) msg_len in + let s = Bytes.sub b.buf (b.pos+5) msg_len in buf_used b (msg_len + 5); - let t = parse opcode s in + let t = parse opcode (Bytes.to_string s) in f t sock end else raise Not_found @@ -148,7 +148,7 @@ let really_udp_send t ip port msg isping = try Buffer.reset buf; DonkeyProtoUdp.write buf msg; - let s = Buffer.contents buf in + let s = Buffer.to_bytes buf in UdpSocket.write t isping s ip port with e -> lprintf_nl "Exception %s in udp_send" (Printexc2.to_string e) @@ -163,10 +163,10 @@ let udp_handler f sock event = UdpSocket.read_packets sock (fun p -> try let pbuf = p.UdpSocket.udp_content in - let len = String.length pbuf in + let len = Bytes.length pbuf in if len > 0 then - let t = M.parse (int_of_char pbuf.[0]) - (String.sub pbuf 1 (len-1)) in + let t = M.parse (int_of_char (Bytes.get pbuf 0)) + (Bytes.to_string (Bytes.sub pbuf 1 (len-1))) in (* M.print t; *) f t p with e -> () @@ -179,15 +179,15 @@ let udp_basic_handler f sock event = UdpSocket.read_packets sock (fun p -> try let pbuf = p.UdpSocket.udp_content in - let len = String.length pbuf in + let len = Bytes.length pbuf in if len = 0 || - int_of_char pbuf.[0] <> DonkeyOpenProtocol.udp_magic then begin + int_of_char (Bytes.get pbuf 0) <> DonkeyOpenProtocol.udp_magic then begin if !verbose_unknown_messages then begin lprintf_nl "Received unknown UDP packet"; - dump pbuf; + dump (Bytes.to_string pbuf); end; end else begin - let t = String.sub pbuf 1 (len-1) in + let t = Bytes.sub pbuf 1 (len-1) in f t p end with e -> @@ -199,7 +199,7 @@ let udp_basic_handler f sock event = let new_string msg s = let len = String.length s - 5 in - str_int s 1 len + str_int_bytes s 1 len let empty_string = "" @@ -315,9 +315,9 @@ let server_send_share compressed sock msg = ( make_tagged_server compressed (Some sock) msg ) 0 max_len in - let s = Buffer.contents buf in + let s = Buffer.to_bytes buf in str_int s 0 nfiles; - let s = String.sub s 0 prev_len in + let s = Bytes.sub s 0 prev_len in if !verbose_share || !verbose then lprintf_nl "Sending %d share%s to server %s:%d%s" nfiles (Printf2.print_plural_s nfiles) (Ip.to_string (peer_ip sock)) (peer_port sock) @@ -331,26 +331,26 @@ let server_send_share compressed sock msg = in (* Emule only sends the string compressed when it is smaller in that state. *) - if compressed && ((String.length s_c) < (String.length s)) then + if compressed && ((Bytes.length s_c) < (Bytes.length s)) then begin buf_int8 buf 0xD4; buf_int buf 0; buf_int8 buf 21; (* ShareReq *) - Buffer.add_string buf s_c; - Buffer.contents buf + Buffer.add_bytes buf s_c; + Buffer.to_bytes buf end else begin buf_int8 buf 227; buf_int buf 0; buf_int8 buf 21; (* ShareReq *) - Buffer.add_string buf s; - Buffer.contents buf + Buffer.add_bytes buf s; + Buffer.to_bytes buf end in - let len = String.length s - 5 in + let len = Bytes.length s - 5 in str_int s 1 len; - write_string sock s + write_string sock (Bytes.to_string s) let client_send_files sock msg = let max_len = !!client_buffer_size - 100 - @@ -363,12 +363,12 @@ let client_send_files sock msg = let nfiles, prev_len = DonkeyProtoClient.ViewFilesReply.write_files_max buf ( make_tagged (Some sock) msg) 0 max_len in - let s = Buffer.contents buf in - let s = String.sub s 0 prev_len in - let len = String.length s - 5 in + let s = Buffer.to_bytes buf in + let s = Bytes.sub s 0 prev_len in + let len = Bytes.length s - 5 in str_int s 1 len; str_int s 6 nfiles; - write_string sock s + write_string sock (Bytes.to_string s) let client_send_dir sock dir files = let max_len = !!client_buffer_size - 100 - @@ -383,13 +383,13 @@ let client_send_dir sock dir files = let nfiles, prev_len = DonkeyProtoClient.ViewFilesReply.write_files_max buf ( make_tagged (Some sock) files) 0 max_len in - let s = Buffer.contents buf in - let s = String.sub s 0 prev_len in - let len = String.length s - 5 in begin + let s = Buffer.to_bytes buf in + let s = Bytes.sub s 0 prev_len in + let len = Bytes.length s - 5 in begin str_int s 1 len; str_int s (pos-4) nfiles; end; - write_string sock s + write_string sock (Bytes.to_string s) let udp_server_send s t = udp_send (get_udp_sock ()) s.server_ip (s.server_port+4) t diff --git a/src/networks/donkey/donkeyProtoCom.mli b/src/networks/donkey/donkeyProtoCom.mli index 7f8312bc..d627d3cc 100644 --- a/src/networks/donkey/donkeyProtoCom.mli +++ b/src/networks/donkey/donkeyProtoCom.mli @@ -60,7 +60,7 @@ val udp_handler : (* val propagate_working_servers : (Ip.t * int) list -> (Ip.t * int) list -> unit *) val udp_basic_handler : - (string -> UdpSocket.udp_packet -> unit) -> UdpSocket.t -> + (bytes -> UdpSocket.udp_packet -> unit) -> UdpSocket.t -> UdpSocket.event -> unit val server_msg_to_string : DonkeyProtoServer.t -> string diff --git a/src/networks/donkey/donkeyProtoKademlia.ml b/src/networks/donkey/donkeyProtoKademlia.ml index a8da9b8c..5d5d60bc 100644 --- a/src/networks/donkey/donkeyProtoKademlia.ml +++ b/src/networks/donkey/donkeyProtoKademlia.ml @@ -84,7 +84,7 @@ module P = struct ss.[14] <- s.[pos+13]; ss.[15] <- s.[pos+12]; - Md4.direct_of_string ss + Md4.direct_of_string (Bytes.to_string ss) let buf_md4 buf s = let s = Md4.direct_to_string s in @@ -112,7 +112,7 @@ module P = struct ss.[14] <- s.[pos+13]; ss.[15] <- s.[pos+12]; - Buffer.add_string buf ss + Buffer.add_bytes buf ss (* Strange: why was the IP format changed for Kademlia ? *) @@ -400,26 +400,26 @@ module P = struct let kademlia_header_code = char_of_int 0xE4 let kademlia_packed_header_code = char_of_int 0xE5 let kademlia_header = String.make 1 kademlia_header_code - let kademlia_packed_header = String.make 1 kademlia_packed_header_code + let kademlia_packed_header = Bytes.make 1 kademlia_packed_header_code let parse_message ip port pbuf = - let len = String.length pbuf in + let len = Bytes.length pbuf in if len < 2 || - (let magic = pbuf.[0] in + (let magic = Bytes.get pbuf 0 in magic <> kademlia_header_code && magic <> kademlia_packed_header_code) then begin if !CommonOptions.verbose_unknown_messages then begin lprintf_nl "Received unknown UDP packet"; - dump pbuf; + dump (Bytes.to_string pbuf); end; raise Not_found end else - let magic = pbuf.[0] in - let opcode = int_of_char pbuf.[1] in - let msg = String.sub pbuf 2 (len-2) in + let magic = Bytes.get pbuf 0 in + let opcode = int_of_char (Bytes.get pbuf 1) in + let msg = Bytes.sub pbuf 2 (len-2) in let msg = if magic = kademlia_packed_header_code then let s = Zlib2.uncompress_string2 msg in (* lprintf "Uncompressed:\n"; @@ -427,28 +427,30 @@ module P = struct s else msg in - let t = parse ip port opcode msg in + let t = parse ip port opcode (Bytes.to_string msg) in t let udp_send sock ip port ping msg = try Buffer.reset udp_buf; write udp_buf msg; - let s = Buffer.contents udp_buf in + let s = Buffer.to_bytes udp_buf in let s = - if String.length s > 200 then - let opcode = String.sub s 0 1 in - let args = String.sub s 1 (String.length s - 1) in - kademlia_packed_header ^ opcode ^ (Zlib2.compress_string args) + if Bytes.length s > 200 then + let opcode = Bytes.sub s 0 1 in + let args = Bytes.sub s 1 (Bytes.length s - 1) in + Bytes.cat kademlia_packed_header (Bytes.cat opcode (Zlib2.compress_string args)) else - kademlia_header ^ s + Bytes.cat kademlia_packed_header s in + let ss = Bytes.to_string s in + if !verbose_overnet then begin lprintf_nl "UDP to %s:%d op 0x%02X len %d type %s" - (Ip.to_string ip) port (get_uint8 s 1) (String.length s) (message_to_string msg); + (Ip.to_string ip) port (get_uint8 ss 1) (String.length ss) (message_to_string msg); end; (* let len = String.length s in @@ -491,7 +493,7 @@ module P = struct begin lprintf_nl "Error %s in udp_handler, dump of packet:" (Printexc2.to_string e); - dump p.UdpSocket.udp_content; + dump (Bytes.to_string p.UdpSocket.udp_content); lprint_newline () end ); diff --git a/src/networks/donkey/donkeyProtoOvernet.ml b/src/networks/donkey/donkeyProtoOvernet.ml index 6157c45d..16145452 100644 --- a/src/networks/donkey/donkeyProtoOvernet.ml +++ b/src/networks/donkey/donkeyProtoOvernet.ml @@ -388,13 +388,13 @@ module Proto = struct UdpSocket.read_packets sock (fun p -> try let pbuf = p.UdpSocket.udp_content in - let len = String.length pbuf in + let len = Bytes.length pbuf in if len < 2 || - int_of_char pbuf.[0] <> 227 then + int_of_char (Bytes.get pbuf 0) <> 227 then begin if !verbose_unknown_messages then begin lprintf_nl "Received unknown UDP packet"; - dump pbuf; + dump (Bytes.to_string pbuf); end end else @@ -405,7 +405,7 @@ module Proto = struct Ip.of_inet_addr inet, port | _ -> assert false in - let t = parse ip port (int_of_char pbuf.[1]) (String.sub pbuf 2 (len-2)) in + let t = parse ip port (int_of_char (Bytes.get pbuf 1)) (Bytes.to_string (Bytes.sub pbuf 2 (len-2))) in let is_not_banned ip = match !Ip.banned (ip, None) with None -> true @@ -420,7 +420,7 @@ module Proto = struct if !verbose_unknown_messages then begin lprintf_nl "Error %s in udp_handler, dump of packet:" (Printexc2.to_string e); - dump p.UdpSocket.udp_content; + dump (Bytes.to_string p.UdpSocket.udp_content); lprint_newline () end ); @@ -447,7 +447,7 @@ module Proto = struct lprintf_nl "UDP to %s:%d op 0x%02X len %d type %s" (Ip.to_string ip) port (get_uint8 s 1) (String.length s) (message_to_string msg); end; - UdpSocket.write sock ping s ip port + UdpSocket.write sock ping (Bytes.of_string s) ip port with e -> lprintf_nl "Exception %s in udp_send" (Printexc2.to_string e) diff --git a/src/networks/donkey/donkeyProtoServer.ml b/src/networks/donkey/donkeyProtoServer.ml index ddcc40c8..0d5739df 100644 --- a/src/networks/donkey/donkeyProtoServer.ml +++ b/src/networks/donkey/donkeyProtoServer.ml @@ -1124,8 +1124,8 @@ let rec parse magic s = raise Not_found end | 0xD4 -> (* 212 *) - let s = Zlib2.uncompress_string2 (String.sub s 1 (len-1)) in - let s = Printf.sprintf "%c%s" (char_of_int opcode) s in + let s = Zlib2.uncompress_string2 (Bytes.of_string (String.sub s 1 (len-1))) in + let s = Printf.sprintf "%c%s" (char_of_int opcode) (Bytes.to_string s) in parse 227 s | _ -> diff --git a/src/utils/net/anyEndian.ml b/src/utils/net/anyEndian.ml index 2c65c15d..283354fc 100644 --- a/src/utils/net/anyEndian.ml +++ b/src/utils/net/anyEndian.ml @@ -37,7 +37,9 @@ let buf_int8 buf i = let get_uint8 s pos = check_string s pos; int_of_char s.[pos] - + +let get_uint8_bytes b pos = + int_of_char (Bytes.get b pos) (* let buf_int32_8 buf i = Buffer.add_char buf (char_of_int (Int32.to_int ( diff --git a/src/utils/net/littleEndian.ml b/src/utils/net/littleEndian.ml index 70d6ba43..08b101f7 100644 --- a/src/utils/net/littleEndian.ml +++ b/src/utils/net/littleEndian.ml @@ -88,6 +88,9 @@ let str_int s pos i = s.[pos+2] <- char_of_int ((i lsr 16) land 255); s.[pos+3] <- char_of_int ((i lsr 24) land 255) +let str_int_bytes s pos i = + str_int (Bytes.unsafe_to_string s) pos i + let get_int s pos = let c1 = get_uint8 s pos in let c2 = get_uint8 s (pos+1) in From 18787df5f61d28a4a6b8518dd636fb08d518b6e2 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Wed, 5 Jun 2024 11:54:55 +0200 Subject: [PATCH 27/69] Enable safe strings. --- config/configure.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config/configure.in b/config/configure.in index 584e1074..95e497dd 100644 --- a/config/configure.in +++ b/config/configure.in @@ -691,7 +691,7 @@ if test "$OCAMLVERSION" \< "$MINIMUM_OCAML"; then fi if test ! "$OCAMLVERSION" \< "4.03.0"; then - OCAMLC="$OCAMLC -unsafe-string" + OCAMLC="$OCAMLC" fi if test "$OCAMLOPT" = "no"; then @@ -709,7 +709,7 @@ else exit 1; } if test ! "$OCAMLVERSION" \< "4.03.0"; then - OCAMLOPT="$OCAMLOPT -unsafe-string" + OCAMLOPT="$OCAMLOPT" fi fi From 57c47dad4647f6bf6a8a29b459e3b1f61e41ddc8 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 02:51:27 +0200 Subject: [PATCH 28/69] Ported to string immutability. --- src/daemon/common/commonFile.ml | 2 +- src/daemon/common/commonInteractive.ml | 2 +- src/daemon/common/commonMultimedia.ml | 84 +++++++++++----------- src/daemon/common/commonSwarming.ml | 2 +- src/daemon/common/guiDecoding.ml | 2 +- src/daemon/common/guiDecoding.mli | 2 +- src/daemon/common/guiEncoding.ml | 2 +- src/daemon/driver/driverCommands.ml | 16 ++--- src/daemon/driver/driverControlers.ml | 8 +-- src/daemon/driver/driverInterface.ml | 2 +- src/networks/donkey/donkeyClient.ml | 4 +- src/networks/donkey/donkeyFiles.ml | 4 +- src/networks/donkey/donkeyOneFile.mli | 2 +- src/networks/donkey/donkeyProtoClient.ml | 6 +- src/networks/donkey/donkeyProtoCom.ml | 6 +- src/networks/donkey/donkeyProtoCom.mli | 2 +- src/networks/fasttrack/fasttrackPandora.ml | 4 +- src/networks/fileTP/fileTPFTP.ml | 2 +- src/networks/fileTP/fileTPHTTP.ml | 4 +- src/networks/fileTP/fileTPProtocol.ml | 2 +- src/networks/fileTP/fileTPSSH.ml | 6 +- src/networks/gnutella/gnutellaClients.ml | 2 +- src/networks/gnutella/gnutellaFunctions.ml | 2 +- src/networks/gnutella/gnutellaMain.ml | 2 +- src/utils/cdk/file.ml | 6 +- src/utils/cdk/genlex2.ml | 8 +-- src/utils/cdk/gzip.ml | 6 +- src/utils/cdk/string2.ml | 11 ++- src/utils/cdk/string2.mli | 5 +- src/utils/cdk/tar.mlcpp | 14 ++-- src/utils/lib/md4.ml | 16 ++--- src/utils/lib/md4.mli | 2 +- src/utils/lib/store.ml | 6 +- src/utils/lib/unix32.ml | 10 +-- src/utils/lib/unix32.mli | 4 +- src/utils/lib/url.ml | 9 ++- src/utils/lib/url.mli | 3 +- src/utils/mp3tagui/mp3_tag.ml | 26 +++---- src/utils/net/base64.mli | 6 +- src/utils/net/cobs.ml | 16 ++--- src/utils/net/http_client.ml | 8 +-- src/utils/net/http_server.ml | 4 +- src/utils/net/littleEndian.ml | 3 - src/utils/net/mailer.ml | 44 ++++++------ src/utils/net/tcpBufferedSocket.ml | 12 ++-- 45 files changed, 202 insertions(+), 187 deletions(-) diff --git a/src/daemon/common/commonFile.ml b/src/daemon/common/commonFile.ml index 8cd0b6d6..ffaf30fa 100644 --- a/src/daemon/common/commonFile.ml +++ b/src/daemon/common/commonFile.ml @@ -895,7 +895,7 @@ parent.fstatus.location.href='submit?q=chgrp+'+v+'+%d'; let file_print_ed2k_link filename filesize md4hash = if md4hash = Md4.null then "" else Printf.sprintf "ed2k://|file|%s|%s|%s|/" - (Url.encode filename) (Int64.to_string filesize) (Md4.to_string md4hash) + (Bytes.to_string (Url.encode filename)) (Int64.to_string filesize) (Md4.to_string md4hash) (*************************************************************************) (* *) diff --git a/src/daemon/common/commonInteractive.ml b/src/daemon/common/commonInteractive.ml index 81122108..33c70edd 100644 --- a/src/daemon/common/commonInteractive.ml +++ b/src/daemon/common/commonInteractive.ml @@ -356,7 +356,7 @@ let mail_for_completed_file file = incoming.shdir_dirname (if (file_owner file).user_commit_dir = "" then "" else Printf.sprintf "/%s" (file_owner file).user_commit_dir) - (Url.encode (file_best_name file)) + (Bytes.to_string (Url.encode (file_best_name file))) in let line5 = if !!auto_commit then "" else diff --git a/src/daemon/common/commonMultimedia.ml b/src/daemon/common/commonMultimedia.ml index 88036a26..46ccd69d 100644 --- a/src/daemon/common/commonMultimedia.ml +++ b/src/daemon/common/commonMultimedia.ml @@ -243,7 +243,7 @@ let rec page_seek ic s pos = (**********************************************************************************) let normalize_stream_type s ct = - let s = String.sub s 0 6 in + let s = Bytes.sub_string s 0 6 in if s = "vorbis" && ct = 0x1 then OGG_VORBIS_STREAM else if s = "theora" && ct = 0x80 @@ -302,17 +302,17 @@ let rec next_ogg_stream ic ogg_infos str stream_number = and get_ogg_video_info ic ogg_infos str sizeof_packet stream_number = let s = String.create sizeof_packet in really_input ic s 0 sizeof_packet; - let codec = String.lowercase (String.sub s 0 4) in - let time_unit = read64 (String.sub s 8 8) in + let codec = String.lowercase (Bytes.sub_string s 0 4) in + let time_unit = read64 (Bytes.sub_string s 8 8) in let video_width = if sizeof_packet >= sizeof_old_ogm_packet - then read32 (String.sub s 36 4) - else read32 (String.sub s 34 4) + then read32 (Bytes.sub_string s 36 4) + else read32 (Bytes.sub_string s 34 4) in let video_height = if sizeof_packet >= sizeof_old_ogm_packet - then read32 (String.sub s 40 4) - else read32 (String.sub s 38 4) + then read32 (Bytes.sub_string s 40 4) + else read32 (Bytes.sub_string s 38 4) in let sample_rate = 10000000. /. time_unit in ogg_infos := { @@ -329,22 +329,22 @@ and get_ogg_video_info ic ogg_infos str sizeof_packet stream_number = and get_ogg_audio_info ic ogg_infos str sizeof_packet stream_number = let s = String.create sizeof_packet in really_input ic s 0 sizeof_packet; - let codec = get_audio_codec (String.sub s 0 4) in - let sample_per_unit = read64 (String.sub s 16 8) in + let codec = get_audio_codec (Bytes.sub_string s 0 4) in + let sample_per_unit = read64 (Bytes.sub_string s 16 8) in let channels = if sizeof_packet >= sizeof_old_ogm_packet - then read16 (String.sub s 36 2) - else read16 (String.sub s 34 2) + then read16 (Bytes.sub_string s 36 2) + else read16 (Bytes.sub_string s 34 2) in let blockalign = if sizeof_packet >= sizeof_old_ogm_packet - then read16 (String.sub s 38 2) - else read16 (String.sub s 36 2) + then read16 (Bytes.sub_string s 38 2) + else read16 (Bytes.sub_string s 36 2) in let avgbytespersec = if sizeof_packet >= sizeof_old_ogm_packet - then read32 (String.sub s 40 4) - else read32 (String.sub s 38 4) + then read32 (Bytes.sub_string s 40 4) + else read32 (Bytes.sub_string s 38 4) in ogg_infos := { stream_no = !stream_number; @@ -362,14 +362,14 @@ and get_ogg_vorbis_info ic ogg_infos str stream_number = seek_in ic (pos_in ic - 2); (* ogm sets 8 octets in the common header as vorbis uses 6 octects for 'vorbis' *) let s = String.create 22 in really_input ic s 0 22; - let version = read32 (String.sub s 0 4) in - let audio_channels = int_of_char s.[4] in - let sample_rate = read32 (String.sub s 5 4) in - let br_max = read32 (String.sub s 9 4) in - let br_nom = read32 (String.sub s 13 4) in - let br_min = read32 (String.sub s 17 4) in - let blocksize_1 = ((int_of_char s.[21]) asr 4) land 15 in - let blocksize_0 = (int_of_char s.[21]) land 15 in + let version = read32 (Bytes.sub_string s 0 4) in + let audio_channels = int_of_char (Bytes.get s 4) in + let sample_rate = read32 (Bytes.sub_string s 5 4) in + let br_max = read32 (Bytes.sub_string s 9 4) in + let br_nom = read32 (Bytes.sub_string s 13 4) in + let br_min = read32 (Bytes.sub_string s 17 4) in + let blocksize_1 = ((int_of_char (Bytes.get s 21)) asr 4) land 15 in + let blocksize_0 = (int_of_char (Bytes.get s 21)) land 15 in let l = ref [] in (if br_max > 0. then l := (Maximum_br br_max) :: !l); (if br_nom > 0. then l := (Nominal_br br_nom) :: !l); @@ -392,27 +392,27 @@ and get_ogg_theora_info ic ogg_infos str stream_number = seek_in ic (pos_in ic - 2); (* ogm sets 8 octets in the common header as theora uses 6 octects for 'theora' *) let s = String.create 34 in really_input ic s 0 34; - let vmaj = int_of_char s.[0] in - let vmin = int_of_char s.[1] in - let vrev = int_of_char s.[2] in + let vmaj = int_of_char (Bytes.get s 0) in + let vmin = int_of_char (Bytes.get s 1) in + let vrev = int_of_char (Bytes.get s 2) in let codec = Printf.sprintf "theora-%d.%d.%d" vmaj vmin vrev in (* multiply by 16 to get the actual frame width in pixels *) (* multiply by 16 to get the actual frame height in pixels *) - let picw = read24B (String.sub s 7 3) in - let pich = read24B (String.sub s 10 3) in - let frn = read32B (String.sub s 15 4) in - let frd = read32B (String.sub s 19 4) in + let picw = read24B (Bytes.sub_string s 7 3) in + let pich = read24B (Bytes.sub_string s 10 3) in + let frn = read32B (Bytes.sub_string s 15 4) in + let frd = read32B (Bytes.sub_string s 19 4) in let sample_rate = frn /. frd in - let parn = read24B (String.sub s 23 3) in - let pard = read24B (String.sub s 26 3) in + let parn = read24B (Bytes.sub_string s 23 3) in + let pard = read24B (Bytes.sub_string s 26 3) in let parn, pard = if parn = 0 then (1, 1) else (parn, pard) in - let cs = int_of_char s.[29] in - let nombr = read24B (String.sub s 30 3) in - let qual = (int_of_char s.[33] asr 2) land 63 in + let cs = int_of_char (Bytes.get s 29) in + let nombr = read24B (Bytes.sub_string s 30 3) in + let qual = (int_of_char (Bytes.get s 33) asr 2) land 63 in ogg_infos := { stream_no = !stream_number; stream_type = OGG_THEORA_STREAM; @@ -475,7 +475,7 @@ let search_info_avi ic = try (* pos: 0 *) let s = input_string4 ic in - if s <> "RIFF" then failwith "Not an AVI file (RIFF absent)"; + if s <> Bytes.of_string "RIFF" then failwith "Not an AVI file (RIFF absent)"; (* pos: 4 *) let size = input_int32 ic in @@ -485,11 +485,11 @@ let search_info_avi ic = (* pos: 8 *) let s = input_string4 ic in - if s <> "AVI " then failwith "Not an AVI file (AVI absent)"; + if s <> Bytes.of_string "AVI " then failwith "Not an AVI file (AVI absent)"; (* pos: 12 *) let s = input_string4 ic in - if s <> "LIST" then failwith "Not an AVI file (LIST absent)"; + if s <> Bytes.of_string "LIST" then failwith "Not an AVI file (LIST absent)"; (* position 16 *) let rec iter_list pos end_pos = @@ -509,11 +509,11 @@ let search_info_avi ic = (* lprint_string4 "header\n" header_name; *) (* pos: pos + 8 *) begin - match header_name with + match Bytes.to_string header_name with "hdrl" -> (* lprintf "HEADER\n"; *) - let s = input_string4 ic in + let s = Bytes.to_string (input_string4 ic) in if s <> "avih" then failwith "Bad AVI file (avih absent)"; (* pos: pos + 12 *) @@ -545,8 +545,8 @@ let search_info_avi ic = ignore (input_string4 ic); - let fccType = input_string4 ic in - let fccHandler = input_string4 ic in + let fccType = Bytes.to_string (input_string4 ic) in + let fccHandler = Bytes.to_string (input_string4 ic) in let _dwFlags = input_int32 ic in (* Contains AVITF_* flags *) let _wPriority = input_int16 ic in let _wLanguage = input_int16 ic in diff --git a/src/daemon/common/commonSwarming.ml b/src/daemon/common/commonSwarming.ml index 64e8396a..4a417c2a 100644 --- a/src/daemon/common/commonSwarming.ml +++ b/src/daemon/common/commonSwarming.ml @@ -2792,7 +2792,7 @@ let range_range r = (r.range_begin, r.range_end) let received up file_begin str string_begin string_len = assert (string_begin >= 0); assert (string_len >= 0); - assert (string_begin + string_len <= String.length str); + assert (string_begin + string_len <= Bytes.length str); let t = up.up_t in let s = t.t_s in diff --git a/src/daemon/common/guiDecoding.ml b/src/daemon/common/guiDecoding.ml index 203c95a5..43f16e31 100644 --- a/src/daemon/common/guiDecoding.ml +++ b/src/daemon/common/guiDecoding.ml @@ -47,7 +47,7 @@ let gui_cut_messages f sock nread = begin let s = Bytes.sub b.buf (b.pos+4) msg_len in buf_used b (msg_len + 4); - let opcode = get_int16 s 0 in + let opcode = get_int16_bytes s 0 in (f opcode s : unit) end else raise Not_found diff --git a/src/daemon/common/guiDecoding.mli b/src/daemon/common/guiDecoding.mli index 2bdf1337..2fd0a9da 100644 --- a/src/daemon/common/guiDecoding.mli +++ b/src/daemon/common/guiDecoding.mli @@ -23,5 +23,5 @@ val to_gui : int array -> int -> string -> GuiProto.to_gui val from_gui : int array -> int -> string -> GuiProto.from_gui val get_string : string -> int -> string * int -val gui_cut_messages : (int -> string -> unit) -> TcpBufferedSocket.t -> 'a -> unit +val gui_cut_messages : (int -> bytes -> unit) -> TcpBufferedSocket.t -> 'a -> unit diff --git a/src/daemon/common/guiEncoding.ml b/src/daemon/common/guiEncoding.ml index 25847f7a..6d0096c2 100644 --- a/src/daemon/common/guiEncoding.ml +++ b/src/daemon/common/guiEncoding.ml @@ -47,7 +47,7 @@ let gui_send writer sock t = let s = Buffer.to_bytes buf in let len = Bytes.length s - 4 in str_int s 0 len; - write_string sock s; + write_string sock (Bytes.to_string s); with UnsupportedGuiMessage -> () (*************** diff --git a/src/daemon/driver/driverCommands.ml b/src/daemon/driver/driverCommands.ml index 7d0f4cae..49d24162 100644 --- a/src/daemon/driver/driverCommands.ml +++ b/src/daemon/driver/driverCommands.ml @@ -1677,12 +1677,12 @@ let _ = if use_html_mods o then custom_commands := !custom_commands @ [ ( "bu bbig", name, - Printf.sprintf "mSub('output','custom=%s')" (Url.encode name), + Printf.sprintf "mSub('output','custom=%s')" (Bytes.to_string (Url.encode name)), name ) ; ] else Printf.bprintf buf "\\ %s \\\n" - (Url.encode name) name; + (Bytes.to_string (Url.encode name)) name; end else @@ -2295,14 +2295,14 @@ action=\\\"javascript:submitHtmlModsStyle();\\\"\\>"; onClick=\\\'javascript:{ parent.fstatus.location.href=\\\"submit?q=urlremove+\\\\\\\"%s\\\\\\\"\\\" setTimeout(\\\"window.location.reload()\\\",1000);}' - class=\\\"srb\\\"\\>Remove\\" (Url.encode w.url); + class=\\\"srb\\\"\\>Remove\\" (Url.encode_to_string w.url); Printf.bprintf buf " \\DL\\" (Url.encode w.url); + class=\\\"srb\\\"\\>DL\\" (Url.encode_to_string w.url); Printf.bprintf buf " \\%s\\ \\%d\\" w.url w.kind w.period; @@ -2563,7 +2563,7 @@ let _ = \\%s\\ \\%s\\\\" (html_mods_cntr ()) - (Url.encode dir) + (Url.encode_to_string dir) shared_dir.shdir_priority dir shared_dir.shdir_strategy @@ -4158,15 +4158,15 @@ let _ = (title, "sr", "\\" ^ title ^ "\\"); (title, "sr", "\\dllink\\" ^ " \\http\\" ^ " \\startbt\\" ) ]; diff --git a/src/daemon/driver/driverControlers.ml b/src/daemon/driver/driverControlers.ml index 0f026a96..5009b6f5 100644 --- a/src/daemon/driver/driverControlers.ml +++ b/src/daemon/driver/driverControlers.ml @@ -1557,15 +1557,15 @@ let http_handler o t r = let s = match !http_file_type with - HTM -> html_close_page buf false; dollar_escape o true (Buffer.to_bytes buf) - | MLHTM -> html_close_page buf true; dollar_escape o true (Buffer.to_bytes buf) + HTM -> html_close_page buf false; dollar_escape o true (Buffer.contents buf) + | MLHTM -> html_close_page buf true; dollar_escape o true (Buffer.contents buf) | TXT | UNK - | BIN -> Buffer.to_bytes buf + | BIN -> Buffer.contents buf in r.reply_content <- if !http_file_type <> BIN && !!html_use_gzip then - Zlib2.gzip_string s + Zlib2.gzip_string (Bytes.of_string s) else s let http_options = { diff --git a/src/daemon/driver/driverInterface.ml b/src/daemon/driver/driverInterface.ml index d280e9a6..efdd4630 100644 --- a/src/daemon/driver/driverInterface.ml +++ b/src/daemon/driver/driverInterface.ml @@ -1211,7 +1211,7 @@ let gui_handler t event = TcpBufferedSocket.set_reader sock (GuiDecoding.gui_cut_messages (fun opcode s -> try - let m = GuiDecoding.from_gui gui.gui_proto_from_gui_version opcode s in + let m = GuiDecoding.from_gui gui.gui_proto_from_gui_version opcode (Bytes.to_string s) in gui_reader gui m sock; with GuiDecoding.FromGuiMessageNotImplemented -> () )); diff --git a/src/networks/donkey/donkeyClient.ml b/src/networks/donkey/donkeyClient.ml index 56500ddf..999d4ebe 100644 --- a/src/networks/donkey/donkeyClient.ml +++ b/src/networks/donkey/donkeyClient.ml @@ -1620,7 +1620,7 @@ is checked for the file. lprintf_nl "Decompressed: %d/%d" (Bytes.length s) comp.comp_len; DonkeyOneFile.block_received c comp.comp_md4 - comp.comp_pos (Bytes.to_string s) 0 (Bytes.length s); + comp.comp_pos s 0 (Bytes.length s); c.client_comp <- None; end else @@ -1931,7 +1931,7 @@ end else *) log_chat_message cip (client_num c) c.client_name s; | M.EmuleCaptchaReq t -> - let b64data = Base64.encode t in + let b64data = Bytes.to_string (Base64.encode t) in let cip = string_of_client_addr c in log_chat_message cip (client_num c) c.client_name ("data:image/bmp;base64," ^ b64data) diff --git a/src/networks/donkey/donkeyFiles.ml b/src/networks/donkey/donkeyFiles.ml index 9a6e9419..1a187cb4 100644 --- a/src/networks/donkey/donkeyFiles.ml +++ b/src/networks/donkey/donkeyFiles.ml @@ -78,7 +78,7 @@ module NewUpload = struct B.usesixtyfour = (begin_pos ++ (Int64.of_int len_int)) > old_max_emule_file_size; B.start_pos = begin_pos; B.end_pos = begin_pos ++ (Int64.of_int len_int); - B.bloc_str = ""; + B.bloc_str = Bytes.empty; B.bloc_begin = 0; B.bloc_len = 0; } @@ -87,7 +87,7 @@ module NewUpload = struct let slen = String.length s in let upload_buffer = String.create (slen + len_int) in String.blit s 0 upload_buffer 0 slen; - DonkeyProtoCom.new_string msg (Bytes.to_string upload_buffer); + DonkeyProtoCom.new_string msg upload_buffer; Unix32.read (file_fd file) begin_pos upload_buffer slen len_int; let uploaded = Int64.of_int len_int in count_upload c uploaded; diff --git a/src/networks/donkey/donkeyOneFile.mli b/src/networks/donkey/donkeyOneFile.mli index 9df79577..6a704bf9 100644 --- a/src/networks/donkey/donkeyOneFile.mli +++ b/src/networks/donkey/donkeyOneFile.mli @@ -23,7 +23,7 @@ val get_from_client : DonkeyTypes.client -> unit val request_slot : DonkeyTypes.client -> unit val check_files_downloaded : unit -> unit val block_received : - DonkeyTypes.client -> Md4.t -> int64 -> string -> int -> int -> unit + DonkeyTypes.client -> Md4.t -> int64 -> bytes -> int -> int -> unit val add_client_chunks : DonkeyTypes.client -> DonkeyTypes.file -> Bitv.t -> unit val unshare_file : DonkeyTypes.file -> unit diff --git a/src/networks/donkey/donkeyProtoClient.ml b/src/networks/donkey/donkeyProtoClient.ml index e7935bb0..8e14dab3 100644 --- a/src/networks/donkey/donkeyProtoClient.ml +++ b/src/networks/donkey/donkeyProtoClient.ml @@ -496,7 +496,7 @@ module Bloc = struct usesixtyfour : bool; start_pos : int64; end_pos: int64; - bloc_str: string; + bloc_str: bytes; bloc_begin : int; bloc_len : int; } @@ -507,7 +507,7 @@ module Bloc = struct usesixtyfour = usesixtyfour; start_pos = if usesixtyfour then get_int64 s 17 else get_uint64_32 s 17; end_pos = if usesixtyfour then get_int64 s 25 else get_uint64_32 s 21; - bloc_str = s; + bloc_str = (Bytes.of_string s); bloc_begin = if usesixtyfour then 33 else 25; bloc_len = if usesixtyfour then len - 33 else len - 25; } @@ -522,7 +522,7 @@ module Bloc = struct buf_md4 buf t.md4; if t.usesixtyfour then buf_int64 buf t.start_pos else buf_int64_32 buf t.start_pos; if t.usesixtyfour then buf_int64 buf t.end_pos else buf_int64_32 buf t.end_pos; - Buffer.add_substring buf t.bloc_str t.bloc_begin t.bloc_len + Buffer.add_subbytes buf t.bloc_str t.bloc_begin t.bloc_len end module QueryBloc = struct diff --git a/src/networks/donkey/donkeyProtoCom.ml b/src/networks/donkey/donkeyProtoCom.ml index 05ef0817..d7d00094 100644 --- a/src/networks/donkey/donkeyProtoCom.ml +++ b/src/networks/donkey/donkeyProtoCom.ml @@ -101,7 +101,7 @@ let client_handler2 c ff f = None -> emule_proto (); | Some c -> c.client_emule_proto in - let opcode = get_uint8 b.buf b.pos in + let opcode = get_uint8_bytes b.buf b.pos in let msg_len = get_int_bytes b.buf (b.pos+1) in if b.len >= 5 + msg_len then begin @@ -198,8 +198,8 @@ let udp_basic_handler f sock event = let new_string msg s = - let len = String.length s - 5 in - str_int_bytes s 1 len + let len = Bytes.length s - 5 in + str_int s 1 len let empty_string = "" diff --git a/src/networks/donkey/donkeyProtoCom.mli b/src/networks/donkey/donkeyProtoCom.mli index d627d3cc..c1309ec4 100644 --- a/src/networks/donkey/donkeyProtoCom.mli +++ b/src/networks/donkey/donkeyProtoCom.mli @@ -75,7 +75,7 @@ val client_send_files : val client_send_dir : TcpBufferedSocket.t -> string -> file list -> unit -val new_string : DonkeyProtoClient.t -> string -> unit +val new_string : DonkeyProtoClient.t -> bytes -> unit val tag_file : file -> CommonTypes.tag list diff --git a/src/networks/fasttrack/fasttrackPandora.ml b/src/networks/fasttrack/fasttrackPandora.ml index 9eb3ba1f..808a87b4 100644 --- a/src/networks/fasttrack/fasttrackPandora.ml +++ b/src/networks/fasttrack/fasttrackPandora.ml @@ -89,7 +89,7 @@ X-KazaaTag: 6=Christina Aguliera(13) X-KazaaTag: 8=Stripped(13) X-KazaaTag: 14=Other(13) X-KazaaTag: 1=2002(13) -X-KazaaTag: 26=© christinas_eyedol 2002(13) +X-KazaaTag: 26=� christinas_eyedol 2002(13) X-KazaaTag: 12=album version, stripped, fighter, real, christina, aguilera(13) X-KazaaTag: 10=en(13) X-KazaaTag: 18=Video Clip(13) @@ -710,7 +710,7 @@ let read_trace () = let time = get_int_bytes s (pos+6) in let item_len = size + 14 in if item_len <= len then - let p = Bytes.sub s (pos+14) size in + let p = Bytes.sub_string s (pos+14) size in received ip port time p; iter_log (pos + item_len) (len - item_len) else iter_read pos len diff --git a/src/networks/fileTP/fileTPFTP.ml b/src/networks/fileTP/fileTPFTP.ml index 7d51d9a4..14e1bfba 100644 --- a/src/networks/fileTP/fileTPFTP.ml +++ b/src/networks/fileTP/fileTPFTP.ml @@ -79,7 +79,7 @@ end_pos !counter_pos b.len to_read; let old_downloaded = CommonSwarming.downloaded swarmer in - CommonSwarming.received up !counter_pos (Bytes.to_string b.buf) b.pos to_read_int; + CommonSwarming.received up !counter_pos b.buf b.pos to_read_int; let new_downloaded = CommonSwarming.downloaded swarmer in c.client_total_downloaded <- c.client_total_downloaded ++ (new_downloaded -- old_downloaded); diff --git a/src/networks/fileTP/fileTPHTTP.ml b/src/networks/fileTP/fileTPHTTP.ml index 981c20e7..cd267338 100644 --- a/src/networks/fileTP/fileTPHTTP.ml +++ b/src/networks/fileTP/fileTPHTTP.ml @@ -65,7 +65,7 @@ let http_send_range_request c range sock d = Printf.bprintf buf "Connection: Keep-Alive\r\n"; if url.Url.user <> "" then begin let userpass = Printf.sprintf "%s:%s" url.Url.user url.Url.passwd in - let encoded = Base64.encode userpass in + let encoded = Bytes.to_string (Base64.encode userpass) in Printf.bprintf buf "Authorization: Basic %s\r\n" encoded end; Printf.bprintf buf "\r\n"; @@ -264,7 +264,7 @@ let rec client_parse_header c gconn sock header = let old_downloaded = CommonSwarming.downloaded swarmer in - CommonSwarming.received up !counter_pos (Bytes.to_string b.buf) b.pos to_read_int; + CommonSwarming.received up !counter_pos b.buf b.pos to_read_int; let new_downloaded = CommonSwarming.downloaded swarmer in c.client_total_downloaded <- c.client_total_downloaded ++ (new_downloaded -- old_downloaded); diff --git a/src/networks/fileTP/fileTPProtocol.ml b/src/networks/fileTP/fileTPProtocol.ml index 0b9b1998..55350bc7 100644 --- a/src/networks/fileTP/fileTPProtocol.ml +++ b/src/networks/fileTP/fileTPProtocol.ml @@ -59,7 +59,7 @@ let handlers info gconn = dump header; lprint_newline (); end; *) - (try h gconn sock header with + (try h gconn sock (Bytes.to_string header) with e -> close sock (Closed_for_exception e)); if not (TcpBufferedSocket.closed sock) then begin let nused = i - b.pos + 1 in diff --git a/src/networks/fileTP/fileTPSSH.ml b/src/networks/fileTP/fileTPSSH.ml index b54acfd1..b503e112 100644 --- a/src/networks/fileTP/fileTPSSH.ml +++ b/src/networks/fileTP/fileTPSSH.ml @@ -56,7 +56,7 @@ let shell_command hostname = (*************************************************************************) let segment_received c num s pos = - if String.length s > 0 then + if Bytes.length s > 0 then let d = match c.client_downloads with [] -> disconnect_client c Closed_by_user; raise Exit @@ -85,7 +85,7 @@ let segment_received c num s pos = CommonSwarming.downloaded swarmer in CommonSwarming.received up - pos s 0 (String.length s); + pos s 0 (Bytes.length s); let new_downloaded = CommonSwarming.downloaded swarmer in @@ -306,7 +306,7 @@ let ssh_connect token c f = | SegmentX (file_num, pos, len, elen, ss) -> lprintf "******* SEGMENT RECEIVED *******\n"; - segment_received c file_num ss pos; + segment_received c file_num (Bytes.of_string ss) pos; segment := Nothing; iter0 0 | _ -> diff --git a/src/networks/gnutella/gnutellaClients.ml b/src/networks/gnutella/gnutellaClients.ml index ec433244..d364e5ff 100644 --- a/src/networks/gnutella/gnutellaClients.ml +++ b/src/networks/gnutella/gnutellaClients.ml @@ -266,7 +266,7 @@ and read_some d c counter_pos b to_read_int = begin try CommonSwarming.received up - counter_pos (Bytes.to_string b.buf) b.pos to_read_int; + counter_pos b.buf b.pos to_read_int; with e -> lprintf "FT: Exception %s in CommonSwarming.received\n" (Printexc2.to_string e); diff --git a/src/networks/gnutella/gnutellaFunctions.ml b/src/networks/gnutella/gnutellaFunctions.ml index ba97909f..ff31ab3c 100644 --- a/src/networks/gnutella/gnutellaFunctions.ml +++ b/src/networks/gnutella/gnutellaFunctions.ml @@ -87,7 +87,7 @@ let default_handler gconn sock = let b = buf sock in if !verbose then lprintf "HttpReader: Handler not found for [%s]\n" - (String.escaped (String.sub b.buf b.pos b.len)); + (String.escaped (Bytes.to_string (Bytes.sub b.buf b.pos b.len))); close sock (Closed_for_error "not recognized"); failwith "Reply is not in the correct protocol" | Some f -> f gconn sock diff --git a/src/networks/gnutella/gnutellaMain.ml b/src/networks/gnutella/gnutellaMain.ml index f7e07e83..97c3f557 100644 --- a/src/networks/gnutella/gnutellaMain.ml +++ b/src/networks/gnutella/gnutellaMain.ml @@ -74,7 +74,7 @@ let udp_handler sock event = in (* lprintf "Gnutella: calling udp_client_handler %s:%d\n" (Ip.to_string ip) port; *) - let buf = p.UdpSocket.udp_content in + let buf = Bytes.to_string p.UdpSocket.udp_content in GnutellaHandler.udp_client_handler ip port buf with e -> lprintf "Error %s in udp_handler\n" diff --git a/src/utils/cdk/file.ml b/src/utils/cdk/file.ml index c0105e0f..fc50efa7 100644 --- a/src/utils/cdk/file.ml +++ b/src/utils/cdk/file.ml @@ -19,7 +19,7 @@ (* read a whole file *) let to_string name = - Unix2.tryopen_read_bin name (fun chan -> + Bytes.to_string (Unix2.tryopen_read_bin name (fun chan -> let buf_size = 1024 in let buf = String.create buf_size in let rec iter buf nb_read = @@ -32,12 +32,12 @@ let to_string name = let nb_read = nb_read + tmp in let buf = if nb_read = buf_size then - String2.resize buf (2 * buf_size) + String2.resize_bytes buf (2 * buf_size) else buf in iter buf nb_read in - iter buf 0) + iter buf 0)) let read_whole_chan chan = let buf = Buffer.create 1024 in diff --git a/src/utils/cdk/genlex2.ml b/src/utils/cdk/genlex2.ml index de90afe4..9c469e5d 100644 --- a/src/utils/cdk/genlex2.ml +++ b/src/utils/cdk/genlex2.ml @@ -28,7 +28,7 @@ type token = (* The string buffering machinery *) -let initial_buffer = String.create 32 +let initial_buffer = String.make 32 '\000' let buffer = ref initial_buffer let bufpos = ref 0 @@ -38,10 +38,10 @@ let reset_buffer () = buffer := initial_buffer; bufpos := 0 let store c = if !bufpos >= String.length !buffer then begin - let newbuffer = String.create (2 * !bufpos) in - String.blit !buffer 0 newbuffer 0 !bufpos; buffer := newbuffer + let newbuffer = String.make (2 * !bufpos) '\000' in + String.blit !buffer 0 (Bytes.of_string newbuffer) 0 !bufpos; buffer := newbuffer end; - String.set !buffer !bufpos c; + String.set (Bytes.of_string !buffer) !bufpos c; incr bufpos let get_string () = diff --git a/src/utils/cdk/gzip.ml b/src/utils/cdk/gzip.ml index bd9e4fc7..239ece75 100644 --- a/src/utils/cdk/gzip.ml +++ b/src/utils/cdk/gzip.ml @@ -153,9 +153,9 @@ let rec really_input iz buf pos len = end let input_char iz = - if input iz (Bytes.of_string iz.char_buffer) 0 1 = 0 + if input iz iz.char_buffer 0 1 = 0 then raise End_of_file - else Bytes.get (Bytes.of_string iz.char_buffer) 0 + else Bytes.get iz.char_buffer 0 let input_byte iz = Char.code (input_char iz) @@ -176,7 +176,7 @@ type 'a out_channel = out_stream: Zlib.stream; mutable out_size: int32; mutable out_crc: int32; - char_buffer: string } + char_buffer: bytes } let open_out ?(level = 6) oc = if level < 1 || level > 9 then invalid_arg "Gzip_stream.open_output: bad level"; diff --git a/src/utils/cdk/string2.ml b/src/utils/cdk/string2.ml index efed116f..6ef5a108 100644 --- a/src/utils/cdk/string2.ml +++ b/src/utils/cdk/string2.ml @@ -204,7 +204,16 @@ let resize s newlen = let str = Bytes.create newlen in Bytes.blit_string s 0 str 0 len; Bytes.to_string str - + +let resize_bytes s newlen = + let len = Bytes.length s in + if len > newlen then + Bytes.sub s 0 newlen + else + let str = Bytes.create newlen in + Bytes.blit s 0 str 0 len; + str + let init len f = let s = String.create len in for i = 0 to len - 1 do diff --git a/src/utils/cdk/string2.mli b/src/utils/cdk/string2.mli index bccb5806..413cd893 100644 --- a/src/utils/cdk/string2.mli +++ b/src/utils/cdk/string2.mli @@ -81,7 +81,10 @@ val of_char : char -> string val resize : string -> int -> string (*d [resize s len] returns a string of length [len] starting with [s]. *) - + +val resize_bytes: bytes -> int -> bytes +(*d [resize s len] returns a byffer of length [len] starting with [s]. *) + val init : int -> (int -> char) -> string val tokens: string -> string list diff --git a/src/utils/cdk/tar.mlcpp b/src/utils/cdk/tar.mlcpp index f39ba538..9987ac97 100644 --- a/src/utils/cdk/tar.mlcpp +++ b/src/utils/cdk/tar.mlcpp @@ -276,7 +276,7 @@ let read_body t = let leftover = String.create blocksize in t.chan#really_input leftover 0 align end; - buf + (Bytes.to_string buf) let read_entry t = let head = read_header t in @@ -394,8 +394,8 @@ let write_gnu_header t buf = write_int32 buf 36 ext.t_realsize let output t head body = - let size = String.length body in - let buf = String.copy empty_block in + let size = Bytes.length body in + let buf = Bytes.copy empty_bytes in write_str buf 0 100 head.t_name; write_num8 buf 100 head.t_mode; write_num8 buf 108 head.t_uid; @@ -415,8 +415,8 @@ let output t head body = let chksum = compute_chksum buf in write_padded_num buf 148 chksum; t.ochan#output buf 0 blocksize; - if head.t_format = GNU_FORMAT && isdigit buf.[156] then begin - let buf2 = String.copy empty_block in + if head.t_format = GNU_FORMAT && isdigit (Bytes.get buf 156) then begin + let buf2 = Bytes.copy empty_bytes in write_gnu_header head buf2; t.ochan#output buf2 0 blocksize end; @@ -424,11 +424,11 @@ let output t head body = t.ochan#output body 0 size; let align = blocksize - (size mod blocksize) in if align > 0 && align < blocksize then - t.ochan#output empty_block 0 align + t.ochan#output empty_bytes 0 align end let flush t = - t.ochan#output empty_block 0 blocksize; + t.ochan#output empty_bytes 0 blocksize; t.ochan#flush () let close_out t = diff --git a/src/utils/lib/md4.ml b/src/utils/lib/md4.ml index 3b2418e4..4bc0c94e 100644 --- a/src/utils/lib/md4.ml +++ b/src/utils/lib/md4.ml @@ -198,7 +198,7 @@ module Base6427 = struct done done; hash64.[!j-1] <- '='; - Bytes.sub hash64 0 !j + String.sub (Bytes.to_string hash64) 0 !j let base64tbl_inv = String.create 126 let _ = @@ -207,7 +207,7 @@ module Base6427 = struct done let of_string _ hash64 = - let hashbin = Bytes.make 20 '\000' in + let hashbin = Bytes.create 20 in let hash64 n = let c = hash64.[n] in int_of_char (Bytes.get base64tbl_inv (int_of_char c)) @@ -314,7 +314,7 @@ module Make(M: sig let string s = let len = String.length s in - let digest = Bytes.create hash_length in + let digest = String.make hash_length '\000' in unsafe_string digest s len; digest @@ -334,30 +334,30 @@ module Make(M: sig external xor_c : t -> t -> t -> unit = "md4_xor" "noalloc" let xor m1 m2 = - let m3 = Bytes.create hash_length in + let m3 = String.make hash_length '\000' in xor_c m1 m2 m3; m3 let file s = - let digest = Bytes.create hash_length in + let digest = String.make hash_length '\000' in let file_size = Unix32.getsize s in unsafe_file digest s file_size; digest let digest_subfile fd pos len = - let digest = Bytes.create hash_length in + let digest = String.make hash_length '\000' in Unix32.apply_on_chunk fd pos len (fun fd pos -> digest_subfile digest fd pos len); digest - let create () = Bytes.create hash_length + let create () = String.make hash_length '\000' let direct_to_string s = s let direct_of_string s = s let random () = - let s = create () in + let s = (Bytes.of_string (create ())) in for i = 0 to hash_length - 1 do s.[i] <- char_of_int (Random.int 256) done; diff --git a/src/utils/lib/md4.mli b/src/utils/lib/md4.mli index 64cee459..b15de4d9 100644 --- a/src/utils/lib/md4.mli +++ b/src/utils/lib/md4.mli @@ -80,4 +80,4 @@ module Md5Ext : Digest module Base16 : Base module Base32 : Base module Base6427 : Base - \ No newline at end of file + diff --git a/src/utils/lib/store.ml b/src/utils/lib/store.ml index 18cbc302..88fedb7e 100644 --- a/src/utils/lib/store.ml +++ b/src/utils/lib/store.ml @@ -56,7 +56,7 @@ let rec iter_write fd s pos len = iter_write fd s (pos+nwrite) (len-nwrite) let really_write fd pos s = - let len = String.length s in + let len = Bytes.length s in if verbose then begin lprintf_nl "write %d %d" pos len; end; @@ -151,8 +151,8 @@ let uncombine comb = pos, chunk_size, attr let save t doc v attr = - let str = Marshal.to_string v [] in - let len = String.length str in + let str = Marshal.to_bytes v [] in + let len = Bytes.length str in let chunk_size = chunk_size len in let file = try List.assoc chunk_size t.store_files diff --git a/src/utils/lib/unix32.ml b/src/utils/lib/unix32.ml index 458332de..d9e2c197 100644 --- a/src/utils/lib/unix32.ml +++ b/src/utils/lib/unix32.ml @@ -1110,7 +1110,7 @@ type file = { mutable filename : string; mutable writable : bool; mutable error : exn option; - mutable buffers : (string * int * int * int64 * int64) list; + mutable buffers : (bytes * int * int * int64 * int64) list; } module H = Weak.Make(struct @@ -1258,7 +1258,7 @@ let flush_fd t = | [] -> () | (s, pos_s, len_s, offset, len) :: tail -> Buffer.reset buffer; - Buffer.add_substring buffer s pos_s len_s; + Buffer.add_subbytes buffer s pos_s len_s; t.buffers <- tail; iter_in offset len @@ -1268,7 +1268,7 @@ let flush_fd t = | (s, pos_s, len_s, offset2, len2) :: tail -> let in_offset = offset ++ len -- offset2 in if in_offset = Int64.zero then begin - Buffer.add_substring buffer s pos_s len_s; + Buffer.add_subbytes buffer s pos_s len_s; t.buffers <- tail; iter_in offset (len ++ len2); end else @@ -1284,7 +1284,7 @@ let flush_fd t = iter_in offset len end else begin let new_pos = len2 -- keep_len in - Buffer.add_substring buffer s + Buffer.add_subbytes buffer s (pos_s + Int64.to_int new_pos) (Int64.to_int keep_len); buffered_bytes := !buffered_bytes -- new_pos; iter_in offset (len ++ keep_len) @@ -1343,7 +1343,7 @@ let buffered_write t offset s pos_s len_s = raise e let buffered_write_copy t offset s pos_s len_s = - buffered_write t offset (String.sub s pos_s len_s) 0 len_s + buffered_write t offset (Bytes.sub s pos_s len_s) 0 len_s let copy_chunk t1 t2 pos1 pos2 len = flush_fd t1; diff --git a/src/utils/lib/unix32.mli b/src/utils/lib/unix32.mli index 10b15c00..1a8cfcd2 100644 --- a/src/utils/lib/unix32.mli +++ b/src/utils/lib/unix32.mli @@ -52,8 +52,8 @@ val owner : string -> (string * string) val flush : unit -> unit val flush_fd : t -> unit -val buffered_write : t -> int64 -> string -> int -> int -> unit -val buffered_write_copy : t -> int64 -> string -> int -> int -> unit +val buffered_write : t -> int64 -> bytes -> int -> int -> unit +val buffered_write_copy : t -> int64 -> bytes -> int -> int -> unit val write : t -> int64 -> bytes -> int -> int -> unit val max_buffered : int64 ref val remove : t -> unit diff --git a/src/utils/lib/url.ml b/src/utils/lib/url.ml index 818ab87d..c226b707 100644 --- a/src/utils/lib/url.ml +++ b/src/utils/lib/url.ml @@ -52,6 +52,9 @@ let encode s = done; Bytes.sub res 0 !pos +let encode_to_string s = + Bytes.to_string (encode s) + (** decodes a sting according RFC 1738 or x-www-form-urlencoded ('+' with ' ') @param raw true use RFC 1738 @@ -162,12 +165,12 @@ let put_args s args = let rec manage_args = function | [] -> assert false | [a, ""] -> - Buffer.add_string res (encode a) + Buffer.add_bytes res (encode a) | [a, b] -> - Buffer.add_string res (encode a); Buffer.add_char res '='; Buffer.add_string res + Buffer.add_bytes res (encode a); Buffer.add_char res '='; Buffer.add_bytes res (encode b) | (a,b)::l -> - Buffer.add_string res (encode a); Buffer.add_char res '='; Buffer.add_string res + Buffer.add_bytes res (encode a); Buffer.add_char res '='; Buffer.add_bytes res (encode b); Buffer.add_char res '&'; manage_args l in (* lprintf "len args %d" (List.length args); lprint_newline ();*) diff --git a/src/utils/lib/url.mli b/src/utils/lib/url.mli index 977be984..10c3612d 100644 --- a/src/utils/lib/url.mli +++ b/src/utils/lib/url.mli @@ -53,7 +53,8 @@ val cut_args : string -> (string * string) list val put_args : string -> (string * string) list -> string -val encode : string -> string +val encode : string -> bytes +val encode_to_string: string -> string val decode : ?raw:bool -> string -> string val option : url Options.option_class diff --git a/src/utils/mp3tagui/mp3_tag.ml b/src/utils/mp3tagui/mp3_tag.ml index 633df6f7..e0b67f76 100644 --- a/src/utils/mp3tagui/mp3_tag.ml +++ b/src/utils/mp3tagui/mp3_tag.ml @@ -161,19 +161,19 @@ module Id3v2 = struct for i = 1 to n do ignore(input_byte ic) done let valid_header header = - Bytes.sub header 0 3 = "ID3" - && (Char.code header.[3] = 3 || Char.code header.[3] = 4) - && Char.code header.[5] land 0b00111111 = 0 - && Char.code header.[6] land 0b10000000 = 0 - && Char.code header.[7] land 0b10000000 = 0 - && Char.code header.[8] land 0b10000000 = 0 - && Char.code header.[9] land 0b10000000 = 0 + Bytes.sub header 0 3 = Bytes.of_string "ID3" + && (Char.code (Bytes.get header 3) = 3 || Char.code (Bytes.get header 3) = 4) + && Char.code (Bytes.get header 5) land 0b00111111 = 0 + && Char.code (Bytes.get header 6) land 0b10000000 = 0 + && Char.code (Bytes.get header 7) land 0b10000000 = 0 + && Char.code (Bytes.get header 8) land 0b10000000 = 0 + && Char.code (Bytes.get header 9) land 0b10000000 = 0 let length_header header = - ((Char.code header.[6] lsl 21) lor - (Char.code header.[7] lsl 14) lor - (Char.code header.[8] lsl 7) lor - (Char.code header.[9])) + ((Char.code (Bytes.get header 6) lsl 21) lor + (Char.code (Bytes.get header 7) lsl 14) lor + (Char.code (Bytes.get header 8) lsl 7) lor + (Char.code (Bytes.get header 9))) let decode_framedata id data = if id = "TXXX" then begin @@ -194,10 +194,10 @@ module Id3v2 = struct let len = length_header header in let startpos = pos_in ic in (* Record use of unsynchronization *) - unsynchronization := ((Char.code header.[5] land 0b10000000) <> 0); + unsynchronization := ((Char.code (Bytes.get header 5) land 0b10000000) <> 0); last_byte_read := 0; (* Skip extended header if present *) - if Char.code header.[5] land 0b01000000 <> 0 then + if Char.code (Bytes.get header 5) land 0b01000000 <> 0 then skip_bytes ic (input_int4 ic); (* Collect frames *) let tags = ref [] in diff --git a/src/utils/net/base64.mli b/src/utils/net/base64.mli index c776b6f8..1c2355f6 100644 --- a/src/utils/net/base64.mli +++ b/src/utils/net/base64.mli @@ -1,4 +1,4 @@ -val encode : string -> string -val encode_substring : string -> int -> int -> string -val decode : string -> string +val encode : string -> bytes +val encode_substring : string -> int -> int -> bytes +val decode : string -> bytes diff --git a/src/utils/net/cobs.ml b/src/utils/net/cobs.ml index 6f6fd619..b8993e45 100644 --- a/src/utils/net/cobs.ml +++ b/src/utils/net/cobs.ml @@ -100,7 +100,7 @@ let decode psrc = let dstlen = calcDecodedLength psrc srclen in let pdest = String.create dstlen in decodeData pdest psrc srclen; - pdest + (Bytes.to_string pdest) let encode psrc = let srclen = String.length psrc in @@ -261,15 +261,15 @@ let write_ggep buf put_magic last_block b = let id_len = String.length id in if put_magic then Buffer.add_char buf '\195'; let cobs_encoded = String.contains data '\000' in - let data = if cobs_encoded then encode data else data in + let data = if cobs_encoded then encode data else (Bytes.of_string data) in let flags = id_len in let flags = if cobs_encoded then flags lor (1 lsl 6) else flags in let flags = if last_block then flags lor (1 lsl 7) else flags in buf_int8 buf flags; Buffer.add_string buf id; - let data_len = String.length data in + let data_len = Bytes.length data in put_len buf true data_len; - Buffer.add_string buf data + Buffer.add_bytes buf data let write_block buf list = let rec iter put_magic list = @@ -354,15 +354,15 @@ let write buf list = if up land 0xffff = up then let s = String.create 2 in LittleEndian.str_int16 s 0 up; - s + (Bytes.to_string s) else if up land 0xffffff = up then let s = String.create 3 in LittleEndian.str_int24 s 0 up; - s + (Bytes.to_string s) else let s = String.create 4 in LittleEndian.str_int s 0 up; - s + (Bytes.to_string s) in GGEP.GGEP ("DU", s) ) list @@ -384,4 +384,4 @@ let print list = | GGEP_DU_uptime up -> lprintf " Uptime %d seconds\n" up ) list - \ No newline at end of file + diff --git a/src/utils/net/http_client.ml b/src/utils/net/http_client.ml index baab86ca..4ce6e71a 100644 --- a/src/utils/net/http_client.ml +++ b/src/utils/net/http_client.ml @@ -124,22 +124,22 @@ let make_full_request r = end; begin match r.req_proxy with | Some (_,_,Some (login,password)) -> - Printf.bprintf res "Proxy-Authorization: Basic %s\n" (Base64.encode (login ^ ":" ^ password)) + Printf.bprintf res "Proxy-Authorization: Basic %s\n" (Bytes.to_string (Base64.encode (login ^ ":" ^ password))) | _ -> () end; if url.user <> "" then begin let userpass = Printf.sprintf "%s:%s" url.user url.passwd in - Printf.bprintf res "Authorization: Basic %s\r\n" (Base64.encode userpass) + Printf.bprintf res "Authorization: Basic %s\r\n" (Bytes.to_string (Base64.encode userpass)) end; if is_real_post then begin let post = Buffer.create 80 in let rec make_post = function | [] -> assert false | [a, b] -> - Printf.bprintf post "%s%c%s" (Url.encode a) '=' (Url.encode b) + Printf.bprintf post "%s%c%s" (Url.encode_to_string a) '=' (Url.encode_to_string b) | (a,b)::l -> Printf.bprintf post "%s%c%s%c" - (Url.encode a) '=' (Url.encode b) '&'; + (Url.encode_to_string a) '=' (Url.encode_to_string b) '&'; make_post l in make_post args; Printf.bprintf res "Content-Type: application/x-www-form-urlencoded\r\nContent-Length: %d\r\n\r\n%s" diff --git a/src/utils/net/http_server.ml b/src/utils/net/http_server.ml index 3a33102c..2fc06406 100644 --- a/src/utils/net/http_server.ml +++ b/src/utils/net/http_server.ml @@ -797,13 +797,13 @@ let request_handler config sock nread = let c = (Bytes.get b.buf (i+1)) in if c = '\n' then let len = i + 2 - b.pos in - let header = Bytes.sub b.buf b.pos len in + let header = Bytes.to_string (Bytes.sub b.buf b.pos len) in buf_used b len; manage config sock header else if c = '\r' && i <= end_pos - 3 && Bytes.get b.buf (i+2) = '\n' then let len = i + 3 - b.pos in - let header = Bytes.sub b.buf b.pos len in + let header = Bytes.to_string (Bytes.sub b.buf b.pos len) in buf_used b len; manage config sock header else diff --git a/src/utils/net/littleEndian.ml b/src/utils/net/littleEndian.ml index 08b101f7..70d6ba43 100644 --- a/src/utils/net/littleEndian.ml +++ b/src/utils/net/littleEndian.ml @@ -88,9 +88,6 @@ let str_int s pos i = s.[pos+2] <- char_of_int ((i lsr 16) land 255); s.[pos+3] <- char_of_int ((i lsr 24) land 255) -let str_int_bytes s pos i = - str_int (Bytes.unsafe_to_string s) pos i - let get_int s pos = let c1 = get_uint8 s pos in let c2 = get_uint8 s (pos+1) in diff --git a/src/utils/net/mailer.ml b/src/utils/net/mailer.ml index 8777da94..d825700b 100644 --- a/src/utils/net/mailer.ml +++ b/src/utils/net/mailer.ml @@ -73,8 +73,10 @@ let rfc2047_encode h encoding s = copy ending; Buffer.contents buf -let send oc s = Printf.fprintf oc "%s\r\n" s; flush oc -let send1 oc s p = Printf.fprintf oc "%s %s\r\n" s p; flush oc +let send_bytes oc s = Printf.fprintf oc "%a\r\n" output_bytes s; flush oc +let send_string oc s = Printf.fprintf oc "%s\r\n" s; flush oc +let send1_bytes oc s p = Printf.fprintf oc "%a %a\r\n" output_bytes s output_bytes p; flush oc +let send1_string oc s p = Printf.fprintf oc "%s %s\r\n" s p; flush oc let simple_connect hostname port = let s = socket PF_INET SOCK_STREAM 0 in @@ -146,20 +148,20 @@ let string_xor s1 s2 = assert (Bytes.length s1 = Bytes.length s2); let s = Bytes.create (Bytes.length s1) in for i = 0 to Bytes.length s - 1 do - s.[i] <- Char.chr (Char.code s1.[i] lxor Char.code s2.[i]); + s.[i] <- Char.chr (Char.code (Bytes.get s1 i) lxor Char.code (Bytes.get s2 i)); done; s (* HMAC-MD5, RFC 2104 *) let hmac_md5 = - let ipad = String.make 64 '\x36' in - let opad = String.make 64 '\x5C' in + let ipad = Bytes.make 64 '\x36' in + let opad = Bytes.make 64 '\x5C' in let md5 s = Md5.direct_to_string (Md5.string s) in fun secret challenge -> let secret = if String.length secret > 64 then md5 secret else secret in let k = Bytes.make 64 '\x00' in String.blit secret 0 k 0 (String.length secret); - md5 (string_xor k opad ^ md5 (string_xor k ipad ^ challenge)) + md5 (Bytes.to_string (string_xor k opad) ^ md5 (Bytes.to_string(string_xor k ipad) ^ challenge)) let sendmail smtp_server smtp_port new_style mail = (* a completely synchronous function (BUG) *) @@ -192,63 +194,63 @@ let sendmail smtp_server smtp_port new_style mail = try if read_response ic <> 220 then bad_response (); - send1 oc "EHLO" (gethostname ()); + send1_string oc "EHLO" (gethostname ()); if read_response_auth ic <> 250 then bad_response (); if mail.smtp_login <> "" then begin if !auth_cram_enabled then (* prefer CRAM-MD5 *) begin - send oc "AUTH CRAM-MD5"; + send_string oc "AUTH CRAM-MD5"; match get_response ic with | (334,true,s) -> (* RFC 2195 *) - let digest = hmac_md5 mail.smtp_password (Base64.decode s) in - send oc (Base64.encode (Printf.sprintf "%s %s" mail.smtp_login digest)); + let digest = hmac_md5 mail.smtp_password (Bytes.to_string (Base64.decode s)) in + send_bytes oc (Base64.encode (Printf.sprintf "%s %s" mail.smtp_login digest)); if read_response ic <> 235 then bad_response () | _ -> bad_response () end else if !auth_login_enabled then begin - send oc "AUTH LOGIN"; + send_string oc "AUTH LOGIN"; if read_response ic <> 334 then bad_response (); - send oc (Base64.encode mail.smtp_login); + send_bytes oc (Base64.encode mail.smtp_login); if read_response ic <> 334 then bad_response (); - send oc (Base64.encode mail.smtp_password); + send_bytes oc (Base64.encode mail.smtp_password); if read_response ic <> 235 then bad_response () end else if !auth_plain_enabled then begin let auth = Printf.sprintf "\x00%s\x00%s" mail.smtp_login mail.smtp_password in - send1 oc "AUTH PLAIN" (Base64.encode auth); + send1_bytes oc (Bytes.of_string "AUTH PLAIN") (Base64.encode auth); if read_response ic <> 235 then bad_response () end end; - send1 oc "MAIL FROM:" (mail_address new_style (canon_addr mail.mail_from)); + send1_string oc "MAIL FROM:" (mail_address new_style (canon_addr mail.mail_from)); if read_response ic <> 250 then bad_response (); List.iter begin fun address -> - send1 oc "RCPT TO:" (mail_address new_style (canon_addr address)); + send1_string oc "RCPT TO:" (mail_address new_style (canon_addr address)); if read_response ic <> 250 then bad_response (); end mail.mail_to; - send oc "DATA"; + send_string oc "DATA"; if read_response ic <> 354 then bad_response (); let body = make_mail mail new_style in - send oc body; - send oc "."; + send_string oc body; + send_string oc "."; if read_response ic <> 250 then bad_response (); - send oc "QUIT"; + send_string oc "QUIT"; if read_response ic <> 221 then bad_response (); close_out oc; with e -> - send oc "QUIT"; + send_string oc "QUIT"; if read_response ic <> 221 then bad_response (); close_out oc; raise e diff --git a/src/utils/net/tcpBufferedSocket.ml b/src/utils/net/tcpBufferedSocket.ml index ea637077..d73ef2c1 100644 --- a/src/utils/net/tcpBufferedSocket.ml +++ b/src/utils/net/tcpBufferedSocket.ml @@ -1057,12 +1057,12 @@ let set_reader t f = let rstr_end = Bytes.index_from b.buf (rstr_pos+1) '\n' in let rstr = Bytes.sub b.buf (rstr_pos+1) (rstr_end-rstr_pos-1) in lprintf "From proxy for %s: %s %s\n" - (Ip.to_string sock.host) rcode rstr; + (Ip.to_string sock.host) (Bytes.unsafe_to_string rcode) (Bytes.unsafe_to_string rstr); rcode, rstr, rstr_end with _ -> - "", "", 0 + Bytes.empty, Bytes.empty, 0 in - (match rcode with + (match (Bytes.to_string rcode) with "200" -> (*lprintf "Connect to client via proxy ok\n";*) let pos = Bytes.index_from b.buf (rstr_end+1) '\n' in let used = pos + 1 - b.pos in @@ -1349,7 +1349,7 @@ let connect token name host port handler = Printf.bprintf buf "Proxy-Connection: Keep-Alive\n"; begin match proxy_auth with | Some (login,password) -> - Printf.bprintf buf "Proxy-Authorization: Basic %s\n" (Base64.encode (login ^ ":" ^ password)) + Printf.bprintf buf "Proxy-Authorization: Basic %s\n" (Bytes.to_string (Base64.encode (login ^ ":" ^ password))) | None -> () end; Printf.bprintf buf "User-Agent: MLdonkey/%s\n" Autoconf.current_version; @@ -1479,11 +1479,11 @@ let value_handler f sock nread = let b = buf sock in try while b.len >= 5 do - let msg_len = get_int b.buf (b.pos+1) in + let msg_len = get_int_bytes b.buf (b.pos+1) in if b.len >= 5 + msg_len then begin let s = Bytes.sub b.buf (b.pos+5) msg_len in - let t = Marshal.from_string s 0 in + let t = Marshal.from_bytes s 0 in buf_used b (msg_len + 5); f t sock; () From 32e3507316b7e4355e2764784d07d1033916c61e Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 14:12:49 +0200 Subject: [PATCH 29/69] Fixed lexer. --- src/networks/direct_connect/dcInteractive.ml | 2 +- src/networks/direct_connect/dcShared.ml | 4 ++-- src/utils/cdk/bzlib.ml | 2 +- src/utils/cdk/genlex2.ml | 14 ++++++-------- src/utils/lib/options.ml4 | 2 +- 5 files changed, 11 insertions(+), 13 deletions(-) diff --git a/src/networks/direct_connect/dcInteractive.ml b/src/networks/direct_connect/dcInteractive.ml index ce31df29..87e252b8 100644 --- a/src/networks/direct_connect/dcInteractive.ml +++ b/src/networks/direct_connect/dcInteractive.ml @@ -105,7 +105,7 @@ let parse_url url user group = let register_commands list = register_commands (List2.tail_map (fun (n,f,h) -> (n, "Direct Connect", f,h)) list) -let command l = String.concat "+" (List.map Url.encode l) +let command l = String.concat "+" (List.map Url.encode_to_string l) let td_command text title ?(blink=false) ?(target=`Output) cmd = Printf.sprintf diff --git a/src/networks/direct_connect/dcShared.ml b/src/networks/direct_connect/dcShared.ml index 3391452f..c132b2c3 100644 --- a/src/networks/direct_connect/dcShared.ml +++ b/src/networks/direct_connect/dcShared.ml @@ -125,7 +125,7 @@ let string_to_che3_to_file str filename = else wlen in let npos = pos + len in - Unix32.write file_fd (Int64.of_int pos) s pos len; + Unix32.write file_fd (Int64.of_int pos) (Bytes.of_string s) pos len; if npos < slen then write npos in write 0; @@ -180,7 +180,7 @@ let buffer_to_bz2_to_file buf filename = else slen in let npos = pos + len in - let str = Buffer.sub buf pos len in + let str = Bytes.of_string (Buffer.sub buf pos len) in Bzip2.output oc str 0 len; if npos < blen then compress npos in compress 0; diff --git a/src/utils/cdk/bzlib.ml b/src/utils/cdk/bzlib.ml index 37800080..afc38c9a 100644 --- a/src/utils/cdk/bzlib.ml +++ b/src/utils/cdk/bzlib.ml @@ -31,7 +31,7 @@ external compress_end: stream -> unit = "camlzip_bzCompressEnd" external decompress_init: int -> bool -> stream = "camlzip_bzDecompressInit" external decompress: - stream -> string -> int -> int -> string -> int -> int -> bool * int * int + stream -> bytes -> int -> int -> bytes -> int -> int -> bool * int * int = "camlzip_bzDecompress_bytecode" "camlzip_bzDecompress" external decompress_end: stream -> unit = "camlzip_bzDecompressEnd" diff --git a/src/utils/cdk/genlex2.ml b/src/utils/cdk/genlex2.ml index 9c469e5d..d2f00575 100644 --- a/src/utils/cdk/genlex2.ml +++ b/src/utils/cdk/genlex2.ml @@ -28,7 +28,7 @@ type token = (* The string buffering machinery *) -let initial_buffer = String.make 32 '\000' +let initial_buffer = Buffer.create 32 let buffer = ref initial_buffer let bufpos = ref 0 @@ -36,16 +36,14 @@ let bufpos = ref 0 let reset_buffer () = buffer := initial_buffer; bufpos := 0 let store c = - if !bufpos >= String.length !buffer then - begin - let newbuffer = String.make (2 * !bufpos) '\000' in - String.blit !buffer 0 (Bytes.of_string newbuffer) 0 !bufpos; buffer := newbuffer - end; - String.set (Bytes.of_string !buffer) !bufpos c; + Buffer.add_char !buffer c; incr bufpos let get_string () = - let s = String.sub !buffer 0 !bufpos in buffer := initial_buffer; s + let s = Buffer.sub !buffer 0 !bufpos in + Buffer.clear !buffer; + bufpos := 0; + s (* The lexer *) diff --git a/src/utils/lib/options.ml4 b/src/utils/lib/options.ml4 index 5095d2b8..ca516834 100644 --- a/src/utils/lib/options.ml4 +++ b/src/utils/lib/options.ml4 @@ -208,7 +208,7 @@ and parse_option = parser | [< 'Int i >] -> IntValue i | [< 'Float f >] -> FloatValue f | [< 'Kwd "@"; 'Int i; v = parse_once_value i >] -> OnceValue v -| [< 'Char c >] -> StringValue (let s = String.make 1 c in s) +| [< 'Char c >] -> StringValue (let s = String.create 1 in s.[0] <- c; Bytes.to_string s) | [< 'Kwd "["; v = parse_list [] >] -> List v | [< 'Kwd "("; v = parse_list [] >] -> List v From 4e80f519528138c37a95c7577c994e2edcb1af3e Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 14:19:31 +0200 Subject: [PATCH 30/69] Minor change. --- src/daemon/common/commonFile.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/daemon/common/commonFile.ml b/src/daemon/common/commonFile.ml index ffaf30fa..630d006d 100644 --- a/src/daemon/common/commonFile.ml +++ b/src/daemon/common/commonFile.ml @@ -895,7 +895,7 @@ parent.fstatus.location.href='submit?q=chgrp+'+v+'+%d'; let file_print_ed2k_link filename filesize md4hash = if md4hash = Md4.null then "" else Printf.sprintf "ed2k://|file|%s|%s|%s|/" - (Bytes.to_string (Url.encode filename)) (Int64.to_string filesize) (Md4.to_string md4hash) + (Url.encode_to_string filename) (Int64.to_string filesize) (Md4.to_string md4hash) (*************************************************************************) (* *) From 25745f32fbb999eb70878a21be3025d9620dae70 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 14:21:36 +0200 Subject: [PATCH 31/69] Minor change. --- src/daemon/common/commonInteractive.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/daemon/common/commonInteractive.ml b/src/daemon/common/commonInteractive.ml index 33c70edd..70d6860e 100644 --- a/src/daemon/common/commonInteractive.ml +++ b/src/daemon/common/commonInteractive.ml @@ -356,7 +356,7 @@ let mail_for_completed_file file = incoming.shdir_dirname (if (file_owner file).user_commit_dir = "" then "" else Printf.sprintf "/%s" (file_owner file).user_commit_dir) - (Bytes.to_string (Url.encode (file_best_name file))) + (Url.encode_to_string (file_best_name file)) in let line5 = if !!auto_commit then "" else From f12c7ffc56f0d03897ec64d74705116caace672e Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 14:48:52 +0200 Subject: [PATCH 32/69] Minor change. --- src/daemon/driver/driverCommands.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/daemon/driver/driverCommands.ml b/src/daemon/driver/driverCommands.ml index 49d24162..16dec6be 100644 --- a/src/daemon/driver/driverCommands.ml +++ b/src/daemon/driver/driverCommands.ml @@ -1677,12 +1677,12 @@ let _ = if use_html_mods o then custom_commands := !custom_commands @ [ ( "bu bbig", name, - Printf.sprintf "mSub('output','custom=%s')" (Bytes.to_string (Url.encode name)), + Printf.sprintf "mSub('output','custom=%s')" (Url.encode_to_string name), name ) ; ] else Printf.bprintf buf "\\ %s \\\n" - (Bytes.to_string (Url.encode name)) name; + (Url.encode_to_string name) name; end else From 035513648d731640cdb25afc2ae48f6bb8611d2f Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 16:41:38 +0200 Subject: [PATCH 33/69] Use a specific function to compare bytes and string literal. --- src/daemon/common/commonMultimedia.ml | 5 ++--- src/utils/lib/misc.ml | 3 +++ 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/daemon/common/commonMultimedia.ml b/src/daemon/common/commonMultimedia.ml index 46ccd69d..0094a7e3 100644 --- a/src/daemon/common/commonMultimedia.ml +++ b/src/daemon/common/commonMultimedia.ml @@ -223,15 +223,14 @@ let get_theora_cs n = (* page_seek *) (* *) (**********************************************************************************) -let ogg_bytes = Bytes.of_string "OggS" -let is_ogg_header s = (s = ogg_bytes) + let rec page_seek ic s pos = if (pos_in ic - pos) > 255 then failwith "No more OGG Stream Header" else begin really_input ic s 0 4; seek_in ic (pos_in ic - 3); - if is_ogg_header s + if Misc.bytes_equal_string s "OggS" then seek_in ic (pos_in ic + 3) else page_seek ic s pos end diff --git a/src/utils/lib/misc.ml b/src/utils/lib/misc.ml index c8800b11..e6284243 100644 --- a/src/utils/lib/misc.ml +++ b/src/utils/lib/misc.ml @@ -117,3 +117,6 @@ let archive_extract filename archive_type = | "bz2" -> Misc2.bz2_extract filename | "gz" -> gz_extract filename | _ -> failwith (Printf.sprintf "wrong archive type %s" archive_type) + +let bytes_equal_string (b : Bytes.t) (s : string) = + String.equal (Bytes.unsafe_to_string b) s From 23331152c9e754612d764d89f9fc569cfb978541 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 18:21:19 +0200 Subject: [PATCH 34/69] Improvements. --- src/daemon/common/commonMultimedia.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/daemon/common/commonMultimedia.ml b/src/daemon/common/commonMultimedia.ml index 0094a7e3..0fb48dc8 100644 --- a/src/daemon/common/commonMultimedia.ml +++ b/src/daemon/common/commonMultimedia.ml @@ -474,7 +474,7 @@ let search_info_avi ic = try (* pos: 0 *) let s = input_string4 ic in - if s <> Bytes.of_string "RIFF" then failwith "Not an AVI file (RIFF absent)"; + if not (Misc.bytes_equal_string s "RIFF") then failwith "Not an AVI file (RIFF absent)"; (* pos: 4 *) let size = input_int32 ic in @@ -484,11 +484,11 @@ let search_info_avi ic = (* pos: 8 *) let s = input_string4 ic in - if s <> Bytes.of_string "AVI " then failwith "Not an AVI file (AVI absent)"; + if not (Misc.bytes_equal_string s "AVI ") then failwith "Not an AVI file (AVI absent)"; (* pos: 12 *) let s = input_string4 ic in - if s <> Bytes.of_string "LIST" then failwith "Not an AVI file (LIST absent)"; + if not (Misc.bytes_equal_string s "LIST") then failwith "Not an AVI file (LIST absent)"; (* position 16 *) let rec iter_list pos end_pos = @@ -512,8 +512,8 @@ let search_info_avi ic = "hdrl" -> (* lprintf "HEADER\n"; *) - let s = Bytes.to_string (input_string4 ic) in - if s <> "avih" then failwith "Bad AVI file (avih absent)"; + let s = input_string4 ic in + if not (Misc.bytes_equal_string s "avih") then failwith "Bad AVI file (avih absent)"; (* pos: pos + 12 *) let main_header_len = 52 in @@ -544,7 +544,7 @@ let search_info_avi ic = ignore (input_string4 ic); - let fccType = Bytes.to_string (input_string4 ic) in + let fccType = input_string4 ic in let fccHandler = Bytes.to_string (input_string4 ic) in let _dwFlags = input_int32 ic in (* Contains AVITF_* flags *) let _wPriority = input_int16 ic in @@ -562,7 +562,7 @@ let search_info_avi ic = let rcFrame_dx = input_int16 ic in let rcFrame_dy = input_int16 ic in - if fccType = "vids" then + if Misc.bytes_equal_string fccType "vids" then raise (FormatFound (AVI { avi_codec = fccHandler; avi_width = rcFrame_dx; From a7052136fee69eda19598ec764dccad2a85fc8f6 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 18:43:49 +0200 Subject: [PATCH 35/69] Use bytes in gzip implementation. --- src/daemon/driver/driverControlers.ml | 2 +- src/utils/cdk/zlib2.ml | 9 ++++++--- src/utils/cdk/zlib2.mli | 3 ++- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/daemon/driver/driverControlers.ml b/src/daemon/driver/driverControlers.ml index 5009b6f5..6bc4909e 100644 --- a/src/daemon/driver/driverControlers.ml +++ b/src/daemon/driver/driverControlers.ml @@ -1565,7 +1565,7 @@ let http_handler o t r = in r.reply_content <- if !http_file_type <> BIN && !!html_use_gzip then - Zlib2.gzip_string (Bytes.of_string s) + Bytes.to_string (Zlib2.gzip_string s) else s let http_options = { diff --git a/src/utils/cdk/zlib2.ml b/src/utils/cdk/zlib2.ml index 4813ba26..87489dc5 100644 --- a/src/utils/cdk/zlib2.ml +++ b/src/utils/cdk/zlib2.ml @@ -35,8 +35,8 @@ let compress_string ?(level = 6) inbuf = res (* header info from camlzip/gpl *) -let gzip_string ?(level = 6) inbuf = - if Bytes.length inbuf <= 0 then "" else +let gzip_bytes ?(level = 6) inbuf = + if Bytes.length inbuf <= 0 then Bytes.empty else begin let zs = deflate_init level false in let out_crc = ref Int32.zero in @@ -78,9 +78,12 @@ let gzip_string ?(level = 6) inbuf = Buffer.add_bytes buf res; write_int32 buf !out_crc; write_int32 buf (Int32.of_int (Bytes.length inbuf)); - Buffer.contents buf + Buffer.to_bytes buf end +let gzip_string ?(level = 6) instr = + gzip_bytes ~level:level (Bytes.of_string instr) + let uncompress_string2 inbuf = let zs = inflate_init true in let rec uncompr inpos outbuf outpos = diff --git a/src/utils/cdk/zlib2.mli b/src/utils/cdk/zlib2.mli index 5f985937..01eaee83 100644 --- a/src/utils/cdk/zlib2.mli +++ b/src/utils/cdk/zlib2.mli @@ -2,6 +2,7 @@ val uncompress_string : string -> string val uncompress_string2 : bytes -> bytes val compress_string : ?level:int -> bytes -> bytes -val gzip_string : ?level:int -> bytes -> string +val gzip_string : ?level:int -> string -> bytes +val gzip_bytes : ?level:int -> bytes -> bytes val zlib_version_num : unit -> string From 830a24c4e0d0379c9e1679d5e147fac1b48ded91 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 19:13:06 +0200 Subject: [PATCH 36/69] Minor change. --- src/utils/mp3tagui/mp3_info.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/mp3tagui/mp3_info.ml b/src/utils/mp3tagui/mp3_info.ml index ae7ac5da..f0399304 100644 --- a/src/utils/mp3tagui/mp3_info.ml +++ b/src/utils/mp3tagui/mp3_info.ml @@ -80,7 +80,7 @@ let get_xing_header ic header = seek_in ic (pos_in ic + offset); let buf = String.create 4 in really_input ic buf 0 4; - if buf <> (Bytes.of_string "Xing") then raise Not_found; + if not (Misc.bytes_equal_string buf "Xing") then raise Not_found; let flags = read_i4 ic in (* 3 = FRAMES_FLAG | BYTES_FLAG *) if flags land 3 <> 3 then raise Not_found; From 0b7014e5c1f1ff57e0830fae90a14be70bb1ecab Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 19:18:35 +0200 Subject: [PATCH 37/69] Improvement. --- src/networks/donkey/donkeyFiles.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/networks/donkey/donkeyFiles.ml b/src/networks/donkey/donkeyFiles.ml index 1a187cb4..5e83dbb2 100644 --- a/src/networks/donkey/donkeyFiles.ml +++ b/src/networks/donkey/donkeyFiles.ml @@ -98,7 +98,7 @@ module NewUpload = struct impl.impl_shared_uploaded <- impl.impl_shared_uploaded ++ uploaded); - write_string sock (Bytes.to_string upload_buffer); + write sock upload_buffer; check_end_upload c sock with | End_of_file -> lprintf_nl "Can not send file %s to %s, file removed?" From 20a626609cc359df0ccd4b39a9a70366cfb677dd Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 19:29:49 +0200 Subject: [PATCH 38/69] Minor change. --- src/networks/donkey/donkeyClient.ml | 2 +- src/networks/fileTP/fileTPHTTP.ml | 2 +- src/utils/net/base64.ml | 2 ++ src/utils/net/base64.mli | 1 + src/utils/net/http_client.ml | 4 ++-- src/utils/net/tcpBufferedSocket.ml | 2 +- 6 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/networks/donkey/donkeyClient.ml b/src/networks/donkey/donkeyClient.ml index 999d4ebe..234b3406 100644 --- a/src/networks/donkey/donkeyClient.ml +++ b/src/networks/donkey/donkeyClient.ml @@ -1931,7 +1931,7 @@ end else *) log_chat_message cip (client_num c) c.client_name s; | M.EmuleCaptchaReq t -> - let b64data = Bytes.to_string (Base64.encode t) in + let b64data = Base64.encode_to_string t in let cip = string_of_client_addr c in log_chat_message cip (client_num c) c.client_name ("data:image/bmp;base64," ^ b64data) diff --git a/src/networks/fileTP/fileTPHTTP.ml b/src/networks/fileTP/fileTPHTTP.ml index cd267338..e06d001f 100644 --- a/src/networks/fileTP/fileTPHTTP.ml +++ b/src/networks/fileTP/fileTPHTTP.ml @@ -65,7 +65,7 @@ let http_send_range_request c range sock d = Printf.bprintf buf "Connection: Keep-Alive\r\n"; if url.Url.user <> "" then begin let userpass = Printf.sprintf "%s:%s" url.Url.user url.Url.passwd in - let encoded = Bytes.to_string (Base64.encode userpass) in + let encoded = Base64.encode_to_string userpass in Printf.bprintf buf "Authorization: Basic %s\r\n" encoded end; Printf.bprintf buf "\r\n"; diff --git a/src/utils/net/base64.ml b/src/utils/net/base64.ml index 3f1d8ed7..24f4a295 100644 --- a/src/utils/net/base64.ml +++ b/src/utils/net/base64.ml @@ -142,6 +142,8 @@ let encode_with_options b64 equal s pos len linelen crlf = let encode s = encode_with_options rfc_pattern '=' s 0 (String.length s) 0 false;; +let encode_to_string s = + Bytes.to_string (encode s) let encode_substring s pos len = encode_with_options rfc_pattern '=' s pos len 0 false;; diff --git a/src/utils/net/base64.mli b/src/utils/net/base64.mli index 1c2355f6..3c329706 100644 --- a/src/utils/net/base64.mli +++ b/src/utils/net/base64.mli @@ -1,4 +1,5 @@ val encode : string -> bytes +val encode_to_string : string -> string val encode_substring : string -> int -> int -> bytes val decode : string -> bytes diff --git a/src/utils/net/http_client.ml b/src/utils/net/http_client.ml index 4ce6e71a..9954c768 100644 --- a/src/utils/net/http_client.ml +++ b/src/utils/net/http_client.ml @@ -124,12 +124,12 @@ let make_full_request r = end; begin match r.req_proxy with | Some (_,_,Some (login,password)) -> - Printf.bprintf res "Proxy-Authorization: Basic %s\n" (Bytes.to_string (Base64.encode (login ^ ":" ^ password))) + Printf.bprintf res "Proxy-Authorization: Basic %s\n" (Base64.encode_to_string (login ^ ":" ^ password)) | _ -> () end; if url.user <> "" then begin let userpass = Printf.sprintf "%s:%s" url.user url.passwd in - Printf.bprintf res "Authorization: Basic %s\r\n" (Bytes.to_string (Base64.encode userpass)) + Printf.bprintf res "Authorization: Basic %s\r\n" (Base64.encode_to_string userpass) end; if is_real_post then begin let post = Buffer.create 80 in diff --git a/src/utils/net/tcpBufferedSocket.ml b/src/utils/net/tcpBufferedSocket.ml index d73ef2c1..616381f3 100644 --- a/src/utils/net/tcpBufferedSocket.ml +++ b/src/utils/net/tcpBufferedSocket.ml @@ -1349,7 +1349,7 @@ let connect token name host port handler = Printf.bprintf buf "Proxy-Connection: Keep-Alive\n"; begin match proxy_auth with | Some (login,password) -> - Printf.bprintf buf "Proxy-Authorization: Basic %s\n" (Bytes.to_string (Base64.encode (login ^ ":" ^ password))) + Printf.bprintf buf "Proxy-Authorization: Basic %s\n" (Base64.encode_to_string (login ^ ":" ^ password)) | None -> () end; Printf.bprintf buf "User-Agent: MLdonkey/%s\n" Autoconf.current_version; From c19f8431ed7dad1f63775387a4cc997999706b72 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 20:08:54 +0200 Subject: [PATCH 39/69] Avoid copies. --- src/networks/donkey/donkeyProtoCom.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/networks/donkey/donkeyProtoCom.ml b/src/networks/donkey/donkeyProtoCom.ml index d7d00094..baf72a56 100644 --- a/src/networks/donkey/donkeyProtoCom.ml +++ b/src/networks/donkey/donkeyProtoCom.ml @@ -350,7 +350,7 @@ let server_send_share compressed sock msg = in let len = Bytes.length s - 5 in str_int s 1 len; - write_string sock (Bytes.to_string s) + write sock s 0 (Bytes.length s) let client_send_files sock msg = let max_len = !!client_buffer_size - 100 - @@ -368,7 +368,7 @@ let client_send_files sock msg = let len = Bytes.length s - 5 in str_int s 1 len; str_int s 6 nfiles; - write_string sock (Bytes.to_string s) + write sock s 0 (Bytes.length s) let client_send_dir sock dir files = let max_len = !!client_buffer_size - 100 - @@ -389,7 +389,7 @@ let client_send_dir sock dir files = str_int s 1 len; str_int s (pos-4) nfiles; end; - write_string sock (Bytes.to_string s) + write sock s 0 (Bytes.length s) let udp_server_send s t = udp_send (get_udp_sock ()) s.server_ip (s.server_port+4) t From c45e0f14e50246326037f6407cff4fc090f0c27f Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 20:14:38 +0200 Subject: [PATCH 40/69] Performance improvement. --- src/networks/donkey/donkeyClient.ml | 3 ++- src/networks/donkey/donkeyFiles.ml | 6 +++--- src/networks/donkey/donkeyProtoCom.ml | 5 +++-- src/networks/donkey/donkeyProtoCom.mli | 2 +- 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/networks/donkey/donkeyClient.ml b/src/networks/donkey/donkeyClient.ml index 234b3406..77503ea5 100644 --- a/src/networks/donkey/donkeyClient.ml +++ b/src/networks/donkey/donkeyClient.ml @@ -2375,7 +2375,8 @@ let read_first_message overnet server cc m sock = porttest_sock := Some sock; set_closer sock (fun _ _ -> porttest_sock := None); set_lifetime sock 30.; - write_string sock (client_msg_to_string (emule_proto ()) m); + let buff = client_msg_to_string (emule_proto ()) m in + write sock buff 0 (Bytes.length buff); None | _ -> diff --git a/src/networks/donkey/donkeyFiles.ml b/src/networks/donkey/donkeyFiles.ml index 5e83dbb2..84cca7b7 100644 --- a/src/networks/donkey/donkeyFiles.ml +++ b/src/networks/donkey/donkeyFiles.ml @@ -84,9 +84,9 @@ module NewUpload = struct } ) in let s = client_msg_to_string c.client_emule_proto msg in - let slen = String.length s in + let slen = Bytes.length s in let upload_buffer = String.create (slen + len_int) in - String.blit s 0 upload_buffer 0 slen; + Bytes.blit s 0 upload_buffer 0 slen; DonkeyProtoCom.new_string msg upload_buffer; Unix32.read (file_fd file) begin_pos upload_buffer slen len_int; let uploaded = Int64.of_int len_int in @@ -98,7 +98,7 @@ module NewUpload = struct impl.impl_shared_uploaded <- impl.impl_shared_uploaded ++ uploaded); - write sock upload_buffer; + write sock upload_buffer 0 (Bytes.length upload_buffer); check_end_upload c sock with | End_of_file -> lprintf_nl "Can not send file %s to %s, file removed?" diff --git a/src/networks/donkey/donkeyProtoCom.ml b/src/networks/donkey/donkeyProtoCom.ml index baf72a56..137f4e26 100644 --- a/src/networks/donkey/donkeyProtoCom.ml +++ b/src/networks/donkey/donkeyProtoCom.ml @@ -46,7 +46,7 @@ let client_msg_to_string emule_version msg = let len = Bytes.length s - 5 in s.[0] <- char_of_int magic; str_int s 1 len; - (Bytes.to_string s) + s let server_msg_to_string msg = Buffer.reset buf; @@ -73,7 +73,8 @@ let server_send sock m = write_string sock (server_msg_to_string m) let direct_client_sock_send emule_version sock m = - write_string sock (client_msg_to_string emule_version m) + let buff = client_msg_to_string emule_version m in + write sock buff 0 (Bytes.length buff) let client_send c m = let emule_version = c.client_emule_proto in diff --git a/src/networks/donkey/donkeyProtoCom.mli b/src/networks/donkey/donkeyProtoCom.mli index c1309ec4..eb45da59 100644 --- a/src/networks/donkey/donkeyProtoCom.mli +++ b/src/networks/donkey/donkeyProtoCom.mli @@ -64,7 +64,7 @@ val udp_basic_handler : UdpSocket.event -> unit val server_msg_to_string : DonkeyProtoServer.t -> string -val client_msg_to_string : emule_proto -> DonkeyProtoClient.t -> string +val client_msg_to_string : emule_proto -> DonkeyProtoClient.t -> bytes val direct_client_sock_send : emule_proto -> TcpBufferedSocket.t -> DonkeyProtoClient.t -> unit From 541dd70fe1fbf1860373b3561325952cea6fc1fb Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 6 Jun 2024 20:22:33 +0200 Subject: [PATCH 41/69] Performance improvement. --- src/networks/donkey/donkeyProtoCom.ml | 7 ++++--- src/networks/donkey/donkeyProtoCom.mli | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/networks/donkey/donkeyProtoCom.ml b/src/networks/donkey/donkeyProtoCom.ml index 137f4e26..a69bf5d1 100644 --- a/src/networks/donkey/donkeyProtoCom.ml +++ b/src/networks/donkey/donkeyProtoCom.ml @@ -63,14 +63,15 @@ let server_msg_to_string msg = let s = Buffer.to_bytes buf in let len = Bytes.length s - 5 in str_int s 1 len; - (Bytes.to_string s) + s let server_send sock m = (* lprintf "Message to server"; lprint_newline (); DonkeyProtoServer.print m; *) - write_string sock (server_msg_to_string m) + let buff = server_msg_to_string m in + write sock buff 0 (Bytes.length buff) let direct_client_sock_send emule_version sock m = let buff = client_msg_to_string emule_version m in @@ -88,7 +89,7 @@ let client_send c m = let servers_send socks m = let m = server_msg_to_string m in - List.iter (fun s -> write_string s m) socks + List.iter (fun s -> write s m 0 (Bytes.length m)) socks let client_handler2 c ff f = let msgs = ref 0 in diff --git a/src/networks/donkey/donkeyProtoCom.mli b/src/networks/donkey/donkeyProtoCom.mli index eb45da59..68f09800 100644 --- a/src/networks/donkey/donkeyProtoCom.mli +++ b/src/networks/donkey/donkeyProtoCom.mli @@ -63,7 +63,7 @@ val udp_basic_handler : (bytes -> UdpSocket.udp_packet -> unit) -> UdpSocket.t -> UdpSocket.event -> unit -val server_msg_to_string : DonkeyProtoServer.t -> string +val server_msg_to_string : DonkeyProtoServer.t -> bytes val client_msg_to_string : emule_proto -> DonkeyProtoClient.t -> bytes val direct_client_sock_send : emule_proto -> TcpBufferedSocket.t -> DonkeyProtoClient.t -> unit From 03c82ef349a84bc416f5038d2b3d1fd56940828a Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 02:00:31 +0200 Subject: [PATCH 42/69] Performance improvement. --- src/networks/donkey/donkeyImport.ml | 2 +- src/networks/donkey/donkeyOvernetImport.ml | 2 +- src/networks/donkey/donkeyProtoCom.ml | 2 +- src/networks/donkey/donkeyProtoKademlia.ml | 4 ++-- src/utils/net/anyEndian.ml | 5 ++++- 5 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/networks/donkey/donkeyImport.ml b/src/networks/donkey/donkeyImport.ml index 372490ea..a1177e26 100644 --- a/src/networks/donkey/donkeyImport.ml +++ b/src/networks/donkey/donkeyImport.ml @@ -37,7 +37,7 @@ let dump_file filename = let n = input ic s 0 20 in lprintf "pos = %d\n" !pos; if n = 0 then raise Exit; - dump (String.sub (Bytes.to_string s) 0 n); + dump_bytes (Bytes.sub s 0 n); pos := !pos + n; done with End_of_file | Exit -> ()) diff --git a/src/networks/donkey/donkeyOvernetImport.ml b/src/networks/donkey/donkeyOvernetImport.ml index bfecddbf..dd37013e 100644 --- a/src/networks/donkey/donkeyOvernetImport.ml +++ b/src/networks/donkey/donkeyOvernetImport.ml @@ -32,7 +32,7 @@ let dump_file filename = let n = input ic s 0 20 in lprintf "pos = %d\n" !pos; if n = 0 then raise Exit; - dump (String.sub (Bytes.to_string s) 0 n); + dump_bytes (Bytes.sub s 0 n); pos := !pos + n; done with End_of_file -> ()) diff --git a/src/networks/donkey/donkeyProtoCom.ml b/src/networks/donkey/donkeyProtoCom.ml index a69bf5d1..5ed9141d 100644 --- a/src/networks/donkey/donkeyProtoCom.ml +++ b/src/networks/donkey/donkeyProtoCom.ml @@ -186,7 +186,7 @@ let udp_basic_handler f sock event = int_of_char (Bytes.get pbuf 0) <> DonkeyOpenProtocol.udp_magic then begin if !verbose_unknown_messages then begin lprintf_nl "Received unknown UDP packet"; - dump (Bytes.to_string pbuf); + dump_bytes pbuf; end; end else begin let t = Bytes.sub pbuf 1 (len-1) in diff --git a/src/networks/donkey/donkeyProtoKademlia.ml b/src/networks/donkey/donkeyProtoKademlia.ml index 5d5d60bc..d7a6cc1d 100644 --- a/src/networks/donkey/donkeyProtoKademlia.ml +++ b/src/networks/donkey/donkeyProtoKademlia.ml @@ -411,7 +411,7 @@ module P = struct begin if !CommonOptions.verbose_unknown_messages then begin lprintf_nl "Received unknown UDP packet"; - dump (Bytes.to_string pbuf); + dump_bytes pbuf; end; raise Not_found @@ -493,7 +493,7 @@ module P = struct begin lprintf_nl "Error %s in udp_handler, dump of packet:" (Printexc2.to_string e); - dump (Bytes.to_string p.UdpSocket.udp_content); + dump_bytes p.UdpSocket.udp_content; lprint_newline () end ); diff --git a/src/utils/net/anyEndian.ml b/src/utils/net/anyEndian.ml index 283354fc..d3f44ad1 100644 --- a/src/utils/net/anyEndian.ml +++ b/src/utils/net/anyEndian.ml @@ -152,7 +152,7 @@ let dump_ascii s = let buf = Buffer.create 1000 in bdump_ascii buf s; lprintf "%s" (Buffer.contents buf) - + let bdump_dec buf s = let len = String.length s in Printf.bprintf buf "dec: ["; @@ -199,3 +199,6 @@ let sdump s = let dump s = lprintf "%s" (sdump s) + +let dump_bytes s = + lprintf "%s" (sdump (Bytes.unsafe_to_string s)) From f4ace521ecc8f1b68b12307eae588db9f42d1ddb Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 02:15:47 +0200 Subject: [PATCH 43/69] Performance improvement. --- src/networks/donkey/donkeyInteractive.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/networks/donkey/donkeyInteractive.ml b/src/networks/donkey/donkeyInteractive.ml index 64cfefd0..f405aa0b 100644 --- a/src/networks/donkey/donkeyInteractive.ml +++ b/src/networks/donkey/donkeyInteractive.ml @@ -465,11 +465,12 @@ let import_config dirname = import_temp !temp_dir +let newline = Bytes.of_string "\n" let broadcast msg = - let s = msg ^ "\n" in - let len = String.length s in + let s = Bytes.cat msg newline in + let len = Bytes.length s in List.iter (fun sock -> - TcpBufferedSocket.write sock (Bytes.of_string s) 0 len + TcpBufferedSocket.write sock s 0 len ) !user_socks (* From 5f7e467b21e05ec5bd81f0f3175a3a425b1b2189 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 02:28:06 +0200 Subject: [PATCH 44/69] Performance improvement. --- src/utils/net/http_server.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/net/http_server.ml b/src/utils/net/http_server.ml index 2fc06406..06abce08 100644 --- a/src/utils/net/http_server.ml +++ b/src/utils/net/http_server.ml @@ -80,7 +80,7 @@ let decode64 s = if s.[len-1] = '=' then if s.[len-2] = '=' then 2 else 1 else 0 in - String.sub (Bytes.to_string res) 0 (len_res - nb_cut) + Bytes.sub res 0 (len_res - nb_cut) let debug = ref false @@ -282,7 +282,7 @@ let parse_head sock s = "authorization" -> let _, pass = String2.cut_at value ' ' in let pass = decode64 pass in - let login, pswd = String2.cut_at pass ':' in + let login, pswd = String2.cut_at (Bytes.to_string pass) ':' in { options with login = login; passwd = pswd } From 922c80d107f5ec2ba4a3d2f8258e972df4b6a6ea Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 02:52:17 +0200 Subject: [PATCH 45/69] Performance improvement. --- src/networks/donkey/donkeyProtoOvernet.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/networks/donkey/donkeyProtoOvernet.ml b/src/networks/donkey/donkeyProtoOvernet.ml index 16145452..49715e62 100644 --- a/src/networks/donkey/donkeyProtoOvernet.ml +++ b/src/networks/donkey/donkeyProtoOvernet.ml @@ -394,7 +394,7 @@ module Proto = struct begin if !verbose_unknown_messages then begin lprintf_nl "Received unknown UDP packet"; - dump (Bytes.to_string pbuf); + dump_bytes pbuf; end end else From f0861fed82d80d2eadc977c28ee02f73649a107c Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 02:54:25 +0200 Subject: [PATCH 46/69] Avoid conversion. --- src/networks/donkey/donkeyProtoOvernet.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/networks/donkey/donkeyProtoOvernet.ml b/src/networks/donkey/donkeyProtoOvernet.ml index 49715e62..b5d3d755 100644 --- a/src/networks/donkey/donkeyProtoOvernet.ml +++ b/src/networks/donkey/donkeyProtoOvernet.ml @@ -441,13 +441,13 @@ module Proto = struct Buffer.reset udp_buf; buf_int8 udp_buf 227; write udp_buf msg; - let s = Buffer.contents udp_buf in + let s = Buffer.to_bytes udp_buf in if !verbose_overnet then begin lprintf_nl "UDP to %s:%d op 0x%02X len %d type %s" - (Ip.to_string ip) port (get_uint8 s 1) (String.length s) (message_to_string msg); + (Ip.to_string ip) port (get_uint8_bytes s 1) (Bytes.length s) (message_to_string msg); end; - UdpSocket.write sock ping (Bytes.of_string s) ip port + UdpSocket.write sock ping s ip port with e -> lprintf_nl "Exception %s in udp_send" (Printexc2.to_string e) From b72c6da181f9e93baef2da066ce06f4b92fe1f8a Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 02:55:26 +0200 Subject: [PATCH 47/69] Avoid conversion. --- src/networks/donkey/donkeyProtoOvernet.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/networks/donkey/donkeyProtoOvernet.ml b/src/networks/donkey/donkeyProtoOvernet.ml index b5d3d755..303fbb51 100644 --- a/src/networks/donkey/donkeyProtoOvernet.ml +++ b/src/networks/donkey/donkeyProtoOvernet.ml @@ -420,7 +420,7 @@ module Proto = struct if !verbose_unknown_messages then begin lprintf_nl "Error %s in udp_handler, dump of packet:" (Printexc2.to_string e); - dump (Bytes.to_string p.UdpSocket.udp_content); + dump_bytes p.UdpSocket.udp_content; lprint_newline () end ); From 12265fdcbe58b949be1a8e95dbe271a3ec73c37f Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 03:05:33 +0200 Subject: [PATCH 48/69] Performance improvement. --- src/utils/lib/options.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/lib/options.ml4 b/src/utils/lib/options.ml4 index ca516834..c18137ff 100644 --- a/src/utils/lib/options.ml4 +++ b/src/utils/lib/options.ml4 @@ -208,7 +208,7 @@ and parse_option = parser | [< 'Int i >] -> IntValue i | [< 'Float f >] -> FloatValue f | [< 'Kwd "@"; 'Int i; v = parse_once_value i >] -> OnceValue v -| [< 'Char c >] -> StringValue (let s = String.create 1 in s.[0] <- c; Bytes.to_string s) +| [< 'Char c >] -> StringValue (String.make 1 c) | [< 'Kwd "["; v = parse_list [] >] -> List v | [< 'Kwd "("; v = parse_list [] >] -> List v From e1d628f9c59869846b219e1a47cdd5467b979861 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 03:09:50 +0200 Subject: [PATCH 49/69] Performance improvement. --- src/utils/lib/md4.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/utils/lib/md4.ml b/src/utils/lib/md4.ml index 4bc0c94e..24576b5d 100644 --- a/src/utils/lib/md4.ml +++ b/src/utils/lib/md4.ml @@ -115,13 +115,13 @@ module Base32 = struct let c = int5_of_char r.[i] in if bit < 3 then let x = c lsl (3-bit) in - s.[byte] <- char_of_int (int_of_char (Bytes.to_string s).[byte] lor x); + s.[byte] <- char_of_int (int_of_char (Bytes.get s byte) lor x); else let x = (c lsr (bit - 3)) land 0xff in - s.[byte] <- char_of_int (int_of_char (Bytes.to_string s).[byte] lor x); + s.[byte] <- char_of_int (int_of_char (Bytes.get s byte) lor x); if byte+1 < hash_length then let y = (c lsl (11 - bit)) land 0xff in - s.[byte+1] <- char_of_int (int_of_char (Bytes.to_string s).[byte+1] lor y); + s.[byte+1] <- char_of_int (int_of_char (Bytes.get s (byte+1)) lor y); done; (Bytes.to_string s) From 4fbc27d3c567563ba62835ab94d18c9a57cf112c Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 11:26:55 +0200 Subject: [PATCH 50/69] Performance improvement. --- src/networks/fasttrack/fasttrackPandora.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/networks/fasttrack/fasttrackPandora.ml b/src/networks/fasttrack/fasttrackPandora.ml index 808a87b4..2966054b 100644 --- a/src/networks/fasttrack/fasttrackPandora.ml +++ b/src/networks/fasttrack/fasttrackPandora.ml @@ -157,7 +157,7 @@ let parse_netname start_pos s ciphers = if pos < len then if (Bytes.get s pos) = '\000' then begin let netname = Bytes.sub s start_pos (pos-start_pos) in - lprintf "netname: [%s]\n" (String.escaped (Bytes.to_string netname)); + lprintf "netname: [%s]\n" (Bytes.unsafe_to_string (Bytes.escaped netname)); (* test_xinu s (pos+1) len 0x51L; *) parse_packets (pos+1) s ciphers From 4956e3cf376a92b83a94ea2919baba19cdc1d4b8 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 13:38:04 +0200 Subject: [PATCH 51/69] Fixed warning. --- src/networks/fasttrack/fasttrackNetwork.ml | 2 +- src/networks/fasttrack/fasttrackPandora.ml | 8 ++++---- src/networks/fasttrack/fasttrackProto.ml | 4 ++-- src/networks/fasttrack/fasttrackServers.ml | 9 ++++----- src/networks/fasttrack/fst_crypt_ml.c | 2 +- 5 files changed, 12 insertions(+), 13 deletions(-) diff --git a/src/networks/fasttrack/fasttrackNetwork.ml b/src/networks/fasttrack/fasttrackNetwork.ml index b792e58c..9a1c54ec 100644 --- a/src/networks/fasttrack/fasttrackNetwork.ml +++ b/src/networks/fasttrack/fasttrackNetwork.ml @@ -87,7 +87,7 @@ external get_cipher_from_packet : string -> int -> cipher -> unit external xor_ciphers : cipher -> cipher -> unit = "ml_xor_ciphers" external xor_ciphers2 : cipher -> cipher -> unit = "ml_xor_ciphers2" -external cipher_packet_set : cipher -> string -> int -> unit +external cipher_packet_set : cipher -> bytes -> int -> unit = "ml_cipher_packet_set" external cipher_packet_set_xored : cipher -> string -> int -> cipher -> unit = "ml_cipher_packet_set_xored" diff --git a/src/networks/fasttrack/fasttrackPandora.ml b/src/networks/fasttrack/fasttrackPandora.ml index 2966054b..c97726d0 100644 --- a/src/networks/fasttrack/fasttrackPandora.ml +++ b/src/networks/fasttrack/fasttrackPandora.ml @@ -242,15 +242,15 @@ let parse (s_out : string) (s_in : string) = ; begin - let s = String.make 8 '\000' in + let s = Bytes.make 8 '\000' in cipher_packet_set ciphers.out_cipher s 0; - lprintf "OUT CIPHER: [%s]\n" (String.escaped s); + lprintf "OUT CIPHER: [%s]\n" (Bytes.to_string (Bytes.escaped s)); end; begin - let s = String.make 8 '\000' in + let s = Bytes.make 8 '\000' in cipher_packet_set ciphers.in_cipher s 0; - lprintf "IN CIPHER: [%s]\n" (String.escaped s); + lprintf "IN CIPHER: [%s]\n" (Bytes.to_string (Bytes.escaped s)); end; ( diff --git a/src/networks/fasttrack/fasttrackProto.ml b/src/networks/fasttrack/fasttrackProto.ml index 81358d90..e779c65c 100644 --- a/src/networks/fasttrack/fasttrackProto.ml +++ b/src/networks/fasttrack/fasttrackProto.ml @@ -1889,9 +1889,9 @@ let check_primitives () = let cipher = create_cipher () in set_cipher cipher 123456789l 0x29; init_cipher cipher; - let s = String.make 12 '0' in + let s = Bytes.make 12 '0' in cipher_packet_set cipher s 0; - assert (s = "\007\091\205\021\110\233\135\1870000"); + assert (s = Bytes.of_string "\007\091\205\021\110\233\135\1870000"); (* lprintf "cipher_packet_set s = \"%s\"\n" (String.escaped s); *) let s = "123456789abcdefghijklm\233\234\235" in apply_cipher cipher s 0 (String.length s); diff --git a/src/networks/fasttrack/fasttrackServers.ml b/src/networks/fasttrack/fasttrackServers.ml index b5eb5a36..1fbf3b5f 100644 --- a/src/networks/fasttrack/fasttrackServers.ml +++ b/src/networks/fasttrack/fasttrackServers.ml @@ -251,14 +251,13 @@ let connect_server h = s.[3] <- '\043'; | Some f -> f s); - let ss = Bytes.to_string s in - cipher_packet_set out_cipher ss 4; + cipher_packet_set out_cipher s 4; if !verbose_msg_raw then begin - lprintf "SENDING %s\n" (String.escaped ss); - AnyEndian.dump ss; + lprintf "SENDING %s\n" (Bytes.to_string (Bytes.escaped s)); + AnyEndian.dump_bytes s; end; - write_string sock ss; + write sock s 0 (Bytes.length s); with _ -> disconnect_from_server nservers s Closed_connect_failed ) diff --git a/src/networks/fasttrack/fst_crypt_ml.c b/src/networks/fasttrack/fst_crypt_ml.c index ad1c266d..b7fe1db2 100755 --- a/src/networks/fasttrack/fst_crypt_ml.c +++ b/src/networks/fasttrack/fst_crypt_ml.c @@ -137,7 +137,7 @@ value ml_xor_ciphers2(value out_cipher_v, value in_cipher_v){ value ml_cipher_packet_set(value cipher_v, value s_v, value pos_v) { FSTCipher* cipher = (FSTCipher*) cipher_v; - char *s = String_val(s_v); + char *s = Bytes_val(s_v); int pos = Int_val(pos_v); ((unsigned int*)(s+pos))[0] = htonl(cipher->seed); From ca06b87d67967b7caf0a6a3e26445073bfaa4849 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 13:38:39 +0200 Subject: [PATCH 52/69] Fixed warning. --- src/utils/lib/magiclib_stub.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/lib/magiclib_stub.c b/src/utils/lib/magiclib_stub.c index a01e0eb5..4f101db7 100644 --- a/src/utils/lib/magiclib_stub.c +++ b/src/utils/lib/magiclib_stub.c @@ -45,8 +45,8 @@ static void raise_magic_failure(const char * msg) { - static value * exn = NULL; - if (exn == NULL) exn = caml_named_value("Magiclib.Failure"); + static const value* exn = NULL; + if (!exn) caml_named_value("Magiclib.Failure"); raise_with_string(*exn, (char *) msg); } From b1ba27af9bb0fa0006a962e2e6bc715bf5f31908 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 13:42:21 +0200 Subject: [PATCH 53/69] Fixed warning. --- src/utils/net/upnp_stubs.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/utils/net/upnp_stubs.c b/src/utils/net/upnp_stubs.c index 0be53d08..0cf2fc51 100644 --- a/src/utils/net/upnp_stubs.c +++ b/src/utils/net/upnp_stubs.c @@ -1015,7 +1015,7 @@ value ml_upnpAddMap(value m_enabled, value m_intPort, value m_extPort, value m_type, value m_notes) { ml_upnpmp_t map; - char *s = NULL; + const char *s = String_val(m_notes); memset(&map, 0, sizeof(ml_upnpmp_t)); @@ -1023,7 +1023,6 @@ ml_upnpAddMap(value m_enabled, value m_intPort, value m_extPort, value m_type, v map.intPort = Int_val(m_intPort); map.extPort = Int_val(m_extPort); map.isTcp = Int_val(m_type); - s = String_val(m_notes); if (s && *s){ strncpy(map.notes, s, 32-1); }else{ @@ -1040,7 +1039,7 @@ value ml_upnpRemoveMap(value m_enabled, value m_intPort, value m_extPort, value m_type, value m_notes) { ml_upnpmp_t map; - char *s = NULL; + const char *s = String_val(m_notes); memset(&map, 0, sizeof(ml_upnpmp_t)); @@ -1048,7 +1047,6 @@ ml_upnpRemoveMap(value m_enabled, value m_intPort, value m_extPort, value m_type map.intPort = Int_val(m_intPort); map.extPort = Int_val(m_extPort); map.isTcp = Int_val(m_type); - s = String_val(m_notes); if (s && *s){ strncpy(map.notes, s, 32-1); }else{ From da5af29377f989b8f53ff97304b7f913b8de17c5 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 14:31:26 +0200 Subject: [PATCH 54/69] Fixed warnings. --- src/networks/direct_connect/che3_c.c | 26 +++++++++----------------- src/utils/cdk/gdstubs.c | 12 ++++++++++-- src/utils/lib/CryptoPP.cc | 25 ++++++++++++------------- src/utils/lib/CryptoPP.h | 24 ++++++++++++------------ src/utils/lib/fst_hash.c | 2 +- 5 files changed, 44 insertions(+), 45 deletions(-) diff --git a/src/networks/direct_connect/che3_c.c b/src/networks/direct_connect/che3_c.c index 35071714..5f010ad0 100644 --- a/src/networks/direct_connect/che3_c.c +++ b/src/networks/direct_connect/che3_c.c @@ -1,5 +1,5 @@ /* rewrite in C and caml stubs by b8_bavard (2002) */ -/* rewrite to class without glib by Mathias Küster (2002) */ +/* rewrite to class without glib by Mathias K�ster (2002) */ /* DCTC - a Direct Connect text clone for Linux * Copyright (C) 2001 Eric Prevoteau @@ -71,7 +71,7 @@ directory name \xD\xA /******************************************************/ /*get 1 bit from the current bit position inside data */ /******************************************************/ -unsigned long get_bit(unsigned char *data, unsigned long *cur_pos) +unsigned long get_bit(const unsigned char *data, unsigned long *cur_pos) { unsigned long out; @@ -85,7 +85,7 @@ out=((unsigned long)(data[(*cur_pos)/8]>>((*cur_pos)&7)))&1; /*********************************************************/ /* get nb_bits from the current bit position inside data */ /*********************************************************/ -unsigned long get_bits(unsigned char *data, unsigned long *cur_pos, int nb_bit) +unsigned long get_bits(const unsigned char *data, unsigned long *cur_pos, int nb_bit) { int i; unsigned long res=0; @@ -103,7 +103,7 @@ unsigned long get_bits(unsigned char *data, unsigned long *cur_pos, int nb_bit) /* input: a GByteArray containing HE3 compressed data */ /* output: a GString containing uncompressed data or NULL */ /**********************************************************/ -char *decode_he3_data(char *data_string, int data_len, int* final_len) +char *decode_he3_data(const char *data_string, int data_len, int* final_len) { char *output_string = NULL; int output_len = 0; @@ -368,7 +368,7 @@ HUFNODE *remove_node() return pre_tree[pre_tree_len]; } -char *encode_he3_data(char *str, int len, int* final_len) +char *encode_he3_data(const char *str, int len, int* final_len) { unsigned long occur[256]; HUFENCODE tbl_enc[256]; @@ -524,34 +524,26 @@ char *encode_he3_data(char *str, int len, int* final_len) value ml_che3_decompress(value s_v) { - char *s = String_val(s_v); + const char *s = String_val(s_v); int len = string_length(s_v); char *result; int final_len; - value res; result = decode_he3_data(s, len, &final_len); - res = alloc_string(final_len); - memmove(String_val(res), result, final_len); - - return res; + return caml_alloc_initialized_string(final_len, result); } value ml_che3_compress(value s_v) { - char *s = String_val(s_v); + const char *s = String_val(s_v); int len = string_length(s_v); char *result; int final_len; - value res; result = encode_he3_data(s, len, &final_len); - res = alloc_string(final_len); - memmove(String_val(res), result, final_len); - - return res; + return caml_alloc_initialized_string(final_len, result); } #if 0 diff --git a/src/utils/cdk/gdstubs.c b/src/utils/cdk/gdstubs.c index 8404a102..163f6f74 100644 --- a/src/utils/cdk/gdstubs.c +++ b/src/utils/cdk/gdstubs.c @@ -317,8 +317,12 @@ value ml_image_charu(value *argv, int argc) { value ml_image_str_native(value gdw, value font, value x, value y, value s, value color) { + const char* _s = String_val(s); + const size_t length = strlen(_s); + char tmp[length + 1]; + strcpy(tmp, _s); gdImageString(IM_VAL(gdw), FONT_VAL(font), Int_val(x), Int_val(y), - String_val(s), Int_val(color)); + tmp, Int_val(color)); return Val_unit; } @@ -329,8 +333,12 @@ value ml_image_str(value *argv, int argc) { value ml_image_stru_native(value gdw, value font, value x, value y, value s, value color) { + const char* _s = String_val(s); + const size_t length = strlen(_s); + char tmp[length + 1]; + strcpy(tmp, _s); gdImageStringUp(IM_VAL(gdw), FONT_VAL(font), Int_val(x), Int_val(y), - String_val(s), Int_val(color)); + tmp, Int_val(color)); return Val_unit; } diff --git a/src/utils/lib/CryptoPP.cc b/src/utils/lib/CryptoPP.cc index 1b3b2bd3..9cf3c8a5 100644 --- a/src/utils/lib/CryptoPP.cc +++ b/src/utils/lib/CryptoPP.cc @@ -695,13 +695,13 @@ BufferedTransformation * PK_Encryptor::CreateEncryptionFilter(RandomNumberGenera unsigned int PK_Signer::Sign(RandomNumberGenerator &rng, PK_MessageAccumulator *messageAccumulator, byte *signature) const { - std::auto_ptr m(messageAccumulator); + std::unique_ptr m(messageAccumulator); return SignAndRestart(rng, *m, signature, false); } unsigned int PK_Signer::SignMessage(RandomNumberGenerator &rng, const byte *message, unsigned int messageLen, byte *signature) const { - std::auto_ptr m(NewSignatureAccumulator(rng)); + std::unique_ptr m(NewSignatureAccumulator(rng)); m->Update(message, messageLen); return SignAndRestart(rng, *m, signature, false); } @@ -709,7 +709,7 @@ unsigned int PK_Signer::SignMessage(RandomNumberGenerator &rng, const byte *mess unsigned int PK_Signer::SignMessageWithRecovery(RandomNumberGenerator &rng, const byte *recoverableMessage, unsigned int recoverableMessageLength, const byte *nonrecoverableMessage, unsigned int nonrecoverableMessageLength, byte *signature) const { - std::auto_ptr m(NewSignatureAccumulator(rng)); + std::unique_ptr m(NewSignatureAccumulator(rng)); InputRecoverableMessage(*m, recoverableMessage, recoverableMessageLength); m->Update(nonrecoverableMessage, nonrecoverableMessageLength); return SignAndRestart(rng, *m, signature, false); @@ -717,13 +717,13 @@ unsigned int PK_Signer::SignMessageWithRecovery(RandomNumberGenerator &rng, cons bool PK_Verifier::Verify(PK_MessageAccumulator *messageAccumulator) const { - std::auto_ptr m(messageAccumulator); + std::unique_ptr m(messageAccumulator); return VerifyAndRestart(*m); } bool PK_Verifier::VerifyMessage(const byte *message, unsigned int messageLen, const byte *signature, unsigned int signatureLength) const { - std::auto_ptr m(NewVerificationAccumulator()); + std::unique_ptr m(NewVerificationAccumulator()); InputSignature(*m, signature, signatureLength); m->Update(message, messageLen); return VerifyAndRestart(*m); @@ -731,7 +731,7 @@ bool PK_Verifier::VerifyMessage(const byte *message, unsigned int messageLen, co DecodingResult PK_Verifier::Recover(byte *recoveredMessage, PK_MessageAccumulator *messageAccumulator) const { - std::auto_ptr m(messageAccumulator); + std::unique_ptr m(messageAccumulator); return RecoverAndRestart(recoveredMessage, *m); } @@ -739,7 +739,7 @@ DecodingResult PK_Verifier::RecoverMessage(byte *recoveredMessage, const byte *nonrecoverableMessage, unsigned int nonrecoverableMessageLength, const byte *signature, unsigned int signatureLength) const { - std::auto_ptr m(NewVerificationAccumulator()); + std::unique_ptr m(NewVerificationAccumulator()); InputSignature(*m, signature, signatureLength); m->Update(nonrecoverableMessage, nonrecoverableMessageLength); return RecoverAndRestart(recoveredMessage, *m); @@ -1044,7 +1044,7 @@ struct NewPrimeTable { const unsigned int maxPrimeTableSize = 3511; - std::auto_ptr > pPrimeTable(new std::vector); + std::unique_ptr > pPrimeTable(new std::vector); std::vector &primeTable = *pPrimeTable; primeTable.reserve(maxPrimeTableSize); @@ -4523,23 +4523,20 @@ std::ostream& operator<<(std::ostream& out, const Integer &a) { // Get relevant conversion specifications from ostream. long f = out.flags() & std::ios::basefield; // Get base digits. - int base, block; + int base; char suffix; switch(f) { case std::ios::oct : base = 8; - block = 8; suffix = 'o'; break; case std::ios::hex : base = 16; - block = 4; suffix = 'h'; break; default : base = 10; - block = 3; suffix = '.'; } @@ -6484,6 +6481,7 @@ bool Filter::Flush(bool hardFlush, int propagation, bool blocking) case 0: if (IsolatedFlush(hardFlush, blocking)) return true; + [[fallthrough]]; case 1: if (OutputFlush(1, hardFlush, propagation, blocking)) return true; @@ -6498,6 +6496,7 @@ bool Filter::MessageSeriesEnd(int propagation, bool blocking) case 0: if (IsolatedMessageSeriesEnd(blocking)) return true; + [[fallthrough]]; case 1: if (ShouldPropagateMessageSeriesEnd() && OutputMessageSeriesEnd(1, propagation, blocking)) return true; @@ -6785,7 +6784,7 @@ void ProxyFilter::SetFilter(Filter *filter) if (filter) { OutputProxy *proxy; - std::auto_ptr temp(proxy = new OutputProxy(*this, false)); + std::unique_ptr temp(proxy = new OutputProxy(*this, false)); m_filter->TransferAllTo(*proxy); m_filter->Attach(temp.release()); } diff --git a/src/utils/lib/CryptoPP.h b/src/utils/lib/CryptoPP.h index 6c01a929..8262affe 100644 --- a/src/utils/lib/CryptoPP.h +++ b/src/utils/lib/CryptoPP.h @@ -3938,15 +3938,15 @@ class CRYPTOPP_DLL CRYPTOPP_NO_VTABLE Sink : public BufferedTransformation { protected: // make these functions protected to help prevent unintentional calls to them - BufferedTransformation::Get; - BufferedTransformation::Peek; - BufferedTransformation::TransferTo; - BufferedTransformation::CopyTo; - BufferedTransformation::CopyRangeTo; - BufferedTransformation::TransferMessagesTo; - BufferedTransformation::CopyMessagesTo; - BufferedTransformation::TransferAllTo; - BufferedTransformation::CopyAllTo; + using BufferedTransformation::Get; + using BufferedTransformation::Peek; + using BufferedTransformation::TransferTo; + using BufferedTransformation::CopyTo; + using BufferedTransformation::CopyRangeTo; + using BufferedTransformation::TransferMessagesTo; + using BufferedTransformation::CopyMessagesTo; + using BufferedTransformation::TransferAllTo; + using BufferedTransformation::CopyAllTo; unsigned int TransferTo2(BufferedTransformation& /* target */, unsigned long &transferBytes, const std::string& /* channel */ = NULL_CHANNEL, bool /* blocking */ = true) {transferBytes = 0; return 0;} unsigned int CopyRangeTo2(BufferedTransformation& /* target */, unsigned long& /* begin */, unsigned long /* end */ = ULONG_MAX, const std::string& /* channel */ = NULL_CHANNEL, bool /* blocking */ = true) const @@ -4356,8 +4356,8 @@ class CRYPTOPP_DLL AlgorithmParametersBase : public NameValuePairs try #endif { - if (m_throwIfNotUsed && !m_used) - throw ParameterNotUsed(m_name); + //if (m_throwIfNotUsed && !m_used) + // throw ParameterNotUsed(m_name); } #ifndef CRYPTOPP_UNCAUGHT_EXCEPTION_AVAILABLE catch(...) @@ -4715,7 +4715,7 @@ class StringSinkTemplate : public Bufferless void IsolatedInitialize(const NameValuePairs ¶meters) {if (!parameters.GetValue("OutputStringPointer", m_output)) throw InvalidArgument("StringSink: OutputStringPointer not specified");} - unsigned int Put2(const byte *begin, unsigned int length, int messageEnd, bool blocking) + unsigned int Put2(const byte *begin, unsigned int length, int /* messageEnd */, bool /* blocking */) { if (length > 0) { diff --git a/src/utils/lib/fst_hash.c b/src/utils/lib/fst_hash.c index 1d3b3e27..1f2a6195 100755 --- a/src/utils/lib/fst_hash.c +++ b/src/utils/lib/fst_hash.c @@ -198,7 +198,7 @@ unsigned short fst_hash_checksum (unsigned char *hash) /*****************************************************************************/ // hash file -int fst_hash_file (unsigned char *fth, char *file, int64_t filesize) +int fst_hash_file (unsigned char *fth, const char *file, int64_t filesize) { FILE *fp; unsigned char *buf; From 1b39956f69f1d520a94cd570e13484515186d87b Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 14:46:03 +0200 Subject: [PATCH 55/69] String immutability in C code. --- src/networks/fasttrack/fasttrackNetwork.ml | 2 +- src/networks/fasttrack/fasttrackPandora.ml | 48 +++++++++++----------- src/networks/fasttrack/fasttrackProto.ml | 14 +++---- src/networks/fasttrack/fst_crypt_ml.c | 6 +-- src/networks/gnutella/gnutellaFunctions.ml | 2 +- 5 files changed, 36 insertions(+), 36 deletions(-) diff --git a/src/networks/fasttrack/fasttrackNetwork.ml b/src/networks/fasttrack/fasttrackNetwork.ml index 9a1c54ec..009dcd63 100644 --- a/src/networks/fasttrack/fasttrackNetwork.ml +++ b/src/networks/fasttrack/fasttrackNetwork.ml @@ -78,7 +78,7 @@ type file_uid = Md5Ext.t type file_uri = string external create_cipher : unit -> cipher = "ml_create_cipher" -external apply_cipher : cipher -> string -> int -> int -> unit +external apply_cipher : cipher -> bytes -> int -> int -> unit = "ml_apply_cipher" external init_cipher : cipher -> unit = "ml_init_cipher" external set_cipher : cipher -> int32 -> int -> unit = "ml_set_cipher" diff --git a/src/networks/fasttrack/fasttrackPandora.ml b/src/networks/fasttrack/fasttrackPandora.ml index c97726d0..ce30521a 100644 --- a/src/networks/fasttrack/fasttrackPandora.ml +++ b/src/networks/fasttrack/fasttrackPandora.ml @@ -208,9 +208,9 @@ let rec check_xinu s pos len depth = else depth | _ -> -10 -let parse (s_out : string) (s_in : string) = +let parse (s_out : bytes) (s_in : bytes) = let parsed = ref false in - if String.length s_in > 12 && String.length s_out > 12 then begin + if Bytes.length s_in > 12 && Bytes.length s_out > 12 then begin let ciphers = { in_cipher = create_cipher (); out_cipher = create_cipher (); @@ -220,25 +220,25 @@ let parse (s_out : string) (s_in : string) = begin try - get_cipher_from_packet s_out 4 ciphers.out_cipher; + get_cipher_from_packet (Bytes.to_string s_out) 4 ciphers.out_cipher; init_cipher ciphers.out_cipher; - get_cipher_from_packet s_in 0 ciphers.in_cipher; + get_cipher_from_packet (Bytes.to_string s_in) 0 ciphers.in_cipher; init_cipher ciphers.in_cipher; xor_ciphers ciphers.out_cipher ciphers.in_cipher; init_cipher ciphers.out_cipher; lprintf "HEADER OF CONNECTION: %02x.%02x.%02x.%02x - %02x.%02x.%02x.%02x\n" - (int_of_char s_out.[0]) - (int_of_char s_out.[1]) - (int_of_char s_out.[2]) - (int_of_char s_out.[3]) - - (int_of_char s_out.[4]) - (int_of_char s_out.[5]) - (int_of_char s_out.[6]) - (int_of_char s_out.[7]) + (int_of_char (Bytes.get s_out 0)) + (int_of_char (Bytes.get s_out 1)) + (int_of_char (Bytes.get s_out 2)) + (int_of_char (Bytes.get s_out 3)) + + (int_of_char (Bytes.get s_out 4)) + (int_of_char (Bytes.get s_out 5)) + (int_of_char (Bytes.get s_out 6)) + (int_of_char (Bytes.get s_out 7)) ; begin @@ -254,7 +254,7 @@ let parse (s_out : string) (s_in : string) = end; ( - let len = String.length s_out in + let len = Bytes.length s_out in let start_pos = 12 in apply_cipher ciphers.out_cipher s_out start_pos (len-start_pos); (* @@ -263,7 +263,7 @@ let parse (s_out : string) (s_in : string) = *) ); ( - let len = String.length s_in in + let len = Bytes.length s_in in let start_pos = 8 in apply_cipher ciphers.in_cipher s_in start_pos (len-start_pos); (* @@ -273,11 +273,11 @@ let parse (s_out : string) (s_in : string) = ); lprintf "---------------------------------------------->\n"; - lprintf " HEADER[%s]\n" (String.escaped (String.sub s_out 0 4)); - parse_netname 12 (Bytes.of_string s_out) { ciphers with + lprintf " HEADER[%s]\n" (Bytes.unsafe_to_string (Bytes.escaped (Bytes.sub s_out 0 4))); + parse_netname 12 s_out { ciphers with in_xinu = ciphers.out_xinu; in_cipher = ciphers.out_cipher }; lprintf "<----------------------------------------------\n"; - parse_netname 8 (Bytes.of_string s_in) ciphers; + parse_netname 8 s_in ciphers; parsed := true; (* (* @@ -289,8 +289,8 @@ dump_sub s (start_pos) (len - start_pos); with e -> lprintf "exception %s while parsing stream\n" (Printexc2.to_string e) ; - lprintf " [%s]\n" (String.escaped - (String.sub s_in 0 (min 50 (String.length s_in)))) + lprintf " [%s]\n" (Bytes.unsafe_to_string (Bytes.escaped + (Bytes.sub s_in 0 (min 50 (Bytes.length s_in))))) end; cipher_free ciphers.in_cipher; cipher_free ciphers.out_cipher; @@ -376,13 +376,13 @@ let print_packets () = lprintf "First direction....\n"; let parsed = parse - (Buffer.contents cnx.packets_out) - (Buffer.contents cnx.packets_in) in + (Buffer.to_bytes cnx.packets_out) + (Buffer.to_bytes cnx.packets_in) in if not parsed then begin lprintf "Second direction....\n"; let _ = parse - (Buffer.contents cnx.packets_in) - (Buffer.contents cnx.packets_out) in + (Buffer.to_bytes cnx.packets_in) + (Buffer.to_bytes cnx.packets_out) in () end end diff --git a/src/networks/fasttrack/fasttrackProto.ml b/src/networks/fasttrack/fasttrackProto.ml index e779c65c..55dd9681 100644 --- a/src/networks/fasttrack/fasttrackProto.ml +++ b/src/networks/fasttrack/fasttrackProto.ml @@ -65,11 +65,11 @@ let ip_to_string ip = Ip.to_string ip let crypt_and_send sock out_cipher str = if !verbose_msg_raw || monitored sock then lprintf "crypt_and_send: to send [%s]\n" (String.escaped str); - let str = String.copy str in - apply_cipher out_cipher str 0 (String.length str); + let str = Bytes.of_string str in + apply_cipher out_cipher str 0 (Bytes.length str); if !verbose_msg_raw || monitored sock then - lprintf "crypt_and_send: [%s] sent\n" (String.escaped str); - write_string sock str + lprintf "crypt_and_send: [%s] sent\n" (Bytes.unsafe_to_string (Bytes.escaped str)); + write sock str 0 (Bytes.length str) (*************************************************************************) (* *) @@ -1893,9 +1893,9 @@ let check_primitives () = cipher_packet_set cipher s 0; assert (s = Bytes.of_string "\007\091\205\021\110\233\135\1870000"); (* lprintf "cipher_packet_set s = \"%s\"\n" (String.escaped s); *) - let s = "123456789abcdefghijklm\233\234\235" in - apply_cipher cipher s 0 (String.length s); - assert (s = "\016\210\245\241\144Ug\028Z\229\1928\176\167\192\008\139\019\018Z\1937\226\250i"); + let s = Bytes.of_string "123456789abcdefghijklm\233\234\235" in + apply_cipher cipher s 0 (Bytes.length s); + assert (s = Bytes.of_string "\016\210\245\241\144Ug\028Z\229\1928\176\167\192\008\139\019\018Z\1937\226\250i"); (* lprintf "apply_cipher s = \"%s\"\n" (String.escaped s); *) cipher_free cipher; with _ -> diff --git a/src/networks/fasttrack/fst_crypt_ml.c b/src/networks/fasttrack/fst_crypt_ml.c index b7fe1db2..c55772fb 100755 --- a/src/networks/fasttrack/fst_crypt_ml.c +++ b/src/networks/fasttrack/fst_crypt_ml.c @@ -47,7 +47,7 @@ value ml_create_cipher(value unit) value ml_apply_cipher(value cipher_v, value s_v, value pos_v, value len_v) { FSTCipher* cipher = (FSTCipher*) cipher_v; - char *s = String_val(s_v); + char *s = Bytes_val(s_v); int pos = Int_val(pos_v); int len = Int_val(len_v); @@ -83,7 +83,7 @@ value ml_set_cipher(value cipher_v, value seed_v, value encode_v) value ml_cipher_packet_get(value s_v, value pos_v, value in_cipher_v) { FSTCipher* in_cipher = (FSTCipher*) in_cipher_v; - char *s = String_val(s_v); + const char *s = String_val(s_v); int pos = Int_val(pos_v); unsigned int seed; unsigned int enc_type; @@ -158,7 +158,7 @@ value ml_cipher_packet_set_xored(value cipher_v, value s_v, value pos_v, value x { FSTCipher* cipher = (FSTCipher*) cipher_v; FSTCipher* xor_cipher = (FSTCipher*) xor_cipher_v; - char *s = String_val(s_v); + const char *s = String_val(s_v); int pos = Int_val(pos_v); unsigned int seed = cipher->seed; diff --git a/src/networks/gnutella/gnutellaFunctions.ml b/src/networks/gnutella/gnutellaFunctions.ml index ff31ab3c..258a4711 100644 --- a/src/networks/gnutella/gnutellaFunctions.ml +++ b/src/networks/gnutella/gnutellaFunctions.ml @@ -201,7 +201,7 @@ let handlers info gconn = (String.escaped (String.sub (Bytes.to_string b.buf) b.pos b.len)); if nread > 0 then begin (* AnyEndian.dump_sub b.buf (b.pos + b.len - nread) nread; *) - apply_cipher cipher (Bytes.to_string b.buf) (b.pos + b.len - nread) nread; + apply_cipher cipher b.buf (b.pos + b.len - nread) nread; log (LogReceive(peer_ip sock, peer_port sock, String.sub (Bytes.to_string b.buf) (b.pos + b.len - nread) nread)); From 5ce542e78e2aff084a32105d0647b4a3c9644b41 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 14:48:41 +0200 Subject: [PATCH 56/69] Fixed warnings. --- src/utils/lib/fst_hash.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/lib/fst_hash.c b/src/utils/lib/fst_hash.c index 1f2a6195..bf9fc1d0 100755 --- a/src/utils/lib/fst_hash.c +++ b/src/utils/lib/fst_hash.c @@ -182,7 +182,7 @@ static unsigned int fst_hash_small (unsigned char* data, unsigned int len, unsig #include "caml/mlvalues.h" /* returns checksum of fzhash */ -unsigned short fst_hash_checksum (unsigned char *hash) +unsigned short fst_hash_checksum (const unsigned char *hash) { unsigned short sum = 0; int i; @@ -272,7 +272,7 @@ int fst_hash_file (unsigned char *fth, const char *file, int64_t filesize) } -void fst_hash_string (unsigned char *fth, unsigned char *file, int64_t filesize) +void fst_hash_string (unsigned char *fth, const unsigned char *file, int64_t filesize) { unsigned char * buf = file; size_t len = filesize; From 668541b144e64034cbbf7d066c69ea774bf1aaf8 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 17:19:37 +0200 Subject: [PATCH 57/69] Fixed hash functions. --- src/daemon/common/commonHasher_c.c | 2 +- src/utils/lib/fst_hash.c | 8 ++--- src/utils/lib/md4.ml | 50 +++++++++++++++--------------- src/utils/lib/md4_c.c | 6 ++-- src/utils/lib/stubs_c.c | 2 +- 5 files changed, 34 insertions(+), 34 deletions(-) diff --git a/src/daemon/common/commonHasher_c.c b/src/daemon/common/commonHasher_c.c index 0e1e1762..05f90f6f 100644 --- a/src/daemon/common/commonHasher_c.c +++ b/src/daemon/common/commonHasher_c.c @@ -292,7 +292,7 @@ value ml_job_done(value job_v) { if(job_done){ value result_v = Field(job_v, JOB_RESULT); - char *result = String_val(result_v); + char *result = Bytes_val(result_v); int result_len = string_length(result_v); /* printf("job len done: %d\n", result_len); */ diff --git a/src/utils/lib/fst_hash.c b/src/utils/lib/fst_hash.c index bf9fc1d0..39aa304b 100755 --- a/src/utils/lib/fst_hash.c +++ b/src/utils/lib/fst_hash.c @@ -168,7 +168,7 @@ void FSTUpdate (FST_CTX*context, unsigned char*buffer, unsigned int len) // updates 4 byte small hash that is concatenated to the md5 of the first // 307200 bytes of the file. set hash to 0xffffffff for first run -static unsigned int fst_hash_small (unsigned char* data, unsigned int len, unsigned int smallhash) +static unsigned int fst_hash_small (const unsigned char* data, unsigned int len, unsigned int smallhash) { unsigned int i; @@ -274,7 +274,7 @@ int fst_hash_file (unsigned char *fth, const char *file, int64_t filesize) void fst_hash_string (unsigned char *fth, const unsigned char *file, int64_t filesize) { - unsigned char * buf = file; + const unsigned char * buf = file; size_t len = filesize; ml_MD5Context md5_ctx; unsigned int smallhash; @@ -324,14 +324,14 @@ void fst_hash_string (unsigned char *fth, const unsigned char *file, int64_t fil value fst_hash_file_ml(value digest, value filename, value filesize) { - if(fst_hash_file(String_val(digest), String_val(filename), + if(fst_hash_file(Bytes_val(digest), String_val(filename), Int64_val(filesize))) return Val_unit; failwith("Exception during FST computation"); } value fst_hash_string_ml(value digest, value s, value size) { - fst_hash_string(String_val(digest), String_val(s), Int_val(size)); + fst_hash_string(Bytes_val(digest), String_val(s), Int_val(size)); return Val_unit; } diff --git a/src/utils/lib/md4.ml b/src/utils/lib/md4.ml index 24576b5d..dc09d345 100644 --- a/src/utils/lib/md4.ml +++ b/src/utils/lib/md4.ml @@ -291,12 +291,12 @@ module Make(M: sig val hash_name : string (* [unsafe_string digest string string_len] *) - val unsafe_string : string -> string -> int -> unit + val unsafe_string : bytes -> string -> int -> unit (* [unsafe_file digest filename filesize] *) - val unsafe_file : string -> string -> int64 -> unit + val unsafe_file : bytes -> string -> int64 -> unit (* [unsafe_string digest file_fd offset len] *) - val digest_subfile : string -> Unix.file_descr -> int64 -> int64 -> unit + val digest_subfile : bytes -> Unix.file_descr -> int64 -> int64 -> unit module Base : Base end) = struct @@ -314,9 +314,9 @@ module Make(M: sig let string s = let len = String.length s in - let digest = String.make hash_length '\000' in + let digest = Bytes.make hash_length '\000' in unsafe_string digest s len; - digest + Bytes.to_string digest let to_bits s = let len = String.length s in @@ -331,25 +331,25 @@ module Make(M: sig done; (Bytes.to_string digest) - external xor_c : t -> t -> t -> unit = "md4_xor" "noalloc" + external xor_c : t -> t -> bytes -> unit = "md4_xor" "noalloc" let xor m1 m2 = - let m3 = String.make hash_length '\000' in + let m3 = Bytes.make hash_length '\000' in xor_c m1 m2 m3; - m3 + Bytes.to_string m3 let file s = - let digest = String.make hash_length '\000' in + let digest = Bytes.make hash_length '\000' in let file_size = Unix32.getsize s in unsafe_file digest s file_size; digest let digest_subfile fd pos len = - let digest = String.make hash_length '\000' in + let digest = Bytes.make hash_length '\000' in Unix32.apply_on_chunk fd pos len (fun fd pos -> digest_subfile digest fd pos len); - digest + Bytes.to_string digest let create () = String.make hash_length '\000' @@ -397,9 +397,9 @@ module Md4 = Make(struct let hash_length = 16 let hash_name = "Md4" - external unsafe_string : string -> string -> int -> unit = "md4_unsafe_string" - external unsafe_file : string -> string -> int64 -> unit = "md4_unsafe_file" - external digest_subfile : string -> Unix.file_descr -> int64 -> int64 -> unit = + external unsafe_string : bytes -> string -> int -> unit = "md4_unsafe_string" + external unsafe_file : bytes -> string -> int64 -> unit = "md4_unsafe_file" + external digest_subfile : bytes -> Unix.file_descr -> int64 -> int64 -> unit = "md4_unsafe64_fd" module Base = Base16 @@ -409,9 +409,9 @@ module Md5 = Make(struct let hash_length = 16 let hash_name = "Md5" - external unsafe_string : string -> string -> int -> unit = "md5_unsafe_string" - external unsafe_file : string -> string -> int64 -> unit = "md5_unsafe_file" - external digest_subfile : string -> Unix.file_descr -> int64 -> int64 -> unit = + external unsafe_string : bytes -> string -> int -> unit = "md5_unsafe_string" + external unsafe_file : bytes -> string -> int64 -> unit = "md5_unsafe_file" + external digest_subfile : bytes -> Unix.file_descr -> int64 -> int64 -> unit = "md5_unsafe64_fd" module Base = Base16 @@ -421,9 +421,9 @@ module PreSha1 = Make(struct let hash_length = 20 let hash_name = "Sha1" - external unsafe_string : string -> string -> int -> unit = "sha1_unsafe_string" - external unsafe_file : string -> string -> int64 -> unit = "sha1_unsafe_file" - external digest_subfile : string -> Unix.file_descr -> int64 -> int64 -> unit = + external unsafe_string : bytes -> string -> int -> unit = "sha1_unsafe_string" + external unsafe_file : bytes -> string -> int64 -> unit = "sha1_unsafe_file" + external digest_subfile : bytes -> Unix.file_descr -> int64 -> int64 -> unit = "sha1_unsafe64_fd" module Base = Base32 @@ -464,7 +464,7 @@ module Tiger = Make(struct let hash_length = 24 let hash_name = "Tiger" - external unsafe_string : string -> string -> int -> unit = + external unsafe_string : bytes -> string -> int -> unit = "tiger_unsafe_string" let unsafe_file digest filename = @@ -481,8 +481,8 @@ module PreTigerTree = Make(struct let hash_length = 24 let hash_name = "TigerTree" - external unsafe_string : string -> string -> int -> unit = "tigertree_unsafe_string" - external digest_subfile : string -> Unix.file_descr -> int64 -> int64 -> unit = + external unsafe_string : bytes -> string -> int -> unit = "tigertree_unsafe_string" + external digest_subfile : bytes -> Unix.file_descr -> int64 -> int64 -> unit = "tigertree_unsafe64_fd" let unsafe_file digest filename file_size = @@ -530,10 +530,10 @@ module PreMd5Ext = Make(struct let hash_length = 20 let hash_name = "Md5Ext" - external unsafe_string : string -> string -> int -> unit = + external unsafe_string : bytes -> string -> int -> unit = "fst_hash_string_ml" - external unsafe_file : string -> string -> int64 -> unit = "fst_hash_file_ml" + external unsafe_file : bytes -> string -> int64 -> unit = "fst_hash_file_ml" let digest_subfile _ _ _ _ = failwith "Md5Ext.digest_subfile not implemented" diff --git a/src/utils/lib/md4_c.c b/src/utils/lib/md4_c.c index 10f5c0f6..da4c1d4c 100644 --- a/src/utils/lib/md4_c.c +++ b/src/utils/lib/md4_c.c @@ -29,9 +29,9 @@ value md4_xor(value m1_v, value m2_v, value m3_v) { int len = caml_string_length(m1_v); - char *m1 = String_val(m1_v); - char *m2 = String_val(m2_v); - char *m3 = String_val(m3_v); + const char *m1 = String_val(m1_v); + const char *m2 = String_val(m2_v); + char *m3 = Bytes_val(m3_v); int i; for(i = 0; i Date: Fri, 7 Jun 2024 17:39:01 +0200 Subject: [PATCH 58/69] Fixed warnings. --- src/utils/lib/charsetstubs.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/utils/lib/charsetstubs.c b/src/utils/lib/charsetstubs.c index 73bba69c..fcf385ed 100644 --- a/src/utils/lib/charsetstubs.c +++ b/src/utils/lib/charsetstubs.c @@ -165,7 +165,7 @@ void raise_error(void) { - static value * closure_f = NULL; + static const value * closure_f = NULL; if (closure_f == NULL) { /* First time around, look up by name */ closure_f = caml_named_value("charset_error"); @@ -1204,7 +1204,8 @@ ml_iconv (iconv_t cd, char **outbuf, size_t *outbytes_left) { - return iconv (cd, inbuf, inbytes_left, outbuf, outbytes_left); + /* iconv should not modify the input, according to specs, but it is not marked const */ + return iconv (cd, (char**)inbuf, inbytes_left, outbuf, outbytes_left); } #ifndef EILSEQ @@ -1297,7 +1298,7 @@ ml_convert_with_iconv (const char *str, } char* -ml_convert (const char *str, +ml_convert (char *str, size_t len, const char *to_codeset, const char *from_codeset, From 83c5dfc64656ca6a058d6b35c18d5ff1b38c4d09 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 18:22:55 +0200 Subject: [PATCH 59/69] Fixed string immutability in c code. --- src/config/unix/os_stubs_c.c | 2 +- src/utils/lib/CryptoPP.cc | 4 ++-- src/utils/lib/CryptoPP_stubs.c | 25 ++++++++----------------- src/utils/lib/CryptoPP_stubs.h | 4 ++-- src/utils/lib/charsetstubs.c | 6 +++--- src/utils/lib/os_stubs.h | 2 +- src/utils/lib/stubs_c.c | 16 ++++++++-------- src/utils/lib/tiger.c | 12 ++++++------ src/utils/lib/tiger.h | 2 +- src/utils/net/ip.ml | 4 ++-- 10 files changed, 34 insertions(+), 43 deletions(-) diff --git a/src/config/unix/os_stubs_c.c b/src/config/unix/os_stubs_c.c index a43dc7f5..9ed7d0e0 100644 --- a/src/config/unix/os_stubs_c.c +++ b/src/config/unix/os_stubs_c.c @@ -127,7 +127,7 @@ int64_t os_getfdsize(OS_FD fd) *******************************************************************/ -int64_t os_getfilesize(char *path) +int64_t os_getfilesize(const char *path) { struct stat buf; diff --git a/src/utils/lib/CryptoPP.cc b/src/utils/lib/CryptoPP.cc index 9cf3c8a5..cf0dd654 100644 --- a/src/utils/lib/CryptoPP.cc +++ b/src/utils/lib/CryptoPP.cc @@ -9517,7 +9517,7 @@ void createKey(char buf[]) { } -unsigned long loadKey(char privateKeyBase64[], char buf[]) { +unsigned long loadKey(const char privateKeyBase64[], char buf[]) { using namespace CryptoPP; unsigned long result = 0; @@ -9554,7 +9554,7 @@ unsigned long loadKey(char privateKeyBase64[], char buf[]) { // return signatureSize (buf) -int createSignature(byte *buf, int maxLen, byte *key, int keyLen, uint32_t cInt, uint8_t ipType, uint32_t ip) { +int createSignature(byte *buf, int maxLen, const byte *key, int keyLen, uint32_t cInt, uint8_t ipType, uint32_t ip) { int result = 0; diff --git a/src/utils/lib/CryptoPP_stubs.c b/src/utils/lib/CryptoPP_stubs.c index f957f7f8..0b87b515 100644 --- a/src/utils/lib/CryptoPP_stubs.c +++ b/src/utils/lib/CryptoPP_stubs.c @@ -32,21 +32,16 @@ ml_createKey() { // return public key value ml_loadKey(value privatekey) { - char *s = String_val(privatekey); - char buf[4096]; - unsigned long len = loadKey(s, buf); - - value res; - res = caml_alloc_string(len); - memmove(String_val(res), buf, len); - - return res; + const char *s = String_val(privatekey); + char buf[4096]; + unsigned long len = loadKey(s, buf); + return caml_alloc_initialized_string(len, buf); } value ml_createSignature(value m_key, value m_keyLen, value m_cInt, value m_ipType, value m_ip) { - byte *key = (byte*) String_val(m_key); + const byte *key = (byte*) String_val(m_key); int keyLen = Int_val(m_keyLen); uint32_t cInt = Int64_val(m_cInt); int ipType = Int_val(m_ipType); @@ -56,11 +51,7 @@ ml_createSignature(value m_key, value m_keyLen, value m_cInt, value m_ipType, va int len = createSignature(buf, 200, key, keyLen, cInt, ipType, ip); - value res; - res = caml_alloc_string(len); - memmove(String_val(res), buf, len); - - return res; + return caml_alloc_initialized_string(len, buf); } value @@ -86,8 +77,8 @@ ml_verifySignature_bytecode(value *argv, int argn) { void cc_lprintf_nl(const char * msg, int verb) { - static value * caml_func = NULL; - if (caml_func == NULL) caml_func = caml_named_value("ml_lprintf_nl"); + static const value * caml_func = NULL; + if (!caml_func) caml_func = caml_named_value("ml_lprintf_nl"); caml_callback2(*caml_func, caml_copy_string(msg), Val_int(verb)); } diff --git a/src/utils/lib/CryptoPP_stubs.h b/src/utils/lib/CryptoPP_stubs.h index a03c94c5..f78332ea 100644 --- a/src/utils/lib/CryptoPP_stubs.h +++ b/src/utils/lib/CryptoPP_stubs.h @@ -36,6 +36,6 @@ typedef unsigned char byte; void crypto_exit(); void createKey(char buf[]); -unsigned long loadKey(char privateKeyBase64[], char buf[]); -int createSignature(byte *buf, int maxLen, byte *key, int keyLen, uint32_t cInt, uint8_t ipType, uint32_t ip); +unsigned long loadKey(const char privateKeyBase64[], char buf[]); +int createSignature(byte *buf, int maxLen, const byte *key, int keyLen, uint32_t cInt, uint8_t ipType, uint32_t ip); int verifySignature(byte *key, int keyLen, byte *sig, int sigLen, uint32_t cInt, uint8_t ipType, uint32_t ip); diff --git a/src/utils/lib/charsetstubs.c b/src/utils/lib/charsetstubs.c index fcf385ed..354d4372 100644 --- a/src/utils/lib/charsetstubs.c +++ b/src/utils/lib/charsetstubs.c @@ -1298,7 +1298,7 @@ ml_convert_with_iconv (const char *str, } char* -ml_convert (char *str, +ml_convert (const char *str, size_t len, const char *to_codeset, const char *from_codeset, @@ -1337,8 +1337,8 @@ ml_copy_string_len_and_free (char *str, size_t len) if (!str) raise_error (); - v = alloc_string (len); - memcpy (String_val(v), str, len); + v = caml_alloc_initialized_string(len, str); + free (str); return v; } diff --git a/src/utils/lib/os_stubs.h b/src/utils/lib/os_stubs.h index 5ec05129..fc3ed03b 100644 --- a/src/utils/lib/os_stubs.h +++ b/src/utils/lib/os_stubs.h @@ -156,7 +156,7 @@ extern void os_ftruncate(OS_FD fd, OFF_T len, int sparse); extern ssize_t os_read(OS_FD fd, char *buf, size_t len); extern int os_getdtablesize(); extern int64_t os_getfdsize(OS_FD fd); -extern int64_t os_getfilesize(char *path); +extern int64_t os_getfilesize(const char *path); extern void os_set_nonblock(OS_SOCKET fd); extern void os_uname(char buf[]); extern int os_os_supported(); diff --git a/src/utils/lib/stubs_c.c b/src/utils/lib/stubs_c.c index 321d1426..7fee0461 100644 --- a/src/utils/lib/stubs_c.c +++ b/src/utils/lib/stubs_c.c @@ -420,8 +420,8 @@ value mld_ftruncate_64(value fd_v, value len_v, value sparse) value ml_strstr(value s_v, value sub_v) { - char *s = String_val(s_v); - char *sub = String_val(sub_v); + const char *s = String_val(s_v); + const char *sub = String_val(sub_v); if(strstr(s, sub) == NULL) { return Val_false; @@ -440,7 +440,7 @@ value ml_strstr(value s_v, value sub_v) value ml_ints_of_string(value s_v) { - char *s = String_val(s_v); + char *s = Bytes_val(s_v); uint a1,a2,a3,a4; value res; char *curs = s; @@ -509,7 +509,7 @@ value HASH_NAME##_unsafe64_fd (value digest_v, value fd_v, value pos_v, value le OS_FD fd = Fd_val(fd_v); \ OFF_T pos = Int64_val(pos_v); \ OFF_T len = Int64_val(len_v); \ - unsigned char *digest = String_val(digest_v); \ + unsigned char *digest = Bytes_val(digest_v); \ HASH_CONTEXT context; \ ssize_t nread; \ \ @@ -541,8 +541,8 @@ value HASH_NAME##_unsafe64_fd (value digest_v, value fd_v, value pos_v, value le \ value HASH_NAME##_unsafe_string(value digest_v, value string_v, value len_v) \ { \ - unsigned char *digest = String_val(digest_v); \ - unsigned char *string = String_val(string_v); \ + unsigned char *digest = Bytes_val(digest_v); \ + const unsigned char *string = String_val(string_v); \ long len = Long_val(len_v); \ HASH_CONTEXT context; \ \ @@ -556,7 +556,7 @@ value HASH_NAME##_unsafe_string(value digest_v, value string_v, value len_v) \ value HASH_NAME##_unsafe_file (value digest_v, value filename_v, value file_size) \ { \ const char *filename = String_val(filename_v); \ - unsigned char *digest = String_val(digest_v); \ + unsigned char *digest = Bytes_val(digest_v); \ FILE *file; \ HASH_CONTEXT context; \ size_t len; \ @@ -633,7 +633,7 @@ value tigertree_unsafe64_fd (value digest_v, value fd_v, value pos_v, value len_ OS_FD fd = Fd_val(fd_v); OFF_T pos = Int64_val(pos_v); OFF_T len = Int64_val(len_v); - unsigned char *digest = String_val(digest_v); + unsigned char *digest = Bytes_val(digest_v); /* int nread; */ os_lseek(fd, pos, SEEK_SET); diff --git a/src/utils/lib/tiger.c b/src/utils/lib/tiger.c index df4ed1b7..6302521b 100644 --- a/src/utils/lib/tiger.c +++ b/src/utils/lib/tiger.c @@ -775,7 +775,7 @@ char hexa(int i) #define MAX_TIGER_CHUNK_SIZE 1024 static word64 tiger_buffer[MAX_TIGER_CHUNK_SIZE]; -void tiger_hash(char prefix, char *s, OFF_T len, unsigned char *digest) +void tiger_hash(char prefix, const char *s, OFF_T len, unsigned char *digest) { char *buffer = (char*) tiger_buffer; word64 ndigest[3]; @@ -790,7 +790,7 @@ void tiger_hash(char prefix, char *s, OFF_T len, unsigned char *digest) swap_digest(digest); } -void tiger_tree_string(char *s, size_t len, size_t pos, size_t block_size, char *digest) +void tiger_tree_string(const char *s, size_t len, size_t pos, size_t block_size, char *digest) { if(block_size == BLOCK_SIZE){ size_t length = (len - pos > BLOCK_SIZE) ? BLOCK_SIZE : len - pos; @@ -827,8 +827,8 @@ OFF_T tiger_block_size(OFF_T len) value tigertree_unsafe_string(value digest_v, value string_v, value len_v) { - unsigned char *digest = String_val(digest_v); - unsigned char *string = String_val(string_v); + unsigned char *digest = Bytes_val(digest_v); + const unsigned char *string = String_val(string_v); long len = Long_val(len_v); tiger_tree_string (string, len, 0, tiger_block_size(len), digest); @@ -838,8 +838,8 @@ value tigertree_unsafe_string(value digest_v, value string_v, value len_v) value tiger_unsafe_string(value digest_v, value string_v, value len_v) { - unsigned char *digest = String_val(digest_v); - unsigned char *string = String_val(string_v); + unsigned char *digest = Bytes_val(digest_v); + const unsigned char *string = String_val(string_v); long len = Long_val(len_v); static_tiger ((word64*)string, len, (word64*) digest); diff --git a/src/utils/lib/tiger.h b/src/utils/lib/tiger.h index 4371a8bd..0f8eaa01 100644 --- a/src/utils/lib/tiger.h +++ b/src/utils/lib/tiger.h @@ -30,6 +30,6 @@ typedef unsigned char byte; #define TREE_DEPTH 10 -void tiger_hash(char prefix, char *s, OFF_T len, unsigned char *digest); +void tiger_hash(char prefix, const char *s, OFF_T len, unsigned char *digest); OFF_T tiger_block_size(OFF_T len); #endif diff --git a/src/utils/net/ip.ml b/src/utils/net/ip.ml index 30d758af..156841f0 100644 --- a/src/utils/net/ip.ml +++ b/src/utils/net/ip.ml @@ -38,10 +38,10 @@ let to_ints t = let get_hi16 t = t.hi let get_lo16 t = t.lo -external ints_of_string : string -> (int*int*int*int) = "ml_ints_of_string" +external ints_of_string : bytes -> (int*int*int*int) = "ml_ints_of_string" let of_string s = - of_ints (ints_of_string s) + of_ints (ints_of_string (Bytes.of_string s)) let to_string t = let (a4, a3, a2, a1) = to_ints t in From 10bad811e098a50292fbdba8f87aabe425042db1 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 7 Jun 2024 18:31:14 +0200 Subject: [PATCH 60/69] Restore exception. --- src/utils/lib/CryptoPP.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/lib/CryptoPP.h b/src/utils/lib/CryptoPP.h index 8262affe..869662dd 100644 --- a/src/utils/lib/CryptoPP.h +++ b/src/utils/lib/CryptoPP.h @@ -4356,8 +4356,8 @@ class CRYPTOPP_DLL AlgorithmParametersBase : public NameValuePairs try #endif { - //if (m_throwIfNotUsed && !m_used) - // throw ParameterNotUsed(m_name); + if (m_throwIfNotUsed && !m_used) + throw ParameterNotUsed(m_name); } #ifndef CRYPTOPP_UNCAUGHT_EXCEPTION_AVAILABLE catch(...) From 2e1773af9dc6a9a468811439f6863535011ee09c Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Sat, 8 Jun 2024 03:08:27 +0200 Subject: [PATCH 61/69] Define CAML_NAME_SPACE before including caml/config.h header to avoid a conflict with libc++'s invalid_argument symbol. --- src/utils/lib/CryptoPP.h | 1 + 1 file changed, 1 insertion(+) diff --git a/src/utils/lib/CryptoPP.h b/src/utils/lib/CryptoPP.h index 869662dd..52d1009f 100644 --- a/src/utils/lib/CryptoPP.h +++ b/src/utils/lib/CryptoPP.h @@ -86,6 +86,7 @@ #define CRYPTOPP_H #include +#define CAML_NAME_SPACE #include #include From 71870fc1120e4c247665c7e6a1565bf7668a8163 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Sat, 8 Jun 2024 14:32:28 +0200 Subject: [PATCH 62/69] Use unsafe functions to improve performance. --- src/daemon/common/guiEncoding.ml | 2 +- src/networks/donkey/donkeyProtoClient.ml | 3 +-- src/networks/donkey/donkeyProtoKademlia.ml | 4 +--- src/networks/donkey/donkeyProtoServer.ml | 2 +- src/networks/fasttrack/fasttrackPandora.ml | 4 ++-- src/networks/fasttrack/fasttrackServers.ml | 6 +++--- src/networks/fileTP/fileTPSSH.ml | 2 +- src/networks/gnutella/gnutellaFunctions.ml | 8 ++++---- src/networks/gnutella/gnutellaHandler.ml | 2 +- src/utils/net/tcpBufferedSocket.ml | 5 +++-- src/utils/net/tcpBufferedSocket.mli | 1 + 11 files changed, 19 insertions(+), 20 deletions(-) diff --git a/src/daemon/common/guiEncoding.ml b/src/daemon/common/guiEncoding.ml index 6d0096c2..e6df8da7 100644 --- a/src/daemon/common/guiEncoding.ml +++ b/src/daemon/common/guiEncoding.ml @@ -47,7 +47,7 @@ let gui_send writer sock t = let s = Buffer.to_bytes buf in let len = Bytes.length s - 4 in str_int s 0 len; - write_string sock (Bytes.to_string s); + write_all_bytes sock s; with UnsupportedGuiMessage -> () (*************** diff --git a/src/networks/donkey/donkeyProtoClient.ml b/src/networks/donkey/donkeyProtoClient.ml index 8e14dab3..da73ed9c 100644 --- a/src/networks/donkey/donkeyProtoClient.ml +++ b/src/networks/donkey/donkeyProtoClient.ml @@ -25,7 +25,6 @@ open CommonTypes open LittleEndian open CommonGlobals open CommonOptions - open DonkeyTypes open DonkeyMftp @@ -1489,7 +1488,7 @@ and parse emule_version magic s = | 0xD4 -> (* 212 *) let s = Zlib2.uncompress_string2 (Bytes.of_string (String.sub s 1 (len-1))) in - let s = Printf.sprintf "%c%s" (char_of_int opcode) (Bytes.to_string s) in + let s = Printf.sprintf "%c%s" (char_of_int opcode) (Bytes.unsafe_to_string s) in begin try parse_emule_packet emule_version opcode (String.length s) s with diff --git a/src/networks/donkey/donkeyProtoKademlia.ml b/src/networks/donkey/donkeyProtoKademlia.ml index d7a6cc1d..89ba9568 100644 --- a/src/networks/donkey/donkeyProtoKademlia.ml +++ b/src/networks/donkey/donkeyProtoKademlia.ml @@ -445,12 +445,10 @@ module P = struct Bytes.cat kademlia_packed_header s in - let ss = Bytes.to_string s in - if !verbose_overnet then begin lprintf_nl "UDP to %s:%d op 0x%02X len %d type %s" - (Ip.to_string ip) port (get_uint8 ss 1) (String.length ss) (message_to_string msg); + (Ip.to_string ip) port (get_uint8_bytes s 1) (Bytes.length s) (message_to_string msg); end; (* let len = String.length s in diff --git a/src/networks/donkey/donkeyProtoServer.ml b/src/networks/donkey/donkeyProtoServer.ml index 0d5739df..24dc741f 100644 --- a/src/networks/donkey/donkeyProtoServer.ml +++ b/src/networks/donkey/donkeyProtoServer.ml @@ -1125,7 +1125,7 @@ let rec parse magic s = end | 0xD4 -> (* 212 *) let s = Zlib2.uncompress_string2 (Bytes.of_string (String.sub s 1 (len-1))) in - let s = Printf.sprintf "%c%s" (char_of_int opcode) (Bytes.to_string s) in + let s = Printf.sprintf "%c%s" (char_of_int opcode) (Bytes.unsafe_to_string s) in parse 227 s | _ -> diff --git a/src/networks/fasttrack/fasttrackPandora.ml b/src/networks/fasttrack/fasttrackPandora.ml index ce30521a..cc4122cb 100644 --- a/src/networks/fasttrack/fasttrackPandora.ml +++ b/src/networks/fasttrack/fasttrackPandora.ml @@ -244,13 +244,13 @@ let parse (s_out : bytes) (s_in : bytes) = begin let s = Bytes.make 8 '\000' in cipher_packet_set ciphers.out_cipher s 0; - lprintf "OUT CIPHER: [%s]\n" (Bytes.to_string (Bytes.escaped s)); + lprintf "OUT CIPHER: [%s]\n" (Bytes.unsafe_to_string (Bytes.escaped s)); end; begin let s = Bytes.make 8 '\000' in cipher_packet_set ciphers.in_cipher s 0; - lprintf "IN CIPHER: [%s]\n" (Bytes.to_string (Bytes.escaped s)); + lprintf "IN CIPHER: [%s]\n" (Bytes.unsafe_to_string (Bytes.escaped s)); end; ( diff --git a/src/networks/fasttrack/fasttrackServers.ml b/src/networks/fasttrack/fasttrackServers.ml index 1fbf3b5f..32380dde 100644 --- a/src/networks/fasttrack/fasttrackServers.ml +++ b/src/networks/fasttrack/fasttrackServers.ml @@ -131,13 +131,13 @@ let server_parse_netname s gconn sock = let buf = b.buf in let net = Bytes.sub buf start_pos len in if !verbose_msg_raw then - lprintf "net:[%s]\n" (String.escaped (Bytes.to_string net)); + lprintf "net:[%s]\n" (Bytes.unsafe_to_string (Bytes.escaped net)); let rec iter pos = if pos < end_pos then if (Bytes.get buf pos) = '\000' then begin let netname = Bytes.sub buf start_pos (pos-start_pos) in if !verbose_msg_raw then - lprintf "netname: [%s]\n" (String.escaped (Bytes.to_string netname)); + lprintf "netname: [%s]\n" (Bytes.unsafe_to_string (Bytes.escaped netname)); buf_used b (pos-start_pos+1); match s.server_ciphers with None -> assert false @@ -254,7 +254,7 @@ let connect_server h = cipher_packet_set out_cipher s 4; if !verbose_msg_raw then begin - lprintf "SENDING %s\n" (Bytes.to_string (Bytes.escaped s)); + lprintf "SENDING %s\n" (Bytes.unsafe_to_string (Bytes.escaped s)); AnyEndian.dump_bytes s; end; write sock s 0 (Bytes.length s); diff --git a/src/networks/fileTP/fileTPSSH.ml b/src/networks/fileTP/fileTPSSH.ml index b503e112..787f185d 100644 --- a/src/networks/fileTP/fileTPSSH.ml +++ b/src/networks/fileTP/fileTPSSH.ml @@ -182,7 +182,7 @@ let ssh_check_size file url start_download_file = close sock s); TcpBufferedSocket.set_reader sock (fun sock nread -> let b = TcpBufferedSocket.buf sock in - lprintf "SSH reader %d [%s]\n" nread (String.escaped (String.sub (Bytes.to_string b.buf) b.pos b.len)); + lprintf "SSH reader %d [%s]\n" nread (Bytes.unsafe_to_string (Bytes.escaped (Bytes.sub b.buf b.pos b.len))); let rec iter i = if i < b.len then if (Bytes.get b.buf (b.pos + i)) = '\n' then begin diff --git a/src/networks/gnutella/gnutellaFunctions.ml b/src/networks/gnutella/gnutellaFunctions.ml index 258a4711..e37a62cd 100644 --- a/src/networks/gnutella/gnutellaFunctions.ml +++ b/src/networks/gnutella/gnutellaFunctions.ml @@ -87,7 +87,7 @@ let default_handler gconn sock = let b = buf sock in if !verbose then lprintf "HttpReader: Handler not found for [%s]\n" - (String.escaped (Bytes.to_string (Bytes.sub b.buf b.pos b.len))); + (Bytes.unsafe_to_string (Bytes.escaped (Bytes.sub b.buf b.pos b.len))); close sock (Closed_for_error "not recognized"); failwith "Reply is not in the correct protocol" | Some f -> f gconn sock @@ -104,7 +104,7 @@ let handlers info gconn = let b = TcpBufferedSocket.buf sock in if monitored sock || !verbose_msg_raw then lprintf "iter_read %s :%d/%d\n%s\n" (Ip.to_string (peer_ip sock)) nread b.len - (String.escaped (String.sub (Bytes.to_string b.buf) b.pos b.len)); + (Bytes.unsafe_to_string (Bytes.escaped (Bytes.sub b.buf b.pos b.len))); if b.len > 0 then match gconn.gconn_handler with | HttpReader (n, hs, default) -> @@ -198,7 +198,7 @@ let handlers info gconn = | CipherReader (cipher, h) -> if monitored sock || !verbose_msg_raw then lprintf "CipherReader %d: [%s]\n" nread - (String.escaped (String.sub (Bytes.to_string b.buf) b.pos b.len)); + (Bytes.unsafe_to_string (Bytes.escaped (Bytes.sub b.buf b.pos b.len))); if nread > 0 then begin (* AnyEndian.dump_sub b.buf (b.pos + b.len - nread) nread; *) apply_cipher cipher b.buf (b.pos + b.len - nread) nread; @@ -208,7 +208,7 @@ let handlers info gconn = if monitored sock || !verbose_msg_raw then lprintf " deciphered: [%s]\n" - (String.escaped (String.sub (Bytes.to_string b.buf) b.pos b.len)); + (Bytes.unsafe_to_string (Bytes.escaped (Bytes.sub b.buf b.pos b.len))); end; let len = b.len in (try diff --git a/src/networks/gnutella/gnutellaHandler.ml b/src/networks/gnutella/gnutellaHandler.ml index 3b0abcbf..02349c4d 100644 --- a/src/networks/gnutella/gnutellaHandler.ml +++ b/src/networks/gnutella/gnutellaHandler.ml @@ -356,7 +356,7 @@ let init s sock gconn = let udp_client_handler ip port buf = if !verbose then - lprintf "Unexpected UDP packet: \n%s\n" (String.escaped (Bytes.to_string buf)) + lprintf "Unexpected UDP packet: \n%s\n" (Bytes.undafe_to_string (Bytes.escaped (Bytes.to_string buf))) let update_shared_files () = () diff --git a/src/utils/net/tcpBufferedSocket.ml b/src/utils/net/tcpBufferedSocket.ml index 616381f3..ee74690c 100644 --- a/src/utils/net/tcpBufferedSocket.ml +++ b/src/utils/net/tcpBufferedSocket.ml @@ -1618,14 +1618,15 @@ let write t s pos len = _to_deflate t; buf_add t wbuf s pos len +let write_string t s = write t (Bytes.of_string s) 0 (String.length s) +let write_all_bytes t data = write t data 0 (Bytes.length data) + (*************************************************************************) (* *) (* MAIN *) (* *) (*************************************************************************) -let write_string t s = write t (Bytes.of_string s) 0 (String.length s) - let _ = add_bandwidth_second_timer (fun _ -> reset_bandwidth_controlers (); diff --git a/src/utils/net/tcpBufferedSocket.mli b/src/utils/net/tcpBufferedSocket.mli index 3a2ffed4..c4dd3273 100644 --- a/src/utils/net/tcpBufferedSocket.mli +++ b/src/utils/net/tcpBufferedSocket.mli @@ -67,6 +67,7 @@ val set_refill : t -> (t -> unit) -> unit val set_rtimer : t -> (t -> unit) -> unit val write: t -> bytes -> int -> int -> unit val write_string: t -> string -> unit +val write_all_bytes: t -> bytes -> unit val connect: token -> string -> Unix.inet_addr -> int -> handler -> t val close : t -> BasicSocket.close_reason -> unit val closed : t -> bool From cc8d93d16faa58dbb9b02c6004ee187d8aecb77c Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Sat, 22 Jun 2024 16:50:40 +0200 Subject: [PATCH 63/69] Sync with upstream. --- config/configure.in | 9 - src/daemon/common/commonFile.ml | 4 +- src/daemon/common/commonInteractive.ml | 2 +- src/daemon/common/commonSwarming.ml | 4 +- src/daemon/common/commonUploads.ml | 22 +- src/daemon/common/giftDecoding.ml | 4 +- src/daemon/common/guiDecoding.ml | 6 +- src/daemon/common/guiDecoding.mli | 2 +- src/daemon/common/guiEncoding.ml | 2 +- src/daemon/driver/driverCommands.ml | 18 +- src/daemon/driver/driverControlers.ml | 8 +- src/daemon/driver/driverInterface.ml | 4 +- src/networks/bittorrent/bTClients.ml | 26 +- src/networks/bittorrent/bTOptions.ml | 6 +- src/networks/bittorrent/bTProtocol.ml | 28 +- src/networks/bittorrent/bTTorrent.ml | 3 +- src/networks/bittorrent/bT_DHT.ml | 20 +- src/networks/bittorrent/kademlia.ml | 14 +- src/networks/direct_connect/dcInteractive.ml | 2 +- src/networks/donkey/donkeyClient.ml | 7 +- src/networks/donkey/donkeyFiles.ml | 2 +- src/networks/donkey/donkeyOneFile.mli | 2 +- src/networks/donkey/donkeyPandora.ml | 5 +- src/networks/donkey/donkeyProtoClient.ml | 11 +- src/networks/donkey/donkeyProtoKademlia.ml | 4 +- src/networks/donkey/donkeyProtoServer.ml | 4 +- src/networks/fileTP/fileTPFTP.ml | 2 +- src/networks/fileTP/fileTPHTTP.ml | 2 +- src/networks/fileTP/fileTPSSH.ml | 24 +- src/networks/gnutella/gnutellaClients.ml | 2 +- src/utils/cdk/zlib2.ml | 8 +- src/utils/cdk/zlib2.mli | 2 +- src/utils/extlib/IO.ml | 1230 ++++++++++-------- src/utils/extlib/IO.mli | 127 +- src/utils/lib/url.ml | 13 +- src/utils/lib/url.mli | 5 +- src/utils/net/http_client.ml | 4 +- src/utils/net/tcpBufferedSocket.ml | 4 +- src/utils/net/tcpBufferedSocket.mli | 2 +- 39 files changed, 881 insertions(+), 763 deletions(-) diff --git a/config/configure.in b/config/configure.in index 95e497dd..3f991556 100644 --- a/config/configure.in +++ b/config/configure.in @@ -690,10 +690,6 @@ if test "$OCAMLVERSION" \< "$MINIMUM_OCAML"; then exit 1 fi -if test ! "$OCAMLVERSION" \< "4.03.0"; then - OCAMLC="$OCAMLC" -fi - if test "$OCAMLOPT" = "no"; then TARGET_TYPE=byte OCAMLLIB_EXT=cma @@ -707,11 +703,6 @@ else echo "******** Expected ocamlopt version $OCAMLVERSION , but got $OCAMLOPTVERSION *********" 1>&2; echo "******* Check http://ocaml.org/ ********" 1>&2; exit 1; } - - if test ! "$OCAMLVERSION" \< "4.03.0"; then - OCAMLOPT="$OCAMLOPT" - fi - fi echo "-------------------------------------------" diff --git a/src/daemon/common/commonFile.ml b/src/daemon/common/commonFile.ml index 630d006d..a1962145 100644 --- a/src/daemon/common/commonFile.ml +++ b/src/daemon/common/commonFile.ml @@ -895,7 +895,7 @@ parent.fstatus.location.href='submit?q=chgrp+'+v+'+%d'; let file_print_ed2k_link filename filesize md4hash = if md4hash = Md4.null then "" else Printf.sprintf "ed2k://|file|%s|%s|%s|/" - (Url.encode_to_string filename) (Int64.to_string filesize) (Md4.to_string md4hash) + (Url.encode filename) (Int64.to_string filesize) (Md4.to_string md4hash) (*************************************************************************) (* *) @@ -1137,7 +1137,7 @@ let file_write_bytes file offset s pos len = else Unix32.write (file_fd file) offset s pos len -let file_write_string file offset s pos len = file_write_bytes file offset (Bytes.of_string s) pos len +let file_write_string file offset s pos len = file_write_bytes file offset (Bytes.unsafe_of_string s) pos len let file_verify file key begin_pos end_pos = Unix32.flush_fd (file_fd file); diff --git a/src/daemon/common/commonInteractive.ml b/src/daemon/common/commonInteractive.ml index 70d6860e..81122108 100644 --- a/src/daemon/common/commonInteractive.ml +++ b/src/daemon/common/commonInteractive.ml @@ -356,7 +356,7 @@ let mail_for_completed_file file = incoming.shdir_dirname (if (file_owner file).user_commit_dir = "" then "" else Printf.sprintf "/%s" (file_owner file).user_commit_dir) - (Url.encode_to_string (file_best_name file)) + (Url.encode (file_best_name file)) in let line5 = if !!auto_commit then "" else diff --git a/src/daemon/common/commonSwarming.ml b/src/daemon/common/commonSwarming.ml index 4a417c2a..a74f046e 100644 --- a/src/daemon/common/commonSwarming.ml +++ b/src/daemon/common/commonSwarming.ml @@ -2792,7 +2792,7 @@ let range_range r = (r.range_begin, r.range_end) let received up file_begin str string_begin string_len = assert (string_begin >= 0); assert (string_len >= 0); - assert (string_begin + string_len <= Bytes.length str); + assert (string_begin + string_len <= String.length str); let t = up.up_t in let s = t.t_s in @@ -2909,7 +2909,7 @@ let received up file_begin str string_begin string_len = (Printexc2.to_string e) r.range_begin file_end (file_best_name t.t_file)); - file_write_bytes tprim.t_file + file_write_string tprim.t_file r.range_begin str string_pos string_length; range_received (Some t) r r.range_begin file_end; diff --git a/src/daemon/common/commonUploads.ml b/src/daemon/common/commonUploads.ml index 4d171d0d..a1b5f538 100644 --- a/src/daemon/common/commonUploads.ml +++ b/src/daemon/common/commonUploads.ml @@ -290,7 +290,7 @@ let shared_tree = new_shared_dir "" let md4_of_list md4s = let len = List.length md4s in - let s = String.create (len * 16) in + let s = Bytes.create (len * 16) in let rec iter list i = match list with [] -> () @@ -300,7 +300,7 @@ let md4_of_list md4s = iter tail (i+16) in iter md4s 0; - Md4.string (Bytes.to_string s) + Md4.string @@ Bytes.unsafe_to_string s let rec tiger_of_array array pos block = if block = 1 then @@ -312,11 +312,11 @@ let rec tiger_of_array array pos block = else let d1 = tiger_of_array array pos (block/2) in let d2 = tiger_of_array array (pos+block/2) (block/2) in - let s = String.create (1 + Tiger.length * 2) in + let s = Bytes.create (1 + Tiger.length * 2) in s.[0] <- '\001'; String.blit (TigerTree.direct_to_string d1) 0 s 1 Tiger.length; String.blit (TigerTree.direct_to_string d2) 0 s (1+Tiger.length) Tiger.length; - let t = Tiger.string (Bytes.to_string s) in + let t = Tiger.string @@ Bytes.unsafe_to_string s in let t = TigerTree.direct_of_string (Tiger.direct_to_string t) in t @@ -345,11 +345,11 @@ let rec tiger_pos2 nblocks = pos, list let tiger_node d1 d2 = - let s = String.create (1 + Tiger.length * 2) in + let s = Bytes.create (1 + Tiger.length * 2) in s.[0] <- '\001'; String.blit (TigerTree.direct_to_string d1) 0 s 1 Tiger.length; String.blit (TigerTree.direct_to_string d2) 0 s (1+Tiger.length) Tiger.length; - let t = Tiger.string (Bytes.to_string s) in + let t = Tiger.string @@ Bytes.unsafe_to_string s in let t = TigerTree.direct_of_string (Tiger.direct_to_string t) in t @@ -386,12 +386,12 @@ let rec fill_tiger_tree s list = let flatten_tiger_array array = let len = Array.length array in - let s = String.create ( len * TigerTree.length) in + let s = Bytes.create ( len * TigerTree.length) in for i = 0 to len - 1 do String.blit (TigerTree.direct_to_string array.(i)) 0 s (i * TigerTree.length) TigerTree.length done; - s + Bytes.unsafe_to_string s let unflatten_tiger_array s = let len = String.length s / TigerTree.length in @@ -416,7 +416,7 @@ let build_tiger_tree_file uid ttr = let s = make_tiger_tree ttr in Unix2.safe_mkdir "ttr"; Unix2.can_write_to_directory "ttr"; - File.from_string (Filename.concat "ttr" (Uid.to_file_string uid)) (Bytes.to_string s) + File.from_string (Filename.concat "ttr" (Uid.to_file_string uid)) s let rec start_job_for sh (wanted_id, handler) = let info = IndexedSharedFiles.get_result sh.shared_info in @@ -504,9 +504,9 @@ computation ??? *) let file_size = Unix32.getsize64 fd in let len64 = min 307200L file_size in let len = Int64.to_int len64 in - let s = String.create len in + let s = Bytes.create len in Unix32.read fd zero s 0 len; - Md5Ext.string (Bytes.to_string s) + Md5Ext.string @@ Bytes.unsafe_to_string s with e -> current_job := None; raise e diff --git a/src/daemon/common/giftDecoding.ml b/src/daemon/common/giftDecoding.ml index 06ded55d..c5434795 100755 --- a/src/daemon/common/giftDecoding.ml +++ b/src/daemon/common/giftDecoding.ml @@ -11,11 +11,11 @@ let gui_cut_messages f sock nread = try let rec iter pos len = if len = 0 then raise Not_found; - if Bytes.get b.buf pos = ';' && ( + if Bytes.get b.buf pos = ';' && ( pos = b.pos || (pos > b.pos && Bytes.get b.buf (pos-1) <> '\\')) then begin let len = pos - b.pos+1 in - let s = Bytes.sub b.buf b.pos len in + let s = Bytes.sub_string b.buf b.pos len in buf_used b len; f s; iter b.pos b.len diff --git a/src/daemon/common/guiDecoding.ml b/src/daemon/common/guiDecoding.ml index 43f16e31..60e2b431 100644 --- a/src/daemon/common/guiDecoding.ml +++ b/src/daemon/common/guiDecoding.ml @@ -42,12 +42,12 @@ let gui_cut_messages f sock nread = let b = buf sock in try while b.len >= 4 do - let msg_len = get_int_bytes b.buf b.pos in + let msg_len = get_int (Bytes.unsafe_to_string b.buf) b.pos in if b.len >= 4 + msg_len then begin - let s = Bytes.sub b.buf (b.pos+4) msg_len in + let s = Bytes.sub_string b.buf (b.pos+4) msg_len in buf_used b (msg_len + 4); - let opcode = get_int16_bytes s 0 in + let opcode = get_int16 s 0 in (f opcode s : unit) end else raise Not_found diff --git a/src/daemon/common/guiDecoding.mli b/src/daemon/common/guiDecoding.mli index 2fd0a9da..2bdf1337 100644 --- a/src/daemon/common/guiDecoding.mli +++ b/src/daemon/common/guiDecoding.mli @@ -23,5 +23,5 @@ val to_gui : int array -> int -> string -> GuiProto.to_gui val from_gui : int array -> int -> string -> GuiProto.from_gui val get_string : string -> int -> string * int -val gui_cut_messages : (int -> bytes -> unit) -> TcpBufferedSocket.t -> 'a -> unit +val gui_cut_messages : (int -> string -> unit) -> TcpBufferedSocket.t -> 'a -> unit diff --git a/src/daemon/common/guiEncoding.ml b/src/daemon/common/guiEncoding.ml index e6df8da7..b3f7788e 100644 --- a/src/daemon/common/guiEncoding.ml +++ b/src/daemon/common/guiEncoding.ml @@ -47,7 +47,7 @@ let gui_send writer sock t = let s = Buffer.to_bytes buf in let len = Bytes.length s - 4 in str_int s 0 len; - write_all_bytes sock s; + write_bytes sock s with UnsupportedGuiMessage -> () (*************** diff --git a/src/daemon/driver/driverCommands.ml b/src/daemon/driver/driverCommands.ml index 16dec6be..90e40a6a 100644 --- a/src/daemon/driver/driverCommands.ml +++ b/src/daemon/driver/driverCommands.ml @@ -1389,7 +1389,7 @@ let _ = (* can't close pipe_out in the already forked+executed process... *) let output = Buffer.create 1024 in let buffersize = 1024 in - let buffer = String.create buffersize in + let buffer = Bytes.create buffersize in (try while true do let nread = Unix.read pipe_out buffer 0 buffersize in @@ -1677,12 +1677,12 @@ let _ = if use_html_mods o then custom_commands := !custom_commands @ [ ( "bu bbig", name, - Printf.sprintf "mSub('output','custom=%s')" (Url.encode_to_string name), + Printf.sprintf "mSub('output','custom=%s')" (Url.encode name), name ) ; ] else Printf.bprintf buf "\\ %s \\\n" - (Url.encode_to_string name) name; + (Url.encode name) name; end else @@ -2295,14 +2295,14 @@ action=\\\"javascript:submitHtmlModsStyle();\\\"\\>"; onClick=\\\'javascript:{ parent.fstatus.location.href=\\\"submit?q=urlremove+\\\\\\\"%s\\\\\\\"\\\" setTimeout(\\\"window.location.reload()\\\",1000);}' - class=\\\"srb\\\"\\>Remove\\" (Url.encode_to_string w.url); + class=\\\"srb\\\"\\>Remove\\" (Url.encode w.url); Printf.bprintf buf " \\DL\\" (Url.encode_to_string w.url); + class=\\\"srb\\\"\\>DL\\" (Url.encode w.url); Printf.bprintf buf " \\%s\\ \\%d\\" w.url w.kind w.period; @@ -2563,7 +2563,7 @@ let _ = \\%s\\ \\%s\\\\" (html_mods_cntr ()) - (Url.encode_to_string dir) + (Url.encode dir) shared_dir.shdir_priority dir shared_dir.shdir_strategy @@ -4158,15 +4158,15 @@ let _ = (title, "sr", "\\" ^ title ^ "\\"); (title, "sr", "\\dllink\\" ^ " \\http\\" ^ " \\startbt\\" ) ]; diff --git a/src/daemon/driver/driverControlers.ml b/src/daemon/driver/driverControlers.ml index 6bc4909e..bb76ac25 100644 --- a/src/daemon/driver/driverControlers.ml +++ b/src/daemon/driver/driverControlers.ml @@ -766,9 +766,7 @@ let read_theme_page page = let theme_page = get_theme_page page in Unix2.tryopen_read theme_page (fun file -> let size = (Unix.stat theme_page).Unix.st_size in - let s = Bytes.make size ' ' in - really_input file s 0 size; - (Bytes.to_string s)) + really_input_string file size) let http_add_gen_header r = add_reply_header r "Server" ("MLdonkey/"^Autoconf.current_version); @@ -927,7 +925,7 @@ let send_preview r file fd size filename exten = add_reply_header r "Content-Disposition" (Printf.sprintf "inline;filename=\"%s\"" (Filename.basename filename)); - let s = String.create 200000 in + let s = Bytes.create 200000 in set_max_output_buffer r.sock (Bytes.length s); set_rtimeout r.sock 10000.; let rec stream_file file pos sock = @@ -1565,7 +1563,7 @@ let http_handler o t r = in r.reply_content <- if !http_file_type <> BIN && !!html_use_gzip then - Bytes.to_string (Zlib2.gzip_string s) + Bytes.unsafe_to_string (Zlib2.gzip_string s) else s let http_options = { diff --git a/src/daemon/driver/driverInterface.ml b/src/daemon/driver/driverInterface.ml index efdd4630..abd5e044 100644 --- a/src/daemon/driver/driverInterface.ml +++ b/src/daemon/driver/driverInterface.ml @@ -1211,7 +1211,7 @@ let gui_handler t event = TcpBufferedSocket.set_reader sock (GuiDecoding.gui_cut_messages (fun opcode s -> try - let m = GuiDecoding.from_gui gui.gui_proto_from_gui_version opcode (Bytes.to_string s) in + let m = GuiDecoding.from_gui gui.gui_proto_from_gui_version opcode s in gui_reader gui m sock; with GuiDecoding.FromGuiMessageNotImplemented -> () )); @@ -1250,7 +1250,7 @@ let gift_handler t event = TcpBufferedSocket.set_max_output_buffer sock !!interface_buffer; TcpBufferedSocket.set_reader sock (GiftDecoding.gui_cut_messages (fun s -> - let m = GiftDecoding.from_gui gui (Bytes.to_string s) in + let m = GiftDecoding.from_gui gui s in gui_reader gui m sock; )); TcpBufferedSocket.set_closer sock (gui_closed gui); diff --git a/src/networks/bittorrent/bTClients.ml b/src/networks/bittorrent/bTClients.ml index 5ecfbdc5..c3ef05bb 100644 --- a/src/networks/bittorrent/bTClients.ml +++ b/src/networks/bittorrent/bTClients.ml @@ -137,10 +137,10 @@ let talk_to_udp_tracker host port args file t need_sources = BasicSocket.set_rtimeout (sock socket) 60.; let txn = Random.int32 Int32.max_int in (* lprintf_nl "udpt txn %ld for %s" txn host; *) - write socket false (connect_request txn) ip port; + write socket false (Bytes.unsafe_of_string @@ connect_request txn) ip port; set_reader begin fun () -> let p = read socket in - let conn = connect_response p.udp_content txn in + let conn = connect_response (Bytes.unsafe_to_string p.udp_content) txn in (* lprintf_nl "udpt connection_id %Ld for %s" conn host; *) let txn = Random.int32 Int32.max_int in (* lprintf_nl "udpt txn' %ld for host %s" txn host; *) @@ -159,7 +159,7 @@ let talk_to_udp_tracker host port args file t need_sources = ~numwant:(if need_sources then try Int32.of_string (List.assoc "numwant" args) with _ -> -1l else 0l) (int_of_string (List.assoc "port" args)) in - write socket false req ip port; + write socket false (Bytes.unsafe_of_string req) ip port; set_reader (fun () -> let p = read socket in @@ -169,7 +169,7 @@ let talk_to_udp_tracker host port args file t need_sources = t.tracker_min_interval <- 600; if need_sources then t.tracker_last_clients_num <- 0; - let (interval,clients) = announce_response p.udp_content txn in + let (interval,clients) = announce_response (Bytes.unsafe_to_string p.udp_content) txn in if !verbose_msg_servers then lprintf_nl "udpt got interval %ld clients %d for host %s" interval (List.length clients) host; if interval > 0l then @@ -529,7 +529,7 @@ let is_bit_set s n = let set_bit s n = let i = n lsr 3 in - s.[i] <- Char.unsafe_chr (Char.code s.[i] lor bits.(n land 7)) + s.[i] <- Char.unsafe_chr (Char.code (Bytes.get s i) lor bits.(n land 7)) (* Official client seems to use max_range_request 5 and max_range_len 2^14 *) (* How much requests in the 'pipeline' *) @@ -537,10 +537,10 @@ let max_range_requests = 5 (* How much bytes we can request in one Piece *) let reserved () = - let s = String.make 8 '\x00' in + let s = Bytes.make 8 '\x00' in s.[7] <- (match !bt_dht with None -> '\x00' | Some _ -> '\x01'); s.[5] <- '\x10'; (* TODO bep9, bep10, notify clients about extended*) - s + Bytes.unsafe_to_string s (** handshake *) let send_init client_uid file_id sock = @@ -579,20 +579,20 @@ let send_bitfield c = lprintf_nl "Sending completed verified bitmap"; let nchunks = Array.length c.client_file.file_chunks in let len = (nchunks+7)/8 in - let s = String.make len '\000' in + let s = Bytes.make len '\000' in for i = 0 to nchunks - 1 do set_bit s i done; - s + Bytes.unsafe_to_string s | Some swarmer -> let bitmap = CommonSwarming.chunks_verified_bitmap swarmer in if !verbose_download then lprintf_nl "Sending verified bitmap: [%s]" (VB.to_string bitmap); let len = (VB.length bitmap + 7)/8 in - let s = String.make len '\000' in + let s = Bytes.make len '\000' in VB.iteri (fun i c -> if c = VB.State_verified then set_bit s i) bitmap; - s + Bytes.unsafe_to_string s )) let counter = ref 0 @@ -1385,7 +1385,7 @@ and client_to_client c sock msg = (* regexp ee is a fugly way to find the end of the 1st dict before the real payload *) let metaindex = (2 + (Str.search_forward (Str.regexp_string "ee") chunk 0 )) in let chunklength = ((String.length chunk) - metaindex) in - Unix32.write fd !fileindex chunk + Unix32.write fd !fileindex (Bytes.unsafe_of_string chunk) metaindex chunklength; fileindex := Int64.add !fileindex (Int64.of_int chunklength); @@ -1920,7 +1920,7 @@ let rec iter_upload sock c = end in (* lprintf "sending piece\n"; *) - send_client c (Piece (num, pos, upload_buffer, 0, len)); + send_client c (Piece (num, pos, Bytes.unsafe_to_string upload_buffer, 0, len)); iter_upload sock c with exn -> if !verbose then diff --git a/src/networks/bittorrent/bTOptions.ml b/src/networks/bittorrent/bTOptions.ml index 4915e583..d38fa190 100644 --- a/src/networks/bittorrent/bTOptions.ml +++ b/src/networks/bittorrent/bTOptions.ml @@ -36,13 +36,13 @@ let client_port = define_option bittorrent_section ["client_port"] *) let generate_client_uid = let client_uid_from_version = "-ML" ^ Autoconf.current_version ^ "-" in - let client_uid_random_tail = String.create (20 - (String.length client_uid_from_version)) in - let sl_client_uid_random_tail = String.length client_uid_random_tail in + let client_uid_random_tail = Bytes.create (20 - (String.length client_uid_from_version)) in + let sl_client_uid_random_tail = Bytes.length client_uid_random_tail in if sl_client_uid_random_tail > 0 then for i = 0 to sl_client_uid_random_tail - 1 do client_uid_random_tail.[i] <- char_of_int (Random.int 256) done; - client_uid_from_version ^ client_uid_random_tail + client_uid_from_version ^ Bytes.unsafe_to_string client_uid_random_tail let client_uid = define_option bittorrent_section ["client_uid"] "The UID of this client" diff --git a/src/networks/bittorrent/bTProtocol.ml b/src/networks/bittorrent/bTProtocol.ml index 6c91ef72..be610410 100644 --- a/src/networks/bittorrent/bTProtocol.ml +++ b/src/networks/bittorrent/bTProtocol.ml @@ -329,9 +329,9 @@ module TcpMessages = struct | DHT_Port n -> buf_int8 buf 9; buf_int16 buf n | Extended (n,msg) -> buf_int8 buf 20; buf_int8 buf n; Buffer.add_string buf msg end; - let s = Buffer.contents buf in - str_int s 0 (String.length s - 4); - s + let s = Buffer.to_bytes buf in + str_int s 0 (Bytes.length s - 4); + Bytes.unsafe_to_string s end (*************************************************************************) @@ -456,7 +456,7 @@ let bt_handler parse_fun handler c sock = then drop the connection) *) if b.len >= 20 then begin - let payload = String.sub b.buf b.pos 20 in + let payload = Bytes.sub_string b.buf b.pos 20 in let p = parse_fun (-1) payload in buf_used b 20; c.client_received_peer_id <- true; @@ -477,13 +477,13 @@ let bt_handler parse_fun handler c sock = raise (Wait_for_more "after_peer_id"); end; while b.len >= 4 do - let msg_len = get_int b.buf b.pos in + let msg_len = get_int (Bytes.unsafe_to_string b.buf) b.pos in if msg_len < 0 then begin let (ip,port) = (TcpBufferedSocket.peer_addr sock) in lprintf_nl "BT: Unknown message from %s:%d dropped!! peerid:%b data_len:%i msg_len:%i software: %s" (Ip.to_string ip) port c.client_received_peer_id b.len msg_len (brand_to_string c.client_brand); - dump (String.sub b.buf b.pos (min b.len 30)); + dump (Bytes.sub_string b.buf b.pos (min b.len 30)); buf_used b b.len; close sock Closed_by_user; end @@ -494,7 +494,7 @@ let bt_handler parse_fun handler c sock = let (ip,port) = (TcpBufferedSocket.peer_addr sock) in lprintf_nl "btprotocol.bt_handler: closed connection from %s:%d because of too much data!! data_len:%i msg_len:%i software: %s" (Ip.to_string ip) port b.len msg_len (brand_to_string c.client_brand); - dump (String.sub b.buf b.pos (min b.len 30)); + dump (Bytes.sub_string b.buf b.pos (min b.len 30)); buf_used b b.len; close sock Closed_by_user end @@ -503,9 +503,9 @@ let bt_handler parse_fun handler c sock = buf_used b 4; (* lprintf "Message complete: %d\n" msg_len; *) if msg_len > 0 then - let opcode = get_int8 b.buf b.pos in + let opcode = get_int8 (Bytes.unsafe_to_string b.buf) b.pos in (* FIXME sub *) - let payload = String.sub b.buf (b.pos+1) (msg_len-1) in + let payload = Bytes.sub_string b.buf (b.pos+1) (msg_len-1) in buf_used b msg_len; (* lprintf "Opcode %d\n" opcode; *) try @@ -543,7 +543,7 @@ let handlers info gconn = match gconn.gconn_handler with | BTHeader h -> (* dump (String.sub b.buf b.pos (min b.len 100)); *) - let slen = get_int8 b.buf b.pos in + let slen = get_int8 (Bytes.unsafe_to_string b.buf) b.pos in if slen + 29 <= b.len then begin (* get proto and file_id from handshake, @@ -552,14 +552,14 @@ let handlers info gconn = *) (* let proto = String.sub b.buf (b.pos+1) slen in *) let file_id = Sha1.direct_of_string - (String.sub b.buf (b.pos+9+slen) 20) in - let proto,pos = get_string8 b.buf b.pos in - let rbits = (String.sub b.buf (b.pos+pos) 8) in + (Bytes.sub_string b.buf (b.pos+9+slen) 20) in + let proto,pos = get_string8 (Bytes.unsafe_to_string b.buf) b.pos in + let rbits = (Bytes.sub_string b.buf (b.pos+pos) 8) in buf_used b (slen+29); h gconn sock (proto, rbits, file_id); end else - if (String.sub b.buf b.pos (min b.len 100)) = "NATCHECK_HANDSHAKE" then + if (Bytes.sub_string b.buf b.pos (min b.len 100)) = "NATCHECK_HANDSHAKE" then write_string sock (Printf.sprintf "azureus_rand_%d" !azureus_porttest_random) else if (TcpBufferedSocket.closed sock) then let (ip,port) = (TcpBufferedSocket.peer_addr sock) in diff --git a/src/networks/bittorrent/bTTorrent.ml b/src/networks/bittorrent/bTTorrent.ml index 26ff2096..97c6b167 100644 --- a/src/networks/bittorrent/bTTorrent.ml +++ b/src/networks/bittorrent/bTTorrent.ml @@ -328,11 +328,12 @@ let decode_torrent s = let encode_torrent torrent = let npieces = Array.length torrent.torrent_pieces in - let pieces = String.create (20 * npieces) in + let pieces = Bytes.create (20 * npieces) in for i = 0 to npieces - 1 do String.blit (Sha1.direct_to_string torrent.torrent_pieces.(i)) 0 pieces (i*20) 20 done; + let pieces = Bytes.unsafe_to_string pieces in let encode_file (filename, size) = Dictionary [ diff --git a/src/networks/bittorrent/bT_DHT.ml b/src/networks/bittorrent/bT_DHT.ml index 71569ed2..dab49460 100644 --- a/src/networks/bittorrent/bT_DHT.ml +++ b/src/networks/bittorrent/bT_DHT.ml @@ -125,7 +125,7 @@ let send sock stats (ip,port as addr) txnmsg = if !debug then lprintf_nl "KRPC to %s : %S" (show_addr addr) s; stats_add stats `Sent 1; stats_add stats `SentBytes (String.length s); - write sock false s ip port + write sock false (Bytes.unsafe_of_string s) ip port type stats_key = [ `Timeout | `Sent | `SentBytes | `Recv | `RecvBytes | `Decoded | `Handled | `NoTxn ] type t = @@ -197,16 +197,16 @@ let create port enabler bw_control answer : t = let addr = (Ip.of_inet_addr inet_addr, port) in let ret = ref None in try - stats_add stats `RecvBytes (String.length p.udp_content); + stats_add stats `RecvBytes (Bytes.length p.udp_content); stats_add stats `Recv 1; - let r = decode_exn p.udp_content in + let r = decode_exn @@ Bytes.unsafe_to_string p.udp_content in stats_add stats `Decoded 1; ret := Some r; handle addr r; stats_add stats `Handled 1; with exn -> let version = match !ret with Some (_,Some s,_) -> sprintf " client %S" s | _ -> "" in - if !verb then lprintf_nl ~exn "handle packet from %s%s : %S" (show_addr addr) version p.udp_content; + if !verb then lprintf_nl ~exn "handle packet from %s%s : %S" (show_addr addr) version (Bytes.unsafe_to_string p.udp_content); let error txn code str = send socket stats addr (txn,(Error (Int64.of_int code,str))) in match exn,!ret with | Malformed_packet x, Some (txn, _, _) @@ -308,20 +308,20 @@ let make_peer (ip,port) = assert (port <= 0xffff); let (a,b,c,d) = Ip.to_ints ip in let e = port lsr 8 and f = port land 0xff in - let s = String.create 6 in + let s = Bytes.create 6 in let set i c = s.[i] <- char_of_int c in set 0 a; set 1 b; set 2 c; set 3 d; set 4 e; set 5 f; - s + Bytes.unsafe_to_string s let make_nodes nodes = - let s = String.create (26 * List.length nodes) in + let s = Bytes.create (26 * List.length nodes) in let i = ref 0 in List.iter (fun (id,addr) -> - String.blit (H.direct_to_string id) 0 s (!i*26) 20; - String.blit (make_peer addr) 0 s (!i*26+20) 6; + Bytes.blit_string (H.direct_to_string id) 0 s (!i*26) 20; + Bytes.blit_string (make_peer addr) 0 s (!i*26+20) 6; incr i ) nodes; - s + Bytes.unsafe_to_string s let parse_response_exn q dict = let get k = List.assoc k dict in diff --git a/src/networks/bittorrent/kademlia.ml b/src/networks/bittorrent/kademlia.ml index c6d901f3..017b5bd6 100644 --- a/src/networks/bittorrent/kademlia.ml +++ b/src/networks/bittorrent/kademlia.ml @@ -72,14 +72,14 @@ let cmp id1 id2 = let inside node hash = not (cmp hash node.lo = LT || cmp hash node.hi = GT) let middle = - let s = String.make 20 (Char.chr 0xFF) in + let s = Bytes.make 20 (Char.chr 0xFF) in s.[0] <- Char.chr 0x7F; - H.direct_of_string s + H.direct_of_string @@ Bytes.unsafe_to_string s let middle' = - let s = String.make 20 (Char.chr 0x00) in + let s = Bytes.make 20 (Char.chr 0x00) in s.[0] <- Char.chr 0x80; - H.direct_of_string s + H.direct_of_string @@ Bytes.unsafe_to_string s let last = H.direct_of_string (String.make 20 (Char.chr 0xFF)) @@ -95,16 +95,16 @@ let big_int_of_hash h = !n let hash_of_big_int n = - let s = String.create H.length in + let s = Bytes.create H.length in let n = ref n in let div = big_int_of_int 256 in - for i = String.length s - 1 downto 0 do + for i = Bytes.length s - 1 downto 0 do let (d,m) = quomod_big_int !n div in s.[i] <- Char.chr (int_of_big_int m); n := d done; assert (eq_big_int zero_big_int !n); - H.direct_of_string s + H.direct_of_string @@ Bytes.unsafe_to_string s let big_int_2 = big_int_of_int 2 (* hash <-> number *) diff --git a/src/networks/direct_connect/dcInteractive.ml b/src/networks/direct_connect/dcInteractive.ml index 87e252b8..ce31df29 100644 --- a/src/networks/direct_connect/dcInteractive.ml +++ b/src/networks/direct_connect/dcInteractive.ml @@ -105,7 +105,7 @@ let parse_url url user group = let register_commands list = register_commands (List2.tail_map (fun (n,f,h) -> (n, "Direct Connect", f,h)) list) -let command l = String.concat "+" (List.map Url.encode_to_string l) +let command l = String.concat "+" (List.map Url.encode l) let td_command text title ?(blink=false) ?(target=`Output) cmd = Printf.sprintf diff --git a/src/networks/donkey/donkeyClient.ml b/src/networks/donkey/donkeyClient.ml index 77503ea5..5ccdac8a 100644 --- a/src/networks/donkey/donkeyClient.ml +++ b/src/networks/donkey/donkeyClient.ml @@ -1603,7 +1603,7 @@ is checked for the file. if !verbose_download then lprintf_nl "Complete compressed block received!"; - let s = String.create comp.comp_len in + let s = Bytes.create comp.comp_len in let rec iter list = match list with [] -> 0 @@ -1615,12 +1615,13 @@ is checked for the file. in let pos = iter comp.comp_blocs in assert (pos = comp.comp_len); + let s = Bytes.unsafe_to_string s in let s = Zlib2.uncompress_string2 s in if !verbose_download then - lprintf_nl "Decompressed: %d/%d" (Bytes.length s) comp.comp_len; + lprintf_nl "Decompressed: %d/%d" (String.length s) comp.comp_len; DonkeyOneFile.block_received c comp.comp_md4 - comp.comp_pos s 0 (Bytes.length s); + comp.comp_pos s 0 (String.length s); c.client_comp <- None; end else diff --git a/src/networks/donkey/donkeyFiles.ml b/src/networks/donkey/donkeyFiles.ml index 84cca7b7..e2053847 100644 --- a/src/networks/donkey/donkeyFiles.ml +++ b/src/networks/donkey/donkeyFiles.ml @@ -78,7 +78,7 @@ module NewUpload = struct B.usesixtyfour = (begin_pos ++ (Int64.of_int len_int)) > old_max_emule_file_size; B.start_pos = begin_pos; B.end_pos = begin_pos ++ (Int64.of_int len_int); - B.bloc_str = Bytes.empty; + B.bloc_str = ""; B.bloc_begin = 0; B.bloc_len = 0; } diff --git a/src/networks/donkey/donkeyOneFile.mli b/src/networks/donkey/donkeyOneFile.mli index 6a704bf9..9df79577 100644 --- a/src/networks/donkey/donkeyOneFile.mli +++ b/src/networks/donkey/donkeyOneFile.mli @@ -23,7 +23,7 @@ val get_from_client : DonkeyTypes.client -> unit val request_slot : DonkeyTypes.client -> unit val check_files_downloaded : unit -> unit val block_received : - DonkeyTypes.client -> Md4.t -> int64 -> bytes -> int -> int -> unit + DonkeyTypes.client -> Md4.t -> int64 -> string -> int -> int -> unit val add_client_chunks : DonkeyTypes.client -> DonkeyTypes.file -> Bitv.t -> unit val unshare_file : DonkeyTypes.file -> unit diff --git a/src/networks/donkey/donkeyPandora.ml b/src/networks/donkey/donkeyPandora.ml index aba691e4..a48e38df 100644 --- a/src/networks/donkey/donkeyPandora.ml +++ b/src/networks/donkey/donkeyPandora.ml @@ -172,7 +172,7 @@ let client_parse c opcode s = if comp.comp_len = comp.comp_total then begin lprintf "Compressed bloc received !!!!!!\n"; - let s = String.create comp.comp_len in + let s = Bytes.create comp.comp_len in let rec iter list = match list with [] -> 0 @@ -183,9 +183,10 @@ let client_parse c opcode s = pos + len in let pos = iter comp.comp_blocs in + let s = Bytes.unsafe_to_string s in assert (pos = comp.comp_len); let s = Zlib2.uncompress_string2 s in - lprintf "Decompressed: %d/%d\n" (Bytes.length s) comp.comp_len; + lprintf "Decompressed: %d/%d\n" (String.length s) comp.comp_len; c.client_comp <- None; end else diff --git a/src/networks/donkey/donkeyProtoClient.ml b/src/networks/donkey/donkeyProtoClient.ml index da73ed9c..64b70cce 100644 --- a/src/networks/donkey/donkeyProtoClient.ml +++ b/src/networks/donkey/donkeyProtoClient.ml @@ -25,6 +25,7 @@ open CommonTypes open LittleEndian open CommonGlobals open CommonOptions + open DonkeyTypes open DonkeyMftp @@ -495,7 +496,7 @@ module Bloc = struct usesixtyfour : bool; start_pos : int64; end_pos: int64; - bloc_str: bytes; + bloc_str: string; bloc_begin : int; bloc_len : int; } @@ -506,7 +507,7 @@ module Bloc = struct usesixtyfour = usesixtyfour; start_pos = if usesixtyfour then get_int64 s 17 else get_uint64_32 s 17; end_pos = if usesixtyfour then get_int64 s 25 else get_uint64_32 s 21; - bloc_str = (Bytes.of_string s); + bloc_str = s; bloc_begin = if usesixtyfour then 33 else 25; bloc_len = if usesixtyfour then len - 33 else len - 25; } @@ -521,7 +522,7 @@ module Bloc = struct buf_md4 buf t.md4; if t.usesixtyfour then buf_int64 buf t.start_pos else buf_int64_32 buf t.start_pos; if t.usesixtyfour then buf_int64 buf t.end_pos else buf_int64_32 buf t.end_pos; - Buffer.add_subbytes buf t.bloc_str t.bloc_begin t.bloc_len + Buffer.add_substring buf t.bloc_str t.bloc_begin t.bloc_len end module QueryBloc = struct @@ -1487,8 +1488,8 @@ and parse emule_version magic s = | 0xD4 -> (* 212 *) - let s = Zlib2.uncompress_string2 (Bytes.of_string (String.sub s 1 (len-1))) in - let s = Printf.sprintf "%c%s" (char_of_int opcode) (Bytes.unsafe_to_string s) in + let s = Zlib2.uncompress_string2 (String.sub s 1 (len-1)) in + let s = Printf.sprintf "%c%s" (char_of_int opcode) s in begin try parse_emule_packet emule_version opcode (String.length s) s with diff --git a/src/networks/donkey/donkeyProtoKademlia.ml b/src/networks/donkey/donkeyProtoKademlia.ml index 89ba9568..0cef6fc8 100644 --- a/src/networks/donkey/donkeyProtoKademlia.ml +++ b/src/networks/donkey/donkeyProtoKademlia.ml @@ -419,7 +419,7 @@ module P = struct else let magic = Bytes.get pbuf 0 in let opcode = int_of_char (Bytes.get pbuf 1) in - let msg = Bytes.sub pbuf 2 (len-2) in + let msg = Bytes.sub_string pbuf 2 (len-2) in let msg = if magic = kademlia_packed_header_code then let s = Zlib2.uncompress_string2 msg in (* lprintf "Uncompressed:\n"; @@ -427,7 +427,7 @@ module P = struct s else msg in - let t = parse ip port opcode (Bytes.to_string msg) in + let t = parse ip port opcode msg in t let udp_send sock ip port ping msg = diff --git a/src/networks/donkey/donkeyProtoServer.ml b/src/networks/donkey/donkeyProtoServer.ml index 24dc741f..ddcc40c8 100644 --- a/src/networks/donkey/donkeyProtoServer.ml +++ b/src/networks/donkey/donkeyProtoServer.ml @@ -1124,8 +1124,8 @@ let rec parse magic s = raise Not_found end | 0xD4 -> (* 212 *) - let s = Zlib2.uncompress_string2 (Bytes.of_string (String.sub s 1 (len-1))) in - let s = Printf.sprintf "%c%s" (char_of_int opcode) (Bytes.unsafe_to_string s) in + let s = Zlib2.uncompress_string2 (String.sub s 1 (len-1)) in + let s = Printf.sprintf "%c%s" (char_of_int opcode) s in parse 227 s | _ -> diff --git a/src/networks/fileTP/fileTPFTP.ml b/src/networks/fileTP/fileTPFTP.ml index 14e1bfba..bce22801 100644 --- a/src/networks/fileTP/fileTPFTP.ml +++ b/src/networks/fileTP/fileTPFTP.ml @@ -79,7 +79,7 @@ end_pos !counter_pos b.len to_read; let old_downloaded = CommonSwarming.downloaded swarmer in - CommonSwarming.received up !counter_pos b.buf b.pos to_read_int; + CommonSwarming.received up !counter_pos (Bytes.unsafe_to_string b.buf) b.pos to_read_int; let new_downloaded = CommonSwarming.downloaded swarmer in c.client_total_downloaded <- c.client_total_downloaded ++ (new_downloaded -- old_downloaded); diff --git a/src/networks/fileTP/fileTPHTTP.ml b/src/networks/fileTP/fileTPHTTP.ml index e06d001f..62d6fe4c 100644 --- a/src/networks/fileTP/fileTPHTTP.ml +++ b/src/networks/fileTP/fileTPHTTP.ml @@ -264,7 +264,7 @@ let rec client_parse_header c gconn sock header = let old_downloaded = CommonSwarming.downloaded swarmer in - CommonSwarming.received up !counter_pos b.buf b.pos to_read_int; + CommonSwarming.received up !counter_pos (Bytes.unsafe_to_string b.buf) b.pos to_read_int; let new_downloaded = CommonSwarming.downloaded swarmer in c.client_total_downloaded <- c.client_total_downloaded ++ (new_downloaded -- old_downloaded); diff --git a/src/networks/fileTP/fileTPSSH.ml b/src/networks/fileTP/fileTPSSH.ml index 787f185d..b411abff 100644 --- a/src/networks/fileTP/fileTPSSH.ml +++ b/src/networks/fileTP/fileTPSSH.ml @@ -56,7 +56,7 @@ let shell_command hostname = (*************************************************************************) let segment_received c num s pos = - if Bytes.length s > 0 then + if String.length s > 0 then let d = match c.client_downloads with [] -> disconnect_client c Closed_by_user; raise Exit @@ -85,7 +85,7 @@ let segment_received c num s pos = CommonSwarming.downloaded swarmer in CommonSwarming.received up - pos s 0 (Bytes.length s); + pos s 0 (String.length s); let new_downloaded = CommonSwarming.downloaded swarmer in @@ -182,14 +182,14 @@ let ssh_check_size file url start_download_file = close sock s); TcpBufferedSocket.set_reader sock (fun sock nread -> let b = TcpBufferedSocket.buf sock in - lprintf "SSH reader %d [%s]\n" nread (Bytes.unsafe_to_string (Bytes.escaped (Bytes.sub b.buf b.pos b.len))); + lprintf "SSH reader %d [%s]\n" nread (String.escaped (Bytes.sub_string b.buf b.pos b.len)); let rec iter i = if i < b.len then - if (Bytes.get b.buf (b.pos + i)) = '\n' then begin - let slen = if i > 0 && (Bytes.get b.buf (b.pos + i - 1)) = '\r' then + if Bytes.get b.buf (b.pos + i) = '\n' then begin + let slen = if i > 0 && Bytes.get b.buf (b.pos + i - 1) = '\r' then i - 1 else i in - let line = String.sub (Bytes.to_string b.buf) b.pos slen in + let line = Bytes.sub_string b.buf b.pos slen in lprintf "SSH LINE [%s]\n" line; buf_used b (i+1); if String2.starts_with line "[SIZE " then begin @@ -245,7 +245,7 @@ let ssh_connect token c f = if b.len >= elen then begin segment := SegmentX (file_num, pos, len, elen, - String.sub (Bytes.to_string b.buf) b.pos elen); + Bytes.sub_string b.buf b.pos elen); buf_used b elen; iter0 0 end @@ -255,11 +255,11 @@ let ssh_connect token c f = and iter0 i = if i < b.len then - if (Bytes.get b.buf (b.pos + i)) = '\n' then begin - let slen = if i > 0 && (Bytes.get b.buf (b.pos + i - 1)) = '\r' then + if Bytes.get b.buf (b.pos + i) = '\n' then begin + let slen = if i > 0 && Bytes.get b.buf (b.pos + i - 1) = '\r' then i - 1 else i in - let line = String.sub (Bytes.to_string b.buf) b.pos slen in + let line = Bytes.sub_string b.buf b.pos slen in (* lprintf "SSH LINE [%s]\n" line; *) buf_used b (i+1); @@ -296,7 +296,7 @@ let ssh_connect token c f = (* lprintf "Received/expected: %d/%d\n" (String.length s) elen; *) - let ss = Base64.decode s in + let ss = Bytes.unsafe_to_string (Base64.decode s) in (* lprintf "Decoded/expected: %d/%d\n" (String.length ss) len; *) @@ -306,7 +306,7 @@ let ssh_connect token c f = | SegmentX (file_num, pos, len, elen, ss) -> lprintf "******* SEGMENT RECEIVED *******\n"; - segment_received c file_num (Bytes.of_string ss) pos; + segment_received c file_num ss pos; segment := Nothing; iter0 0 | _ -> diff --git a/src/networks/gnutella/gnutellaClients.ml b/src/networks/gnutella/gnutellaClients.ml index d364e5ff..ab440993 100644 --- a/src/networks/gnutella/gnutellaClients.ml +++ b/src/networks/gnutella/gnutellaClients.ml @@ -266,7 +266,7 @@ and read_some d c counter_pos b to_read_int = begin try CommonSwarming.received up - counter_pos b.buf b.pos to_read_int; + counter_pos (Bytes.unsafe_to_string b.buf) b.pos to_read_int; with e -> lprintf "FT: Exception %s in CommonSwarming.received\n" (Printexc2.to_string e); diff --git a/src/utils/cdk/zlib2.ml b/src/utils/cdk/zlib2.ml index 87489dc5..1e16b774 100644 --- a/src/utils/cdk/zlib2.ml +++ b/src/utils/cdk/zlib2.ml @@ -87,19 +87,19 @@ let gzip_string ?(level = 6) instr = let uncompress_string2 inbuf = let zs = inflate_init true in let rec uncompr inpos outbuf outpos = - let inavail = Bytes.length inbuf - inpos in + let inavail = String.length inbuf - inpos in let outavail = Bytes.length outbuf - outpos in if outavail = 0 then uncompr inpos (grow_buffer outbuf) outpos else begin let (finished, used_in, used_out) = - inflate zs inbuf inpos inavail outbuf outpos outavail Z_SYNC_FLUSH in + inflate_string zs inbuf inpos inavail outbuf outpos outavail Z_SYNC_FLUSH in if finished then - Bytes.sub outbuf 0 (outpos + used_out) + Bytes.sub_string outbuf 0 (outpos + used_out) else uncompr (inpos + used_in) outbuf (outpos + used_out) end in - let res = uncompr 0 (String.create (2 * Bytes.length inbuf)) 0 in + let res = uncompr 0 (Bytes.create (2 * String.length inbuf)) 0 in inflate_end zs; res diff --git a/src/utils/cdk/zlib2.mli b/src/utils/cdk/zlib2.mli index 01eaee83..f7ec113f 100644 --- a/src/utils/cdk/zlib2.mli +++ b/src/utils/cdk/zlib2.mli @@ -1,6 +1,6 @@ val uncompress_string : string -> string -val uncompress_string2 : bytes -> bytes +val uncompress_string2 : string -> string val compress_string : ?level:int -> bytes -> bytes val gzip_string : ?level:int -> string -> bytes val gzip_bytes : ?level:int -> bytes -> bytes diff --git a/src/utils/extlib/IO.ml b/src/utils/extlib/IO.ml index bcbe288b..d5b07719 100644 --- a/src/utils/extlib/IO.ml +++ b/src/utils/extlib/IO.ml @@ -18,17 +18,23 @@ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) +(* #if OCAML < 407 *) +module Stdlib = Pervasives +(* #endif *) + +(* open ExtBytes *) + type input = { - mutable in_read : unit -> char; - mutable in_input : Bytes.t -> int -> int -> int; - mutable in_close : unit -> unit; + mutable in_read : unit -> char; + mutable in_input : Bytes.t -> int -> int -> int; + mutable in_close : unit -> unit; } type 'a output = { - mutable out_write : char -> unit; - mutable out_output : Bytes.t -> int -> int -> int; - mutable out_close : unit -> 'a; - mutable out_flush : unit -> unit; + mutable out_write : char -> unit; + mutable out_output : Bytes.t -> int -> int -> int; + mutable out_close : unit -> 'a; + mutable out_flush : unit -> unit; } exception No_more_input @@ -41,122 +47,127 @@ exception Output_closed let default_close = (fun () -> ()) let create_in ~read ~input ~close = - { - in_read = read; - in_input = input; - in_close = close; - } + { + in_read = read; + in_input = input; + in_close = close; + } let create_out ~write ~output ~flush ~close = - { - out_write = write; - out_output = output; - out_close = close; - out_flush = flush; - } + { + out_write = write; + out_output = output; + out_close = close; + out_flush = flush; + } let read i = i.in_read() let nread i n = - if n < 0 then invalid_arg "IO.nread"; - if n = 0 then Bytes.empty - else - let s = Bytes.create n in - let l = ref n in - let p = ref 0 in - try - while !l > 0 do - let r = i.in_input s !p !l in - if r = 0 then raise No_more_input; - p := !p + r; - l := !l - r; - done; - s - with - No_more_input as e -> - if !p = 0 then raise e; - Bytes.sub s 0 !p + if n < 0 then invalid_arg "IO.nread"; + if n = 0 then Bytes.empty + else + let s = Bytes.create n in + let l = ref n in + let p = ref 0 in + try + while !l > 0 do + let r = i.in_input s !p !l in + if r = 0 then raise No_more_input; + p := !p + r; + l := !l - r; + done; + s + with + No_more_input as e -> + if !p = 0 then raise e; + Bytes.sub s 0 !p let nread_string i n = - (* [nread] transfers ownership of the returned string, so - [unsafe_to_string] is safe here *) - Bytes.unsafe_to_string (nread i n) + (* [nread] transfers ownership of the returned string, so + [unsafe_to_string] is safe here *) + Bytes.unsafe_to_string (nread i n) let really_output o s p l' = - let sl = Bytes.length s in - if p + l' > sl || p < 0 || l' < 0 then invalid_arg "IO.really_output"; - let l = ref l' in - let p = ref p in - while !l > 0 do - let w = o.out_output s !p !l in - if w = 0 then raise Sys_blocked_io; - p := !p + w; - l := !l - w; - done; - l' + let sl = Bytes.length s in + if p + l' > sl || p < 0 || l' < 0 then invalid_arg "IO.really_output"; + let l = ref l' in + let p = ref p in + while !l > 0 do + let w = o.out_output s !p !l in + if w = 0 then raise Sys_blocked_io; + p := !p + w; + l := !l - w; + done; + l' let input i s p l = - let sl = Bytes.length s in - if p + l > sl || p < 0 || l < 0 then invalid_arg "IO.input"; - if l = 0 then - 0 - else - i.in_input s p l + let sl = Bytes.length s in + if p + l > sl || p < 0 || l < 0 then invalid_arg "IO.input"; + if l = 0 then + 0 + else + i.in_input s p l let really_input i s p l' = - let sl = Bytes.length s in - if p + l' > sl || p < 0 || l' < 0 then invalid_arg "IO.really_input"; - let l = ref l' in - let p = ref p in - while !l > 0 do - let r = i.in_input s !p !l in - if r = 0 then raise Sys_blocked_io; - p := !p + r; - l := !l - r; - done; - l' + let sl = Bytes.length s in + if p + l' > sl || p < 0 || l' < 0 then invalid_arg "IO.really_input"; + let l = ref l' in + let p = ref p in + while !l > 0 do + let r = i.in_input s !p !l in + if r = 0 then raise Sys_blocked_io; + p := !p + r; + l := !l - r; + done; + l' let really_nread i n = - if n < 0 then invalid_arg "IO.really_nread"; - if n = 0 then Bytes.empty - else - let s = Bytes.create n - in - ignore(really_input i s 0 n); - s + if n < 0 then invalid_arg "IO.really_nread"; + if n = 0 then Bytes.empty + else + let s = Bytes.create n + in + ignore(really_input i s 0 n); + s + let really_nread_string i n = - (* [really_nread] transfers ownership of the returned string, - so [unsafe_to_string] is safe here *) - Bytes.unsafe_to_string (really_nread i n) + (* [really_nread] transfers ownership of the returned string, + so [unsafe_to_string] is safe here *) + Bytes.unsafe_to_string (really_nread i n) let close_in i = - let f _ = raise Input_closed in - i.in_close(); - i.in_read <- f; - i.in_input <- f; - i.in_close <- f + let f _ = raise Input_closed in + i.in_close(); + i.in_read <- f; + i.in_input <- f; + i.in_close <- f let write o x = o.out_write x let nwrite o s = - let p = ref 0 in + let p = ref 0 in let l = ref (Bytes.length s) in - while !l > 0 do - let w = o.out_output s !p !l in - if w = 0 then raise Sys_blocked_io; - p := !p + w; - l := !l - w; - done + while !l > 0 do + let w = o.out_output s !p !l in + if w = 0 then raise Sys_blocked_io; + p := !p + w; + l := !l - w; + done let nwrite_string o s = - (* [nwrite] does not mutate or capture its [bytes] input, - so using [Bytes.unsafe_of_string] is safe here *) - nwrite o (Bytes.unsafe_of_string s) + (* [nwrite] does not mutate or capture its [bytes] input, + so using [Bytes.unsafe_of_string] is safe here *) + nwrite o (Bytes.unsafe_of_string s) let output o s p l = - let sl = Bytes.length s in - if p + l > sl || p < 0 || l < 0 then invalid_arg "IO.output"; - o.out_output s p l + let sl = Bytes.length s in + if p + l > sl || p < 0 || l < 0 then invalid_arg "IO.output"; + o.out_output s p l + +let scanf i fmt = + let ib = Scanf.Scanning.from_function (fun () -> try read i with No_more_input -> raise End_of_file) in + Scanf.kscanf ib (fun _ exn -> raise exn) fmt let printf o fmt = Printf.kprintf (fun s -> nwrite_string o s) fmt @@ -164,220 +175,249 @@ let printf o fmt = let flush o = o.out_flush() let close_out o = - let f _ = raise Output_closed in - let r = o.out_close() in - o.out_write <- f; - o.out_output <- f; - o.out_close <- f; - o.out_flush <- f; - r + let f _ = raise Output_closed in + let r = o.out_close() in + o.out_write <- f; + o.out_output <- f; + o.out_close <- f; + o.out_flush <- f; + r let read_all i = - let maxlen = 1024 in - let str = ref [] in - let pos = ref 0 in - let rec loop() = - let s = nread i maxlen in - str := (s,!pos) :: !str; - pos := !pos + Bytes.length s; - loop() - in - try - loop() - with - No_more_input -> - let buf = Bytes.create !pos in - List.iter (fun (s,p) -> - Bytes.blit s 0 buf p (Bytes.length s) - ) !str; + let maxlen = 1024 in + let str = ref [] in + let pos = ref 0 in + let rec loop() = + let s = nread i maxlen in + str := (s,!pos) :: !str; + pos := !pos + Bytes.length s; + loop() + in + try + loop() + with + No_more_input -> + let buf = Bytes.create !pos in + List.iter (fun (s,p) -> + Bytes.blit s 0 buf p (Bytes.length s) + ) !str; (* 'buf' doesn't escape, it won't be mutated again *) - Bytes.unsafe_to_string buf + Bytes.unsafe_to_string buf let pos_in i = - let p = ref 0 in - { - in_read = (fun () -> - let c = i.in_read() in - incr p; - c - ); - in_input = (fun s sp l -> - let n = i.in_input s sp l in - p := !p + n; - n - ); - in_close = i.in_close - } , (fun () -> !p) + let p = ref 0 in + { + in_read = (fun () -> + let c = i.in_read() in + incr p; + c + ); + in_input = (fun s sp l -> + let n = i.in_input s sp l in + p := !p + n; + n + ); + in_close = i.in_close + } , (fun () -> !p) let pos_out o = - let p = ref 0 in - { - out_write = (fun c -> - o.out_write c; - incr p - ); - out_output = (fun s sp l -> - let n = o.out_output s sp l in - p := !p + n; - n - ); - out_close = o.out_close; - out_flush = o.out_flush; - } , (fun () -> !p) + let p = ref 0 in + { + out_write = (fun c -> + o.out_write c; + incr p + ); + out_output = (fun s sp l -> + let n = o.out_output s sp l in + p := !p + n; + n + ); + out_close = o.out_close; + out_flush = o.out_flush; + } , (fun () -> !p) (* -------------------------------------------------------------- *) (* Standard IO *) let input_bytes s = - let pos = ref 0 in - let len = Bytes.length s in - { - in_read = (fun () -> - if !pos >= len then raise No_more_input; - let c = Bytes.unsafe_get s !pos in - incr pos; - c - ); - in_input = (fun sout p l -> - if !pos >= len then raise No_more_input; - let n = (if !pos + l > len then len - !pos else l) in - Bytes.unsafe_blit s !pos sout p n; - pos := !pos + n; - n - ); - in_close = (fun () -> ()); - } + let pos = ref 0 in + let len = Bytes.length s in + { + in_read = (fun () -> + if !pos >= len then raise No_more_input; + let c = Bytes.unsafe_get s !pos in + incr pos; + c + ); + in_input = (fun sout p l -> + if !pos >= len then raise No_more_input; + let n = (if !pos + l > len then len - !pos else l) in + Bytes.unsafe_blit s !pos sout p n; + pos := !pos + n; + n + ); + in_close = (fun () -> ()); + } let input_string s = - (* Bytes.unsafe_of_string is safe here as input_bytes does not - mutate the byte sequence *) - input_bytes (Bytes.unsafe_of_string s) + (* Bytes.unsafe_of_string is safe here as input_bytes does not + mutate the byte sequence *) + input_bytes (Bytes.unsafe_of_string s) + +(* open ExtBuffer *) let output_buffer close = - let b = Buffer.create 0 in - { - out_write = (fun c -> Buffer.add_char b c); - out_output = (fun s p l -> Buffer.add_subbytes b s p l; l); - out_close = (fun () -> close b); - out_flush = (fun () -> ()); - } + let b = Buffer.create 0 in + { + out_write = (fun c -> Buffer.add_char b c); + out_output = (fun s p l -> Buffer.add_subbytes b s p l; l); + out_close = (fun () -> close b); + out_flush = (fun () -> ()); + } let output_string () = output_buffer Buffer.contents let output_bytes () = output_buffer Buffer.to_bytes +let output_strings() = + let sl = ref [] in + let size = ref 0 in + let b = Buffer.create 0 in + { + out_write = (fun c -> + if !size = Sys.max_string_length then begin + sl := Buffer.contents b :: !sl; + Buffer.clear b; + size := 0; + end else incr size; + Buffer.add_char b c + ); + out_output = (fun s p l -> + if !size + l > Sys.max_string_length then begin + sl := Buffer.contents b :: !sl; + Buffer.clear b; + size := 0; + end else size := !size + l; + Buffer.add_subbytes b s p l; + l + ); + out_close = (fun () -> sl := Buffer.contents b :: !sl; List.rev (!sl)); + out_flush = (fun () -> ()); + } + + let input_channel ch = - { - in_read = (fun () -> - try - input_char ch - with - End_of_file -> raise No_more_input - ); - in_input = (fun s p l -> - let n = Pervasives.input ch s p l in - if n = 0 then raise No_more_input; - n - ); - in_close = (fun () -> Pervasives.close_in ch); - } + { + in_read = (fun () -> + try + input_char ch + with + End_of_file -> raise No_more_input + ); + in_input = (fun s p l -> + let n = Stdlib.input ch s p l in + if n = 0 then raise No_more_input; + n + ); + in_close = (fun () -> Stdlib.close_in ch); + } let output_channel ch = - { - out_write = (fun c -> output_char ch c); - out_output = (fun s p l -> Pervasives.output ch s p l; l); - out_close = (fun () -> Pervasives.close_out ch); - out_flush = (fun () -> Pervasives.flush ch); - } + { + out_write = (fun c -> output_char ch c); + out_output = (fun s p l -> Stdlib.output ch s p l; l); + out_close = (fun () -> Stdlib.close_out ch); + out_flush = (fun () -> Stdlib.flush ch); + } (* let input_enum e = - let pos = ref 0 in - { - in_read = (fun () -> - match Enum.get e with - | None -> raise No_more_input - | Some c -> - incr pos; - c - ); - in_input = (fun s p l -> - let rec loop p l = - if l = 0 then - 0 - else - match Enum.get e with - | None -> l - | Some c -> - Bytes.unsafe_set s p c; - loop (p + 1) (l - 1) - in - let k = loop p l in - if k = l then raise No_more_input; - l - k - ); - in_close = (fun () -> ()); - } + let pos = ref 0 in + { + in_read = (fun () -> + match Enum.get e with + | None -> raise No_more_input + | Some c -> + incr pos; + c + ); + in_input = (fun s p l -> + let rec loop p l = + if l = 0 then + 0 + else + match Enum.get e with + | None -> l + | Some c -> + Bytes.unsafe_set s p c; + loop (p + 1) (l - 1) + in + let k = loop p l in + if k = l then raise No_more_input; + l - k + ); + in_close = (fun () -> ()); + } let output_enum() = - let b = Buffer.create 0 in - { - out_write = (fun x -> - Buffer.add_char b x - ); - out_output = (fun s p l -> - Buffer.add_subbytes b s p l; - l - ); - out_close = (fun () -> - let s = Buffer.contents b in - ExtString.String.enum s - ); - out_flush = (fun () -> ()); - } + let b = Buffer.create 0 in + { + out_write = (fun x -> + Buffer.add_char b x + ); + out_output = (fun s p l -> + Buffer.add_subbytes b s p l; + l + ); + out_close = (fun () -> + let s = Buffer.contents b in + ExtString.String.enum s + ); + out_flush = (fun () -> ()); + } *) let pipe() = - let input = ref "" in - let inpos = ref 0 in - let output = Buffer.create 0 in - let flush() = - input := Buffer.contents output; - inpos := 0; - Buffer.reset output; - if String.length !input = 0 then raise No_more_input - in - let read() = - if !inpos = String.length !input then flush(); - let c = String.unsafe_get !input !inpos in - incr inpos; - c - in - let input s p l = - if !inpos = String.length !input then flush(); - let r = (if !inpos + l > String.length !input then String.length !input - !inpos else l) in - String.unsafe_blit !input !inpos s p r; - inpos := !inpos + r; - r - in - let write c = - Buffer.add_char output c - in - let output s p l = - Buffer.add_subbytes output s p l; - l - in - let input = { - in_read = read; - in_input = input; - in_close = (fun () -> ()); - } in - let output = { - out_write = write; - out_output = output; - out_close = (fun () -> ()); - out_flush = (fun () -> ()); - } in - input , output + let input = ref "" in + let inpos = ref 0 in + let output = Buffer.create 0 in + let flush() = + input := Buffer.contents output; + inpos := 0; + Buffer.reset output; + if String.length !input = 0 then raise No_more_input + in + let read() = + if !inpos = String.length !input then flush(); + let c = String.unsafe_get !input !inpos in + incr inpos; + c + in + let input s p l = + if !inpos = String.length !input then flush(); + let r = (if !inpos + l > String.length !input then String.length !input - !inpos else l) in + String.unsafe_blit !input !inpos s p r; + inpos := !inpos + r; + r + in + let write c = + Buffer.add_char output c + in + let output s p l = + Buffer.add_subbytes output s p l; + l + in + let input = { + in_read = read; + in_input = input; + in_close = (fun () -> ()); + } in + let output = { + out_write = write; + out_output = output; + out_close = (fun () -> ()); + out_flush = (fun () -> ()); + } in + input , output external cast_output : 'a output -> unit output = "%identity" @@ -389,23 +429,23 @@ exception Overflow of string let read_byte i = int_of_char (i.in_read()) let read_signed_byte i = - let c = int_of_char (i.in_read()) in - if c land 128 <> 0 then - c - 256 - else - c + let c = int_of_char (i.in_read()) in + if c land 128 <> 0 then + c - 256 + else + c let read_string_into_buffer i = - let b = Buffer.create 8 in - let rec loop() = - let c = i.in_read() in - if c <> '\000' then begin - Buffer.add_char b c; - loop(); - end; - in - loop(); - b + let b = Buffer.create 8 in + let rec loop() = + let c = i.in_read() in + if c <> '\000' then begin + Buffer.add_char b c; + loop(); + end; + in + loop(); + b let read_string i = Buffer.contents @@ -416,132 +456,161 @@ let read_bytes i = (read_string_into_buffer i) let read_line i = - let b = Buffer.create 8 in - let cr = ref false in - let rec loop() = - let c = i.in_read() in - match c with - | '\n' -> - () - | '\r' -> - cr := true; - loop() - | _ when !cr -> - cr := false; - Buffer.add_char b '\r'; - Buffer.add_char b c; - loop(); - | _ -> - Buffer.add_char b c; - loop(); - in - try - loop(); - Buffer.contents b - with - No_more_input -> - if !cr then Buffer.add_char b '\r'; - if Buffer.length b > 0 then - Buffer.contents b - else - raise No_more_input + let b = Buffer.create 8 in + let cr = ref false in + let rec loop() = + let c = i.in_read() in + match c with + | '\n' -> + () + | '\r' -> + cr := true; + loop() + | _ when !cr -> + cr := false; + Buffer.add_char b '\r'; + Buffer.add_char b c; + loop(); + | _ -> + Buffer.add_char b c; + loop(); + in + try + loop(); + Buffer.contents b + with + No_more_input -> + if !cr then Buffer.add_char b '\r'; + if Buffer.length b > 0 then + Buffer.contents b + else + raise No_more_input let read_ui16 i = - let ch1 = read_byte i in - let ch2 = read_byte i in - ch1 lor (ch2 lsl 8) + let ch1 = read_byte i in + let ch2 = read_byte i in + ch1 lor (ch2 lsl 8) let read_i16 i = - let ch1 = read_byte i in - let ch2 = read_byte i in - let n = ch1 lor (ch2 lsl 8) in - if ch2 land 128 <> 0 then - n - 65536 - else - n - -let read_i32 ch = - let ch1 = read_byte ch in - let ch2 = read_byte ch in - let ch3 = read_byte ch in - let ch4 = read_byte ch in - if ch4 land 128 <> 0 then begin - if ch4 land 64 = 0 then raise (Overflow "read_i32"); - ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24) - end else begin - if ch4 land 64 <> 0 then raise (Overflow "read_i32"); - ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24) - end + let ch1 = read_byte i in + let ch2 = read_byte i in + let n = ch1 lor (ch2 lsl 8) in + if ch2 land 128 <> 0 then + n - 65536 + else + n + +let sign_bit_i32 = lnot 0x7FFF_FFFF + +let read_32 ~i31 ch = + let ch1 = read_byte ch in + let ch2 = read_byte ch in + let ch3 = read_byte ch in + let ch4 = read_byte ch in + if ch4 land 128 <> 0 then begin + if i31 && ch4 land 64 = 0 then raise (Overflow "read_i31"); + ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24) lor sign_bit_i32 + end else begin + if i31 && ch4 land 64 <> 0 then raise (Overflow "read_i31"); + ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24) + end + +let read_i31 ch = read_32 ~i31:true ch +let read_i32_as_int ch = read_32 ~i31:false ch + +let read_i32 = read_i31 let read_real_i32 ch = - let ch1 = read_byte ch in - let ch2 = read_byte ch in - let ch3 = read_byte ch in - let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in - let big = Int32.shift_left (Int32.of_int (read_byte ch)) 24 in - Int32.logor base big + let ch1 = read_byte ch in + let ch2 = read_byte ch in + let ch3 = read_byte ch in + let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in + let big = Int32.shift_left (Int32.of_int (read_byte ch)) 24 in + Int32.logor base big let read_i64 ch = - let ch1 = read_byte ch in - let ch2 = read_byte ch in - let ch3 = read_byte ch in - let ch4 = read_byte ch in - let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in - let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in - let big = Int64.of_int32 (read_real_i32 ch) in - Int64.logor (Int64.shift_left big 32) small + let ch1 = read_byte ch in + let ch2 = read_byte ch in + let ch3 = read_byte ch in + let ch4 = read_byte ch in + let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in + let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in + let big = Int64.of_int32 (read_real_i32 ch) in + Int64.logor (Int64.shift_left big 32) small + +let read_float32 ch = + Int32.float_of_bits (read_real_i32 ch) let read_double ch = - Int64.float_of_bits (read_i64 ch) + Int64.float_of_bits (read_i64 ch) let write_byte o n = - (* doesn't test bounds of n in order to keep semantics of Pervasives.output_byte *) - write o (Char.unsafe_chr (n land 0xFF)) + (* doesn't test bounds of n in order to keep semantics of Stdlib.output_byte *) + write o (Char.unsafe_chr (n land 0xFF)) let write_string o s = - nwrite_string o s; - write o '\000' + nwrite_string o s; + write o '\000' let write_bytes o s = - nwrite o s; - write o '\000' + nwrite o s; + write o '\000' let write_line o s = - nwrite_string o s; - write o '\n' + nwrite_string o s; + write o '\n' let write_ui16 ch n = - if n < 0 || n > 0xFFFF then raise (Overflow "write_ui16"); - write_byte ch n; - write_byte ch (n lsr 8) + if n < 0 || n > 0xFFFF then raise (Overflow "write_ui16"); + write_byte ch n; + write_byte ch (n lsr 8) let write_i16 ch n = - if n < -0x8000 || n > 0x7FFF then raise (Overflow "write_i16"); - if n < 0 then - write_ui16 ch (65536 + n) - else - write_ui16 ch n + if n < -0x8000 || n > 0x7FFF then raise (Overflow "write_i16"); + if n < 0 then + write_ui16 ch (65536 + n) + else + write_ui16 ch n + +let write_32 ch n = + write_byte ch n; + write_byte ch (n lsr 8); + write_byte ch (n lsr 16); + write_byte ch (n asr 24) + +(* +let write_i31 ch n = +#ifndef WORD_SIZE_32 + if n < -0x4000_0000 || n > 0x3FFF_FFFF then raise (Overflow "write_i31"); +#endif + write_32 ch n +*) let write_i32 ch n = - write_byte ch n; - write_byte ch (n lsr 8); - write_byte ch (n lsr 16); - write_byte ch (n asr 24) +(* +#ifndef WORD_SIZE_32 + if n < -0x8000_0000 || n > 0x7FFF_FFFF then raise (Overflow "write_i32"); +#endif +*) + write_32 ch n let write_real_i32 ch n = - let base = Int32.to_int n in - let big = Int32.to_int (Int32.shift_right_logical n 24) in - write_byte ch base; - write_byte ch (base lsr 8); - write_byte ch (base lsr 16); - write_byte ch big + let base = Int32.to_int n in + let big = Int32.to_int (Int32.shift_right_logical n 24) in + write_byte ch base; + write_byte ch (base lsr 8); + write_byte ch (base lsr 16); + write_byte ch big let write_i64 ch n = - write_real_i32 ch (Int64.to_int32 n); - write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical n 32)) + write_real_i32 ch (Int64.to_int32 n); + write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical n 32)) + +let write_float32 ch f = + write_real_i32 ch (Int32.bits_of_float f) let write_double ch f = - write_i64 ch (Int64.bits_of_float f) + write_i64 ch (Int64.bits_of_float f) (* -------------------------------------------------------------- *) (* Big Endians *) @@ -549,85 +618,114 @@ let write_double ch f = module BigEndian = struct let read_ui16 i = - let ch2 = read_byte i in - let ch1 = read_byte i in - ch1 lor (ch2 lsl 8) + let ch2 = read_byte i in + let ch1 = read_byte i in + ch1 lor (ch2 lsl 8) let read_i16 i = - let ch2 = read_byte i in - let ch1 = read_byte i in - let n = ch1 lor (ch2 lsl 8) in - if ch2 land 128 <> 0 then - n - 65536 - else - n - -let read_i32 ch = - let ch4 = read_byte ch in - let ch3 = read_byte ch in - let ch2 = read_byte ch in - let ch1 = read_byte ch in - if ch4 land 128 <> 0 then begin - if ch4 land 64 = 0 then raise (Overflow "read_i32"); - ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24) - end else begin - if ch4 land 64 <> 0 then raise (Overflow "read_i32"); - ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24) - end + let ch2 = read_byte i in + let ch1 = read_byte i in + let n = ch1 lor (ch2 lsl 8) in + if ch2 land 128 <> 0 then + n - 65536 + else + n + +let sign_bit_i32 = lnot 0x7FFF_FFFF + +let read_32 ~i31 ch = + let ch4 = read_byte ch in + let ch3 = read_byte ch in + let ch2 = read_byte ch in + let ch1 = read_byte ch in + if ch4 land 128 <> 0 then begin + if i31 && ch4 land 64 = 0 then raise (Overflow "read_i31"); + ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24) lor sign_bit_i32 + end else begin + if i31 && ch4 land 64 <> 0 then raise (Overflow "read_i31"); + ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24) + end + +let read_i31 ch = read_32 ~i31:true ch +let read_i32_as_int ch = read_32 ~i31:false ch + +let read_i32 = read_i31 let read_real_i32 ch = - let big = Int32.shift_left (Int32.of_int (read_byte ch)) 24 in - let ch3 = read_byte ch in - let ch2 = read_byte ch in - let ch1 = read_byte ch in - let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in - Int32.logor base big + let big = Int32.shift_left (Int32.of_int (read_byte ch)) 24 in + let ch3 = read_byte ch in + let ch2 = read_byte ch in + let ch1 = read_byte ch in + let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in + Int32.logor base big let read_i64 ch = - let big = Int64.of_int32 (read_real_i32 ch) in - let ch4 = read_byte ch in - let ch3 = read_byte ch in - let ch2 = read_byte ch in - let ch1 = read_byte ch in - let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in - let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in - Int64.logor (Int64.shift_left big 32) small + let big = Int64.of_int32 (read_real_i32 ch) in + let ch4 = read_byte ch in + let ch3 = read_byte ch in + let ch2 = read_byte ch in + let ch1 = read_byte ch in + let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in + let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in + Int64.logor (Int64.shift_left big 32) small + +let read_float32 ch = + Int32.float_of_bits (read_real_i32 ch) let read_double ch = - Int64.float_of_bits (read_i64 ch) + Int64.float_of_bits (read_i64 ch) let write_ui16 ch n = - if n < 0 || n > 0xFFFF then raise (Overflow "write_ui16"); - write_byte ch (n lsr 8); - write_byte ch n + if n < 0 || n > 0xFFFF then raise (Overflow "write_ui16"); + write_byte ch (n lsr 8); + write_byte ch n let write_i16 ch n = - if n < -0x8000 || n > 0x7FFF then raise (Overflow "write_i16"); - if n < 0 then - write_ui16 ch (65536 + n) - else - write_ui16 ch n + if n < -0x8000 || n > 0x7FFF then raise (Overflow "write_i16"); + if n < 0 then + write_ui16 ch (65536 + n) + else + write_ui16 ch n + +let write_32 ch n = + write_byte ch (n asr 24); + write_byte ch (n lsr 16); + write_byte ch (n lsr 8); + write_byte ch n + +(* +let write_i31 ch n = +#ifndef WORD_SIZE_32 + if n < -0x4000_0000 || n > 0x3FFF_FFFF then raise (Overflow "write_i31"); +#endif + write_32 ch n +*) let write_i32 ch n = - write_byte ch (n asr 24); - write_byte ch (n lsr 16); - write_byte ch (n lsr 8); - write_byte ch n +(* +#ifndef WORD_SIZE_32 + if n < -0x8000_0000 || n > 0x7FFF_FFFF then raise (Overflow "write_i32"); +#endif +*) + write_32 ch n let write_real_i32 ch n = - let base = Int32.to_int n in - let big = Int32.to_int (Int32.shift_right_logical n 24) in - write_byte ch big; - write_byte ch (base lsr 16); - write_byte ch (base lsr 8); - write_byte ch base + let base = Int32.to_int n in + let big = Int32.to_int (Int32.shift_right_logical n 24) in + write_byte ch big; + write_byte ch (base lsr 16); + write_byte ch (base lsr 8); + write_byte ch base let write_i64 ch n = - write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical n 32)); - write_real_i32 ch (Int64.to_int32 n) + write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical n 32)); + write_real_i32 ch (Int64.to_int32 n) + +let write_float32 ch f = + write_real_i32 ch (Int32.bits_of_float f) let write_double ch f = - write_i64 ch (Int64.bits_of_float f) + write_i64 ch (Int64.bits_of_float f) end @@ -635,9 +733,9 @@ end (* Bits API *) type 'a bc = { - ch : 'a; - mutable nbits : int; - mutable bits : int; + ch : 'a; + mutable nbits : int; + mutable bits : int; } type in_bits = input bc @@ -646,155 +744,155 @@ type out_bits = unit output bc exception Bits_error let input_bits ch = - { - ch = ch; - nbits = 0; - bits = 0; - } + { + ch = ch; + nbits = 0; + bits = 0; + } let output_bits ch = - { - ch = cast_output ch; - nbits = 0; - bits = 0; - } + { + ch = cast_output ch; + nbits = 0; + bits = 0; + } let rec read_bits b n = - if b.nbits >= n then begin - let c = b.nbits - n in - let k = (b.bits asr c) land ((1 lsl n) - 1) in - b.nbits <- c; - k - end else begin - let k = read_byte b.ch in - if b.nbits >= 24 then begin - if n >= 31 then raise Bits_error; - let c = 8 + b.nbits - n in - let d = b.bits land ((1 lsl b.nbits) - 1) in - let d = (d lsl (8 - c)) lor (k lsr c) in - b.bits <- k; - b.nbits <- c; - d - end else begin - b.bits <- (b.bits lsl 8) lor k; - b.nbits <- b.nbits + 8; - read_bits b n; - end - end + if b.nbits >= n then begin + let c = b.nbits - n in + let k = (b.bits asr c) land ((1 lsl n) - 1) in + b.nbits <- c; + k + end else begin + let k = read_byte b.ch in + if b.nbits >= 24 then begin + if n > 31 then raise Bits_error; + let c = 8 + b.nbits - n in + let d = b.bits land ((1 lsl b.nbits) - 1) in + let d = (d lsl (8 - c)) lor (k lsr c) in + b.bits <- k; + b.nbits <- c; + d + end else begin + b.bits <- (b.bits lsl 8) lor k; + b.nbits <- b.nbits + 8; + read_bits b n; + end + end let drop_bits b = - b.nbits <- 0 + b.nbits <- 0 let rec write_bits b ~nbits x = - let n = nbits in - if n + b.nbits >= 32 then begin - if n > 31 then raise Bits_error; - let n2 = 32 - b.nbits - 1 in - let n3 = n - n2 in - write_bits b ~nbits:n2 (x asr n3); - write_bits b ~nbits:n3 (x land ((1 lsl n3) - 1)); - end else begin - if n < 0 then raise Bits_error; - if (x < 0 || x > (1 lsl n - 1)) && n <> 31 then raise Bits_error; - b.bits <- (b.bits lsl n) lor x; - b.nbits <- b.nbits + n; - while b.nbits >= 8 do - b.nbits <- b.nbits - 8; - write_byte b.ch (b.bits asr b.nbits) - done - end + let n = nbits in + if n + b.nbits >= 32 then begin + if n > 31 then raise Bits_error; + let n2 = 32 - b.nbits - 1 in + let n3 = n - n2 in + write_bits b ~nbits:n2 (x asr n3); + write_bits b ~nbits:n3 (x land ((1 lsl n3) - 1)); + end else begin + if n < 0 then raise Bits_error; + if (x < 0 || x > (1 lsl n - 1)) && n <> 31 then raise Bits_error; + b.bits <- (b.bits lsl n) lor x; + b.nbits <- b.nbits + n; + while b.nbits >= 8 do + b.nbits <- b.nbits - 8; + write_byte b.ch (b.bits asr b.nbits) + done + end let flush_bits b = - if b.nbits > 0 then write_bits b (8 - b.nbits) 0 + if b.nbits > 0 then write_bits b (8 - b.nbits) 0 (* -------------------------------------------------------------- *) (* Generic IO *) class in_channel ch = object - method input s pos len = input ch s pos len - method close_in() = close_in ch + method input s pos len = input ch s pos len + method close_in() = close_in ch end class out_channel ch = object - method output s pos len = output ch s pos len - method flush() = flush ch - method close_out() = ignore(close_out ch) + method output s pos len = output ch s pos len + method flush() = flush ch + method close_out() = ignore(close_out ch) end class in_chars ch = object - method get() = try read ch with No_more_input -> raise End_of_file - method close_in() = close_in ch + method get() = try read ch with No_more_input -> raise End_of_file + method close_in() = close_in ch end class out_chars ch = object - method put t = write ch t - method flush() = flush ch - method close_out() = ignore(close_out ch) + method put t = write ch t + method flush() = flush ch + method close_out() = ignore(close_out ch) end let from_in_channel ch = - let cbuf = Bytes.create 1 in - let read() = - try - if ch#input cbuf 0 1 = 0 then raise Sys_blocked_io; - Bytes.unsafe_get cbuf 0 - with - End_of_file -> raise No_more_input - in - let input s p l = - ch#input s p l - in - create_in - ~read - ~input - ~close:ch#close_in + let cbuf = Bytes.create 1 in + let read() = + try + if ch#input cbuf 0 1 = 0 then raise Sys_blocked_io; + Bytes.unsafe_get cbuf 0 + with + End_of_file -> raise No_more_input + in + let input s p l = + ch#input s p l + in + create_in + ~read + ~input + ~close:ch#close_in let from_out_channel ch = - let cbuf = Bytes.create 1 in - let write c = - Bytes.unsafe_set cbuf 0 c; - if ch#output cbuf 0 1 = 0 then raise Sys_blocked_io; - in - let output s p l = - ch#output s p l - in - create_out - ~write - ~output - ~flush:ch#flush - ~close:ch#close_out + let cbuf = Bytes.create 1 in + let write c = + Bytes.unsafe_set cbuf 0 c; + if ch#output cbuf 0 1 = 0 then raise Sys_blocked_io; + in + let output s p l = + ch#output s p l + in + create_out + ~write + ~output + ~flush:ch#flush + ~close:ch#close_out let from_in_chars ch = - let input s p l = - let i = ref 0 in - try - while !i < l do - Bytes.unsafe_set s (p + !i) (ch#get()); - incr i - done; - l - with - End_of_file when !i > 0 -> - !i - in - create_in - ~read:ch#get - ~input - ~close:ch#close_in + let input s p l = + let i = ref 0 in + try + while !i < l do + Bytes.unsafe_set s (p + !i) (ch#get()); + incr i + done; + l + with + End_of_file when !i > 0 -> + !i + in + create_in + ~read:ch#get + ~input + ~close:ch#close_in let from_out_chars ch = - let output s p l = - for i = p to p + l - 1 do - ch#put (Bytes.unsafe_get s i) - done; - l - in - create_out - ~write:ch#put - ~output - ~flush:ch#flush - ~close:ch#close_out + let output s p l = + for i = p to p + l - 1 do + ch#put (Bytes.unsafe_get s i) + done; + l + in + create_out + ~write:ch#put + ~output + ~flush:ch#flush + ~close:ch#close_out diff --git a/src/utils/extlib/IO.mli b/src/utils/extlib/IO.mli index c288ed03..5fa172ae 100644 --- a/src/utils/extlib/IO.mli +++ b/src/utils/extlib/IO.mli @@ -20,18 +20,20 @@ (** High-order abstract I/O. - IO module simply deals with abstract inputs/outputs. It provides a - set of methods for working with these IO as well as several - constructors that enable to write to an underlying channel, buffer, - or enum. + IO module simply deals with abstract inputs/outputs. It provides a + set of methods for working with these IO as well as several + constructors that enable to write to an underlying channel, buffer, + or enum. *) +(* open ExtBytes *) + type input (** The abstract input type. *) type 'a output (** The abstract output type, ['a] is the accumulator data, it is returned - when the [close_out] function is called. *) + when the [close_out] function is called. *) exception No_more_input (** This exception is raised when reading on an input with the [read] or @@ -66,11 +68,11 @@ val really_nread_string : input -> int -> string (** as [really_nread], but reads a string. *) val input : input -> Bytes.t -> int -> int -> int -(** [input i s p l] reads up to [l] characters from the given input, storing +(** [input i b p l] reads up to [l] characters from the given input, storing them in buffer [b], starting at character number [p]. It returns the actual number of characters read or raise [No_more_input] if no character can be read. It will raise [Invalid_argument] if [p] and [l] do not designate a - valid sequence of [b]. *) + valid subsequence of [b]. *) val really_input : input -> Bytes.t -> int -> int -> int (** [really_input i b p l] reads exactly [l] characters from the given input, @@ -125,6 +127,12 @@ val output_bytes : unit -> Bytes.t output (** Create an output that will write into a byte sequence in an efficient way. When closed, the output returns all the data written into it. *) +val output_strings : unit -> string list output +(** Create an output that will write into a string in an efficient way. + When closed, the output returns all the data written into it. + Several strings are used in case the output size excess max_string_length +*) + val input_channel : in_channel -> input (** Create an input that will read from a channel. *) @@ -153,6 +161,9 @@ val create_out : (** {6 Utilities} *) +val scanf : input -> ('a, 'b, 'c, 'd) Scanf.scanner +(** The scanf function works for any input. *) + val printf : 'a output -> ('b, unit, string, unit) format4 -> 'b (** The printf function works for any output. *) @@ -177,10 +188,10 @@ external cast_output : 'a output -> unit output = "%identity" (** {6 Binary files API} - Here is some API useful for working with binary files, in particular - binary files generated by C applications. By default, encoding of - multibyte integers is low-endian. The BigEndian module provide multibyte - operations with other encoding. + Here is some API useful for working with binary files, in particular + binary files generated by C applications. By default, encoding of + multibyte integers is low-endian. The BigEndian module provide multibyte + operations with other encoding. *) exception Overflow of string @@ -198,9 +209,15 @@ val read_ui16 : input -> int val read_i16 : input -> int (** Read a signed 16-bit word. *) -val read_i32 : input -> int +val read_i31 : input -> int (** Read a signed 32-bit integer. Raise [Overflow] if the - read integer cannot be represented as a Caml 31-bit integer. *) + read integer cannot be represented as an OCaml 31-bit integer. *) + +val read_i32 : input -> int +(** Deprecated, same as read_i31 *) + +val read_i32_as_int : input -> int +(** Read a signed 32-bit integer, represented as OCaml integer, wrapping around 31-bit int on 32-bit architecture *) val read_real_i32 : input -> int32 (** Read a signed 32-bit integer as an OCaml int32. *) @@ -208,8 +225,11 @@ val read_real_i32 : input -> int32 val read_i64 : input -> int64 (** Read a signed 64-bit integer as an OCaml int64. *) +val read_float32 : input -> float +(** Read an IEEE single precision floating point value (32 bits). *) + val read_double : input -> float -(** Read an IEEE double precision floating point value. *) +(** Read an IEEE double precision floating point value (64 bits). *) val read_string : input -> string (** Read a null-terminated string. *) @@ -229,6 +249,9 @@ val write_ui16 : 'a output -> int -> unit val write_i16 : 'a output -> int -> unit (** Write a signed 16-bit word. *) +(* val write_i31 : 'a output -> int -> unit *) +(** Write a signed 31-bit integer as 4 bytes. *) + val write_i32 : 'a output -> int -> unit (** Write a signed 32-bit integer. *) @@ -238,8 +261,11 @@ val write_real_i32 : 'a output -> int32 -> unit val write_i64 : 'a output -> int64 -> unit (** Write an OCaml int64. *) +val write_float32 : 'a output -> float -> unit +(** Write an IEEE single precision floating point value (32 bits). *) + val write_double : 'a output -> float -> unit -(** Write an IEEE double precision floating point value. *) +(** Write an IEEE double precision floating point value (64 bits). *) val write_string : 'a output -> string -> unit (** Write a string and append an null character. *) @@ -249,32 +275,37 @@ val write_bytes : 'a output -> Bytes.t -> unit val write_line : 'a output -> string -> unit (** Write a line and append a LF (it might be converted - to CRLF on some systems depending on the underlying IO). *) + to CRLF on some systems depending on the underlying IO). *) (** Same as operations above, but use big-endian encoding *) module BigEndian : sig - val read_ui16 : input -> int - val read_i16 : input -> int - val read_i32 : input -> int - val read_real_i32 : input -> int32 - val read_i64 : input -> int64 - val read_double : input -> float - - val write_ui16 : 'a output -> int -> unit - val write_i16 : 'a output -> int -> unit - val write_i32 : 'a output -> int -> unit - val write_real_i32 : 'a output -> int32 -> unit - val write_i64 : 'a output -> int64 -> unit - val write_double : 'a output -> float -> unit + val read_ui16 : input -> int + val read_i16 : input -> int + val read_i31 : input -> int + val read_i32 : input -> int + val read_i32_as_int : input -> int + val read_real_i32 : input -> int32 + val read_i64 : input -> int64 + val read_float32 : input -> float + val read_double : input -> float + + val write_ui16 : 'a output -> int -> unit + val write_i16 : 'a output -> int -> unit +(* val write_i31 : 'a output -> int -> unit *) + val write_i32 : 'a output -> int -> unit + val write_real_i32 : 'a output -> int32 -> unit + val write_i64 : 'a output -> int64 -> unit + val write_float32 : 'a output -> float -> unit + val write_double : 'a output -> float -> unit end (** {6 Bits API} - This enable you to read and write from an IO bit-by-bit or several bits - at the same time. + This enable you to read and write from an IO bit-by-bit or several bits + at the same time. *) type in_bits @@ -303,40 +334,40 @@ val drop_bits : in_bits -> unit (** {6 Generic IO Object Wrappers} - Theses OO Wrappers have been written to provide easy support of ExtLib - IO by external librairies. If you want your library to support ExtLib - IO without actually requiring ExtLib to compile, you can should implement - the classes [in_channel], [out_channel], [poly_in_channel] and/or - [poly_out_channel] which are the common IO specifications established - for ExtLib, OCamlNet and Camomile. + Theses OO Wrappers have been written to provide easy support of ExtLib + IO by external librairies. If you want your library to support ExtLib + IO without actually requiring ExtLib to compile, you can should implement + the classes [in_channel], [out_channel], [poly_in_channel] and/or + [poly_out_channel] which are the common IO specifications established + for ExtLib, OCamlNet and Camomile. - (see http://www.ocaml-programming.de/tmp/IO-Classes.html for more details). + (see http://www.ocaml-programming.de/tmp/IO-Classes.html for more details). *) class in_channel : input -> object - method input : Bytes.t -> int -> int -> int - method close_in : unit -> unit + method input : Bytes.t -> int -> int -> int + method close_in : unit -> unit end class out_channel : 'a output -> object - method output : Bytes.t -> int -> int -> int - method flush : unit -> unit - method close_out : unit -> unit + method output : Bytes.t -> int -> int -> int + method flush : unit -> unit + method close_out : unit -> unit end class in_chars : input -> object - method get : unit -> char - method close_in : unit -> unit + method get : unit -> char + method close_in : unit -> unit end class out_chars : 'a output -> object - method put : char -> unit - method flush : unit -> unit - method close_out : unit -> unit + method put : char -> unit + method flush : unit -> unit + method close_out : unit -> unit end val from_in_channel : #in_channel -> input diff --git a/src/utils/lib/url.ml b/src/utils/lib/url.ml index c226b707..b7bdb6da 100644 --- a/src/utils/lib/url.ml +++ b/src/utils/lib/url.ml @@ -36,7 +36,7 @@ type url = { let encode s = let pos = ref 0 in let len = String.length s in - let res = String.create (3*len) in + let res = Bytes.create (3*len) in let hexa_digit x = if x >= 10 then Char.chr (Char.code 'A' + x - 10) else Char.chr (Char.code '0' + x) in @@ -50,10 +50,7 @@ let encode s = res.[!pos+2] <- hexa_digit (Char.code c mod 16); pos := !pos + 3 done; - Bytes.sub res 0 !pos - -let encode_to_string s = - Bytes.to_string (encode s) + Bytes.sub_string res 0 !pos (** decodes a sting according RFC 1738 or x-www-form-urlencoded ('+' with ' ') @@ -165,12 +162,12 @@ let put_args s args = let rec manage_args = function | [] -> assert false | [a, ""] -> - Buffer.add_bytes res (encode a) + Buffer.add_string res (encode a) | [a, b] -> - Buffer.add_bytes res (encode a); Buffer.add_char res '='; Buffer.add_bytes res + Buffer.add_string res (encode a); Buffer.add_char res '='; Buffer.add_string res (encode b) | (a,b)::l -> - Buffer.add_bytes res (encode a); Buffer.add_char res '='; Buffer.add_bytes res + Buffer.add_string res (encode a); Buffer.add_char res '='; Buffer.add_string res (encode b); Buffer.add_char res '&'; manage_args l in (* lprintf "len args %d" (List.length args); lprint_newline ();*) diff --git a/src/utils/lib/url.mli b/src/utils/lib/url.mli index 10c3612d..ccd63f5a 100644 --- a/src/utils/lib/url.mli +++ b/src/utils/lib/url.mli @@ -53,9 +53,8 @@ val cut_args : string -> (string * string) list val put_args : string -> (string * string) list -> string -val encode : string -> bytes -val encode_to_string: string -> string +val encode : string -> string val decode : ?raw:bool -> string -> string val option : url Options.option_class - \ No newline at end of file + diff --git a/src/utils/net/http_client.ml b/src/utils/net/http_client.ml index 9954c768..7bb568a4 100644 --- a/src/utils/net/http_client.ml +++ b/src/utils/net/http_client.ml @@ -136,10 +136,10 @@ let make_full_request r = let rec make_post = function | [] -> assert false | [a, b] -> - Printf.bprintf post "%s%c%s" (Url.encode_to_string a) '=' (Url.encode_to_string b) + Printf.bprintf post "%s%c%s" (Url.encode a) '=' (Url.encode b) | (a,b)::l -> Printf.bprintf post "%s%c%s%c" - (Url.encode_to_string a) '=' (Url.encode_to_string b) '&'; + (Url.encode a) '=' (Url.encode b) '&'; make_post l in make_post args; Printf.bprintf res "Content-Type: application/x-www-form-urlencoded\r\nContent-Length: %d\r\n\r\n%s" diff --git a/src/utils/net/tcpBufferedSocket.ml b/src/utils/net/tcpBufferedSocket.ml index ee74690c..3f123ace 100644 --- a/src/utils/net/tcpBufferedSocket.ml +++ b/src/utils/net/tcpBufferedSocket.ml @@ -1618,8 +1618,8 @@ let write t s pos len = _to_deflate t; buf_add t wbuf s pos len -let write_string t s = write t (Bytes.of_string s) 0 (String.length s) -let write_all_bytes t data = write t data 0 (Bytes.length data) +let write_bytes t s = write t s 0 (Bytes.length s) +let write_string t s = write_bytes t (Bytes.unsafe_of_string s) (*************************************************************************) (* *) diff --git a/src/utils/net/tcpBufferedSocket.mli b/src/utils/net/tcpBufferedSocket.mli index c4dd3273..5e45a0c5 100644 --- a/src/utils/net/tcpBufferedSocket.mli +++ b/src/utils/net/tcpBufferedSocket.mli @@ -67,7 +67,7 @@ val set_refill : t -> (t -> unit) -> unit val set_rtimer : t -> (t -> unit) -> unit val write: t -> bytes -> int -> int -> unit val write_string: t -> string -> unit -val write_all_bytes: t -> bytes -> unit +val write_bytes: t -> bytes -> unit val connect: token -> string -> Unix.inet_addr -> int -> handler -> t val close : t -> BasicSocket.close_reason -> unit val closed : t -> bool From be396bd14adcb5c9728579d56a3345f21f337b76 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 27 Jun 2024 19:18:10 +0200 Subject: [PATCH 64/69] Sync with upstream. --- src/daemon/common/commonDownloads.ml | 2 +- src/daemon/common/commonFile.ml | 4 +- src/daemon/common/commonHasher_c.c | 2 +- src/daemon/driver/driverControlers.ml | 2 +- src/daemon/driver/driverMain.ml | 2 +- src/networks/direct_connect/che3_c.c | 2 +- src/networks/direct_connect/dcClients.ml | 10 ++-- src/networks/direct_connect/dcShared.ml | 12 ++--- src/networks/donkey/donkeyClient.ml | 5 +- src/networks/donkey/donkeyFiles.ml | 6 +-- src/networks/donkey/donkeyImport.ml | 2 +- src/networks/donkey/donkeyOvernetImport.ml | 4 +- src/networks/donkey/donkeyProtoCom.ml | 60 ++++++++++----------- src/networks/donkey/donkeyProtoCom.mli | 6 +-- src/networks/donkey/donkeyProtoKademlia.ml | 36 ++++++------- src/networks/donkey/donkeyProtoOvernet.ml | 18 +++---- src/networks/fasttrack/fasttrackGlobals.ml | 4 +- src/networks/fasttrack/fasttrackServers.ml | 10 ++-- src/networks/fileTP/fileTPGlobals.ml | 4 +- src/networks/fileTP/fileTPHTTP.ml | 2 +- src/networks/fileTP/fileTPSSH.ml | 2 +- src/utils/cdk/file.ml | 10 ++-- src/utils/cdk/filename2.ml | 32 +++++------ src/utils/cdk/string2.ml | 62 +++++++--------------- src/utils/cdk/string2.mli | 9 ++-- src/utils/cdk/unix2.ml | 8 +-- src/utils/cdk/zlib2.ml | 37 ++++++------- src/utils/cdk/zlib2.mli | 5 +- src/utils/lib/misc2.mlcpp | 2 +- src/utils/lib/unix32.ml | 24 +++++---- src/utils/lib/unix32.mli | 7 +-- src/utils/net/anyEndian.ml | 3 -- src/utils/net/base64.ml | 28 +++++----- src/utils/net/base64.mli | 7 ++- src/utils/net/cobs.ml | 26 ++++----- src/utils/net/http_client.ml | 11 ++-- src/utils/net/http_server.ml | 10 ++-- src/utils/net/mailer.ml | 51 +++++++++--------- src/utils/net/tcpBufferedSocket.ml | 2 +- 39 files changed, 244 insertions(+), 285 deletions(-) diff --git a/src/daemon/common/commonDownloads.ml b/src/daemon/common/commonDownloads.ml index be9aa3a6..1c266ad3 100644 --- a/src/daemon/common/commonDownloads.ml +++ b/src/daemon/common/commonDownloads.ml @@ -87,7 +87,7 @@ module Make(M: sig in let final_pos = Unix32.seek64 (file_fd file) d.download_pos Unix.SEEK_SET in *) - Unix32.write (file_fd file) d.download_pos b.buf b.pos b.len; + Unix32.write_bytes (file_fd file) d.download_pos b.buf b.pos b.len; (* end; *) (* lprintf "DIFF %d/%d\n" nread b.len; *) d.download_pos <- d.download_pos ++ (Int64.of_int b.len); diff --git a/src/daemon/common/commonFile.ml b/src/daemon/common/commonFile.ml index a1962145..7887a1f6 100644 --- a/src/daemon/common/commonFile.ml +++ b/src/daemon/common/commonFile.ml @@ -1133,9 +1133,9 @@ let file_write_bytes file offset s pos len = *) if !!CommonOptions.buffer_writes then - Unix32.buffered_write_copy (file_fd file) offset s pos len + Unix32.buffered_write_copy (file_fd file) offset (Bytes.unsafe_to_string s) pos len else - Unix32.write (file_fd file) offset s pos len + Unix32.write_bytes (file_fd file) offset s pos len let file_write_string file offset s pos len = file_write_bytes file offset (Bytes.unsafe_of_string s) pos len diff --git a/src/daemon/common/commonHasher_c.c b/src/daemon/common/commonHasher_c.c index 05f90f6f..0e1e1762 100644 --- a/src/daemon/common/commonHasher_c.c +++ b/src/daemon/common/commonHasher_c.c @@ -292,7 +292,7 @@ value ml_job_done(value job_v) { if(job_done){ value result_v = Field(job_v, JOB_RESULT); - char *result = Bytes_val(result_v); + char *result = String_val(result_v); int result_len = string_length(result_v); /* printf("job len done: %d\n", result_len); */ diff --git a/src/daemon/driver/driverControlers.ml b/src/daemon/driver/driverControlers.ml index bb76ac25..03df5486 100644 --- a/src/daemon/driver/driverControlers.ml +++ b/src/daemon/driver/driverControlers.ml @@ -1563,7 +1563,7 @@ let http_handler o t r = in r.reply_content <- if !http_file_type <> BIN && !!html_use_gzip then - Bytes.unsafe_to_string (Zlib2.gzip_string s) + Zlib2.gzip_string s else s let http_options = { diff --git a/src/daemon/driver/driverMain.ml b/src/daemon/driver/driverMain.ml index 97e24e7d..81d0eedc 100644 --- a/src/daemon/driver/driverMain.ml +++ b/src/daemon/driver/driverMain.ml @@ -685,7 +685,7 @@ for config files at the end. *) try let oc = Unix.openfile security_space_filename [Unix.O_WRONLY; Unix.O_CREAT] 0o600 in let len = 32768 in - let s = Bytes.make len ' ' in + let s = String.make len ' ' in let pos = ref zero in for i = 1 to !!config_files_security_space do for j = 1 to 32 do (* 32 = 1 MB / 32kB *) diff --git a/src/networks/direct_connect/che3_c.c b/src/networks/direct_connect/che3_c.c index 5f010ad0..865acac2 100644 --- a/src/networks/direct_connect/che3_c.c +++ b/src/networks/direct_connect/che3_c.c @@ -1,5 +1,5 @@ /* rewrite in C and caml stubs by b8_bavard (2002) */ -/* rewrite to class without glib by Mathias K�ster (2002) */ +/* rewrite to class without glib by Mathias Küster (2002) */ /* DCTC - a Direct Connect text clone for Linux * Copyright (C) 2001 Eric Prevoteau diff --git a/src/networks/direct_connect/dcClients.ml b/src/networks/direct_connect/dcClients.ml index 701bf0ff..4d350e6a 100644 --- a/src/networks/direct_connect/dcClients.ml +++ b/src/networks/direct_connect/dcClients.ml @@ -1321,7 +1321,7 @@ let client_downloaded c sock nread = (* TODO check tth while loading, abort if e let downloaded = if c.client_preread_bytes_left > 0 then begin (* if precheck not yet done *) let check_bytes = min nread c.client_preread_bytes_left in (* which is smaller... *) - let check_buffer = String.create check_bytes in + let check_buffer = Bytes.create check_bytes in Unix32.read (file_fd file) (c.client_pos -- (Int64.of_int c.client_preread_bytes_left)) check_buffer 0 check_bytes; let str2 = Bytes.sub b.buf b.pos check_bytes in @@ -1330,7 +1330,7 @@ let client_downloaded c sock nread = (* TODO check tth while loading, abort if e if c.client_preread_bytes_left = 0 then begin (* if checked all preread bytes *) let downloaded = b.len - check_bytes in if downloaded > 0 then begin (* check if buffer has bytes to write to file *) - Unix32.write (file_fd file) c.client_pos b.buf (b.pos+check_bytes) downloaded + Unix32.write_bytes (file_fd file) c.client_pos b.buf (b.pos+check_bytes) downloaded end; Int64.of_int downloaded end else Int64.zero @@ -1342,7 +1342,7 @@ let client_downloaded c sock nread = (* TODO check tth while loading, abort if e Int64.zero end end else begin (* precheck done, normal flow *) - Unix32.write (file_fd file) c.client_pos b.buf b.pos b.len; + Unix32.write_bytes (file_fd file) c.client_pos b.buf b.pos b.len; Int64.of_int b.len end in @@ -1370,7 +1370,7 @@ let client_downloaded c sock nread = (* TODO check tth while loading, abort if e | DcDownloadList filelist_fd -> (* downloading file list *) let b = TcpBufferedSocket.buf sock in let len = Int64.of_int b.len in - Unix32.write filelist_fd c.client_pos b.buf b.pos b.len; + Unix32.write_bytes filelist_fd c.client_pos b.buf b.pos b.len; c.client_pos <- c.client_pos ++ len; (match c.client_user with | Some u -> u.user_downloaded <- u.user_downloaded ++ len @@ -1475,7 +1475,7 @@ let udp_handler sock event = let pbuf = p.UdpSocket.udp_content in let len = Bytes.length pbuf in if len > 0 then - udp_parse (Bytes.to_string pbuf) sock + udp_parse (Bytes.unsafe_to_string pbuf) sock with e -> () ) ) | _ -> () diff --git a/src/networks/direct_connect/dcShared.ml b/src/networks/direct_connect/dcShared.ml index c132b2c3..4506245d 100644 --- a/src/networks/direct_connect/dcShared.ml +++ b/src/networks/direct_connect/dcShared.ml @@ -98,7 +98,7 @@ let file_to_che3_to_string filename = let rec read pos = let rlen = int64_min_int (flen -- pos) slen in let npos = Int64.add pos (Int64.of_int rlen) in - let str = String.create slen in + let str = Bytes.create slen in Unix32.read file_fd pos str 0 rlen; Buffer.add_bytes buf str; if npos < flen then read npos @@ -125,7 +125,7 @@ let string_to_che3_to_file str filename = else wlen in let npos = pos + len in - Unix32.write file_fd (Int64.of_int pos) (Bytes.of_string s) pos len; + Unix32.write file_fd (Int64.of_int pos) s pos len; if npos < slen then write npos in write 0; @@ -146,12 +146,12 @@ let file_to_bz2_to_buffer filename = getchar () in getchar ();*) let rec decompress () = - let str = String.create 4096 in + let str = Bytes.create 4096 in let n = Bzip2.input ic str 0 (Bytes.length str) in if n = 0 then () else begin (*let ss = (String.sub str 0 n) in*) - Buffer.add_bytes buf (Bytes.sub str 0 n); + Buffer.add_string buf (Bytes.sub_string str 0 n); (*lprintf_nl "(%s)" ss;*) decompress () end @@ -180,7 +180,7 @@ let buffer_to_bz2_to_file buf filename = else slen in let npos = pos + len in - let str = Bytes.of_string (Buffer.sub buf pos len) in + let str = Bytes.unsafe_of_string @@ Buffer.sub buf pos len in Bzip2.output oc str 0 len; if npos < blen then compress npos in compress 0; @@ -313,7 +313,7 @@ let () = let codedname = match Filename2.slash with | '/' -> codedname - | c -> let s = String.copy codedname in String2.replace_char s c '/'; s + | c -> String2.replace_char codedname c '/' in (try let dcsh = Hashtbl.find dc_shared_files_by_fullname fullname in diff --git a/src/networks/donkey/donkeyClient.ml b/src/networks/donkey/donkeyClient.ml index 5ccdac8a..ee8ad202 100644 --- a/src/networks/donkey/donkeyClient.ml +++ b/src/networks/donkey/donkeyClient.ml @@ -1932,7 +1932,7 @@ end else *) log_chat_message cip (client_num c) c.client_name s; | M.EmuleCaptchaReq t -> - let b64data = Base64.encode_to_string t in + let b64data = Base64.encode t in let cip = string_of_client_addr c in log_chat_message cip (client_num c) c.client_name ("data:image/bmp;base64," ^ b64data) @@ -2376,8 +2376,7 @@ let read_first_message overnet server cc m sock = porttest_sock := Some sock; set_closer sock (fun _ _ -> porttest_sock := None); set_lifetime sock 30.; - let buff = client_msg_to_string (emule_proto ()) m in - write sock buff 0 (Bytes.length buff); + write_string sock (client_msg_to_string (emule_proto ()) m); None | _ -> diff --git a/src/networks/donkey/donkeyFiles.ml b/src/networks/donkey/donkeyFiles.ml index e2053847..422e66e6 100644 --- a/src/networks/donkey/donkeyFiles.ml +++ b/src/networks/donkey/donkeyFiles.ml @@ -84,9 +84,9 @@ module NewUpload = struct } ) in let s = client_msg_to_string c.client_emule_proto msg in - let slen = Bytes.length s in + let slen = String.length s in let upload_buffer = String.create (slen + len_int) in - Bytes.blit s 0 upload_buffer 0 slen; + String.blit s 0 upload_buffer 0 slen; DonkeyProtoCom.new_string msg upload_buffer; Unix32.read (file_fd file) begin_pos upload_buffer slen len_int; let uploaded = Int64.of_int len_int in @@ -98,7 +98,7 @@ module NewUpload = struct impl.impl_shared_uploaded <- impl.impl_shared_uploaded ++ uploaded); - write sock upload_buffer 0 (Bytes.length upload_buffer); + write_bytes sock upload_buffer; check_end_upload c sock with | End_of_file -> lprintf_nl "Can not send file %s to %s, file removed?" diff --git a/src/networks/donkey/donkeyImport.ml b/src/networks/donkey/donkeyImport.ml index a1177e26..1ade5eba 100644 --- a/src/networks/donkey/donkeyImport.ml +++ b/src/networks/donkey/donkeyImport.ml @@ -37,7 +37,7 @@ let dump_file filename = let n = input ic s 0 20 in lprintf "pos = %d\n" !pos; if n = 0 then raise Exit; - dump_bytes (Bytes.sub s 0 n); + dump (Bytes.sub_string s 0 n); pos := !pos + n; done with End_of_file | Exit -> ()) diff --git a/src/networks/donkey/donkeyOvernetImport.ml b/src/networks/donkey/donkeyOvernetImport.ml index dd37013e..76cbb377 100644 --- a/src/networks/donkey/donkeyOvernetImport.ml +++ b/src/networks/donkey/donkeyOvernetImport.ml @@ -24,7 +24,7 @@ open LittleEndian let dump_file filename = Unix2.tryopen_read_bin filename (fun ic -> - let s = String.create 20 in + let s = Bytes.create 20 in try lprintf "file: %s\n" filename; let pos = ref 0 in @@ -32,7 +32,7 @@ let dump_file filename = let n = input ic s 0 20 in lprintf "pos = %d\n" !pos; if n = 0 then raise Exit; - dump_bytes (Bytes.sub s 0 n); + dump (Bytes.sub_string s 0 n); pos := !pos + n; done with End_of_file -> ()) diff --git a/src/networks/donkey/donkeyProtoCom.ml b/src/networks/donkey/donkeyProtoCom.ml index 5ed9141d..1f68a98b 100644 --- a/src/networks/donkey/donkeyProtoCom.ml +++ b/src/networks/donkey/donkeyProtoCom.ml @@ -46,7 +46,7 @@ let client_msg_to_string emule_version msg = let len = Bytes.length s - 5 in s.[0] <- char_of_int magic; str_int s 1 len; - s + Bytes.unsafe_to_string s let server_msg_to_string msg = Buffer.reset buf; @@ -63,19 +63,17 @@ let server_msg_to_string msg = let s = Buffer.to_bytes buf in let len = Bytes.length s - 5 in str_int s 1 len; - s + Bytes.unsafe_to_string s let server_send sock m = (* lprintf "Message to server"; lprint_newline (); DonkeyProtoServer.print m; *) - let buff = server_msg_to_string m in - write sock buff 0 (Bytes.length buff) + write_string sock (server_msg_to_string m) let direct_client_sock_send emule_version sock m = - let buff = client_msg_to_string emule_version m in - write sock buff 0 (Bytes.length buff) + write_string sock (client_msg_to_string emule_version m) let client_send c m = let emule_version = c.client_emule_proto in @@ -89,7 +87,7 @@ let client_send c m = let servers_send socks m = let m = server_msg_to_string m in - List.iter (fun s -> write s m 0 (Bytes.length m)) socks + List.iter (fun s -> write_string s m) socks let client_handler2 c ff f = let msgs = ref 0 in @@ -103,13 +101,13 @@ let client_handler2 c ff f = None -> emule_proto (); | Some c -> c.client_emule_proto in - let opcode = get_uint8_bytes b.buf b.pos in - let msg_len = get_int_bytes b.buf (b.pos+1) in + let opcode = get_uint8 (Bytes.unsafe_to_string b.buf) b.pos in + let msg_len = get_int (Bytes.unsafe_to_string b.buf) (b.pos+1) in if b.len >= 5 + msg_len then begin - let s = Bytes.sub b.buf (b.pos+5) msg_len in + let s = Bytes.sub_string b.buf (b.pos+5) msg_len in buf_used b (msg_len + 5); - let t = M.parse emule_version opcode (Bytes.to_string s) in + let t = M.parse emule_version opcode s in (* M.print t; lprint_newline (); *) incr msgs; @@ -126,13 +124,13 @@ let cut_messages parse f sock nread = let b = TcpBufferedSocket.buf sock in try while b.len >= 5 do - let opcode = get_uint8_bytes b.buf b.pos in - let msg_len = get_int_bytes b.buf (b.pos+1) in + let opcode = get_uint8 (Bytes.unsafe_to_string b.buf) b.pos in + let msg_len = get_int (Bytes.unsafe_to_string b.buf) (b.pos+1) in if b.len >= 5 + msg_len then begin - let s = Bytes.sub b.buf (b.pos+5) msg_len in + let s = Bytes.sub_string b.buf (b.pos+5) msg_len in buf_used b (msg_len + 5); - let t = parse opcode (Bytes.to_string s) in + let t = parse opcode s in f t sock end else raise Not_found @@ -168,7 +166,7 @@ let udp_handler f sock event = let len = Bytes.length pbuf in if len > 0 then let t = M.parse (int_of_char (Bytes.get pbuf 0)) - (Bytes.to_string (Bytes.sub pbuf 1 (len-1))) in + (Bytes.sub_string pbuf 1 (len-1)) in (* M.print t; *) f t p with e -> () @@ -180,16 +178,16 @@ let udp_basic_handler f sock event = UdpSocket.READ_DONE -> UdpSocket.read_packets sock (fun p -> try - let pbuf = p.UdpSocket.udp_content in - let len = Bytes.length pbuf in + let pbuf = Bytes.unsafe_to_string p.UdpSocket.udp_content in + let len = String.length pbuf in if len = 0 || - int_of_char (Bytes.get pbuf 0) <> DonkeyOpenProtocol.udp_magic then begin + int_of_char pbuf.[0] <> DonkeyOpenProtocol.udp_magic then begin if !verbose_unknown_messages then begin lprintf_nl "Received unknown UDP packet"; - dump_bytes pbuf; + dump pbuf; end; end else begin - let t = Bytes.sub pbuf 1 (len-1) in + let t = String.sub pbuf 1 (len-1) in f t p end with e -> @@ -319,7 +317,7 @@ let server_send_share compressed sock msg = in let s = Buffer.to_bytes buf in str_int s 0 nfiles; - let s = Bytes.sub s 0 prev_len in + let s = Bytes.sub_string s 0 prev_len in if !verbose_share || !verbose then lprintf_nl "Sending %d share%s to server %s:%d%s" nfiles (Printf2.print_plural_s nfiles) (Ip.to_string (peer_ip sock)) (peer_port sock) @@ -333,12 +331,12 @@ let server_send_share compressed sock msg = in (* Emule only sends the string compressed when it is smaller in that state. *) - if compressed && ((Bytes.length s_c) < (Bytes.length s)) then + if compressed && ((String.length s_c) < (String.length s)) then begin buf_int8 buf 0xD4; buf_int buf 0; buf_int8 buf 21; (* ShareReq *) - Buffer.add_bytes buf s_c; + Buffer.add_string buf s_c; Buffer.to_bytes buf end else @@ -346,13 +344,13 @@ let server_send_share compressed sock msg = buf_int8 buf 227; buf_int buf 0; buf_int8 buf 21; (* ShareReq *) - Buffer.add_bytes buf s; + Buffer.add_string buf s; Buffer.to_bytes buf end in let len = Bytes.length s - 5 in str_int s 1 len; - write sock s 0 (Bytes.length s) + write_bytes sock s let client_send_files sock msg = let max_len = !!client_buffer_size - 100 - @@ -365,12 +363,11 @@ let client_send_files sock msg = let nfiles, prev_len = DonkeyProtoClient.ViewFilesReply.write_files_max buf ( make_tagged (Some sock) msg) 0 max_len in - let s = Buffer.to_bytes buf in - let s = Bytes.sub s 0 prev_len in + let s = Bytes.unsafe_of_string @@ Buffer.sub buf 0 prev_len in let len = Bytes.length s - 5 in str_int s 1 len; str_int s 6 nfiles; - write sock s 0 (Bytes.length s) + write_bytes sock s let client_send_dir sock dir files = let max_len = !!client_buffer_size - 100 - @@ -385,13 +382,12 @@ let client_send_dir sock dir files = let nfiles, prev_len = DonkeyProtoClient.ViewFilesReply.write_files_max buf ( make_tagged (Some sock) files) 0 max_len in - let s = Buffer.to_bytes buf in - let s = Bytes.sub s 0 prev_len in + let s = Bytes.unsafe_of_string @@ Buffer.sub buf 0 prev_len in let len = Bytes.length s - 5 in begin str_int s 1 len; str_int s (pos-4) nfiles; end; - write sock s 0 (Bytes.length s) + write_bytes sock s let udp_server_send s t = udp_send (get_udp_sock ()) s.server_ip (s.server_port+4) t diff --git a/src/networks/donkey/donkeyProtoCom.mli b/src/networks/donkey/donkeyProtoCom.mli index 68f09800..63e6e030 100644 --- a/src/networks/donkey/donkeyProtoCom.mli +++ b/src/networks/donkey/donkeyProtoCom.mli @@ -60,11 +60,11 @@ val udp_handler : (* val propagate_working_servers : (Ip.t * int) list -> (Ip.t * int) list -> unit *) val udp_basic_handler : - (bytes -> UdpSocket.udp_packet -> unit) -> UdpSocket.t -> + (string -> UdpSocket.udp_packet -> unit) -> UdpSocket.t -> UdpSocket.event -> unit -val server_msg_to_string : DonkeyProtoServer.t -> bytes -val client_msg_to_string : emule_proto -> DonkeyProtoClient.t -> bytes +val server_msg_to_string : DonkeyProtoServer.t -> string +val client_msg_to_string : emule_proto -> DonkeyProtoClient.t -> string val direct_client_sock_send : emule_proto -> TcpBufferedSocket.t -> DonkeyProtoClient.t -> unit diff --git a/src/networks/donkey/donkeyProtoKademlia.ml b/src/networks/donkey/donkeyProtoKademlia.ml index 0cef6fc8..b0cb041c 100644 --- a/src/networks/donkey/donkeyProtoKademlia.ml +++ b/src/networks/donkey/donkeyProtoKademlia.ml @@ -84,7 +84,7 @@ module P = struct ss.[14] <- s.[pos+13]; ss.[15] <- s.[pos+12]; - Md4.direct_of_string (Bytes.to_string ss) + Md4.direct_of_string @@ Bytes.unsafe_to_string ss let buf_md4 buf s = let s = Md4.direct_to_string s in @@ -400,26 +400,26 @@ module P = struct let kademlia_header_code = char_of_int 0xE4 let kademlia_packed_header_code = char_of_int 0xE5 let kademlia_header = String.make 1 kademlia_header_code - let kademlia_packed_header = Bytes.make 1 kademlia_packed_header_code + let kademlia_packed_header = String.make 1 kademlia_packed_header_code let parse_message ip port pbuf = - let len = Bytes.length pbuf in + let len = String.length pbuf in if len < 2 || - (let magic = Bytes.get pbuf 0 in + (let magic = pbuf.[0] in magic <> kademlia_header_code && magic <> kademlia_packed_header_code) then begin if !CommonOptions.verbose_unknown_messages then begin lprintf_nl "Received unknown UDP packet"; - dump_bytes pbuf; + dump pbuf; end; raise Not_found end else - let magic = Bytes.get pbuf 0 in - let opcode = int_of_char (Bytes.get pbuf 1) in - let msg = Bytes.sub_string pbuf 2 (len-2) in + let magic = pbuf.[0] in + let opcode = int_of_char pbuf.[1] in + let msg = String.sub pbuf 2 (len-2) in let msg = if magic = kademlia_packed_header_code then let s = Zlib2.uncompress_string2 msg in (* lprintf "Uncompressed:\n"; @@ -434,21 +434,21 @@ module P = struct try Buffer.reset udp_buf; write udp_buf msg; - let s = Buffer.to_bytes udp_buf in + let s = Buffer.contents udp_buf in let s = - if Bytes.length s > 200 then - let opcode = Bytes.sub s 0 1 in - let args = Bytes.sub s 1 (Bytes.length s - 1) in - Bytes.cat kademlia_packed_header (Bytes.cat opcode (Zlib2.compress_string args)) + if String.length s > 200 then + let opcode = String.sub s 0 1 in + let args = String.sub s 1 (String.length s - 1) in + kademlia_packed_header ^ opcode ^ (Zlib2.compress_string args) else - Bytes.cat kademlia_packed_header s + kademlia_header ^ s in if !verbose_overnet then begin lprintf_nl "UDP to %s:%d op 0x%02X len %d type %s" - (Ip.to_string ip) port (get_uint8_bytes s 1) (Bytes.length s) (message_to_string msg); + (Ip.to_string ip) port (get_uint8 s 1) (String.length s) (message_to_string msg); end; (* let len = String.length s in @@ -458,7 +458,7 @@ module P = struct end; *) - UdpSocket.write sock ping s ip port + UdpSocket.write sock ping (Bytes.unsafe_of_string s) ip port with | MessageNotImplemented -> () | e -> lprintf_nl "Exception %s in udp_send" (Printexc2.to_string e) @@ -476,7 +476,7 @@ module P = struct Ip.of_inet_addr inet, port | _ -> assert false in - let t = parse_message ip port pbuf in + let t = parse_message ip port (Bytes.unsafe_to_string pbuf) in let is_not_banned ip = match !Ip.banned (ip, None) with None -> true @@ -491,7 +491,7 @@ module P = struct begin lprintf_nl "Error %s in udp_handler, dump of packet:" (Printexc2.to_string e); - dump_bytes p.UdpSocket.udp_content; + dump (Bytes.unsafe_to_string p.UdpSocket.udp_content); lprint_newline () end ); diff --git a/src/networks/donkey/donkeyProtoOvernet.ml b/src/networks/donkey/donkeyProtoOvernet.ml index 303fbb51..3ff18328 100644 --- a/src/networks/donkey/donkeyProtoOvernet.ml +++ b/src/networks/donkey/donkeyProtoOvernet.ml @@ -387,14 +387,14 @@ module Proto = struct UdpSocket.READ_DONE -> UdpSocket.read_packets sock (fun p -> try - let pbuf = p.UdpSocket.udp_content in - let len = Bytes.length pbuf in + let pbuf = Bytes.unsafe_to_string p.UdpSocket.udp_content in + let len = String.length pbuf in if len < 2 || - int_of_char (Bytes.get pbuf 0) <> 227 then + int_of_char pbuf.[0] <> 227 then begin if !verbose_unknown_messages then begin lprintf_nl "Received unknown UDP packet"; - dump_bytes pbuf; + dump pbuf; end end else @@ -405,7 +405,7 @@ module Proto = struct Ip.of_inet_addr inet, port | _ -> assert false in - let t = parse ip port (int_of_char (Bytes.get pbuf 1)) (Bytes.to_string (Bytes.sub pbuf 2 (len-2))) in + let t = parse ip port (int_of_char pbuf.[1]) (String.sub pbuf 2 (len-2)) in let is_not_banned ip = match !Ip.banned (ip, None) with None -> true @@ -420,7 +420,7 @@ module Proto = struct if !verbose_unknown_messages then begin lprintf_nl "Error %s in udp_handler, dump of packet:" (Printexc2.to_string e); - dump_bytes p.UdpSocket.udp_content; + dump (Bytes.unsafe_to_string p.UdpSocket.udp_content); lprint_newline () end ); @@ -441,13 +441,13 @@ module Proto = struct Buffer.reset udp_buf; buf_int8 udp_buf 227; write udp_buf msg; - let s = Buffer.to_bytes udp_buf in + let s = Buffer.contents udp_buf in if !verbose_overnet then begin lprintf_nl "UDP to %s:%d op 0x%02X len %d type %s" - (Ip.to_string ip) port (get_uint8_bytes s 1) (Bytes.length s) (message_to_string msg); + (Ip.to_string ip) port (get_uint8 s 1) (String.length s) (message_to_string msg); end; - UdpSocket.write sock ping s ip port + UdpSocket.write sock ping (Bytes.unsafe_of_string s) ip port with e -> lprintf_nl "Exception %s in udp_send" (Printexc2.to_string e) diff --git a/src/networks/fasttrack/fasttrackGlobals.ml b/src/networks/fasttrack/fasttrackGlobals.ml index df3a61ac..49be9858 100644 --- a/src/networks/fasttrack/fasttrackGlobals.ml +++ b/src/networks/fasttrack/fasttrackGlobals.ml @@ -530,9 +530,9 @@ let client_name () = let name = !!global_login in if name != !old_client_name then begin let len = String.length name in - ft_client_name := String.sub name 0 (min 32 len); old_client_name := name; - String2.replace_char !ft_client_name ' ' '_'; + let name' = String.sub name 0 (min 32 len) in + ft_client_name := String2.replace_char name' ' ' '_'; end; !ft_client_name diff --git a/src/networks/fasttrack/fasttrackServers.ml b/src/networks/fasttrack/fasttrackServers.ml index 32380dde..99aed67f 100644 --- a/src/networks/fasttrack/fasttrackServers.ml +++ b/src/networks/fasttrack/fasttrackServers.ml @@ -159,7 +159,7 @@ let server_parse_cipher s gconn sock = | Some ciphers -> if !verbose_msg_raw then lprintf "Cipher received from server\n"; - get_cipher_from_packet (Bytes.to_string b.buf) b.pos ciphers.in_cipher; + get_cipher_from_packet (Bytes.unsafe_to_string b.buf) b.pos ciphers.in_cipher; init_cipher ciphers.in_cipher; xor_ciphers ciphers.out_cipher ciphers.in_cipher; @@ -253,11 +253,13 @@ let connect_server h = cipher_packet_set out_cipher s 4; + let s = Bytes.unsafe_to_string s in + if !verbose_msg_raw then begin - lprintf "SENDING %s\n" (Bytes.unsafe_to_string (Bytes.escaped s)); - AnyEndian.dump_bytes s; + lprintf "SENDING %s\n" (String.escaped s); + AnyEndian.dump s; end; - write sock s 0 (Bytes.length s); + write_string sock s; with _ -> disconnect_from_server nservers s Closed_connect_failed ) diff --git a/src/networks/fileTP/fileTPGlobals.ml b/src/networks/fileTP/fileTPGlobals.ml index 4a755052..dbbf55da 100644 --- a/src/networks/fileTP/fileTPGlobals.ml +++ b/src/networks/fileTP/fileTPGlobals.ml @@ -302,9 +302,9 @@ let client_name () = let name = !!global_login in if name != !old_client_name then begin let len = String.length name in - ft_client_name := String.sub name 0 (min 32 len); old_client_name := name; - String2.replace_char !ft_client_name ' ' '_'; + let name' = String.sub name 0 (min 32 len) in + ft_client_name := String2.replace_char name' ' ' '_'; end; !ft_client_name diff --git a/src/networks/fileTP/fileTPHTTP.ml b/src/networks/fileTP/fileTPHTTP.ml index 62d6fe4c..c4130f8c 100644 --- a/src/networks/fileTP/fileTPHTTP.ml +++ b/src/networks/fileTP/fileTPHTTP.ml @@ -65,7 +65,7 @@ let http_send_range_request c range sock d = Printf.bprintf buf "Connection: Keep-Alive\r\n"; if url.Url.user <> "" then begin let userpass = Printf.sprintf "%s:%s" url.Url.user url.Url.passwd in - let encoded = Base64.encode_to_string userpass in + let encoded = Base64.encode userpass in Printf.bprintf buf "Authorization: Basic %s\r\n" encoded end; Printf.bprintf buf "\r\n"; diff --git a/src/networks/fileTP/fileTPSSH.ml b/src/networks/fileTP/fileTPSSH.ml index b411abff..6b93c992 100644 --- a/src/networks/fileTP/fileTPSSH.ml +++ b/src/networks/fileTP/fileTPSSH.ml @@ -296,7 +296,7 @@ let ssh_connect token c f = (* lprintf "Received/expected: %d/%d\n" (String.length s) elen; *) - let ss = Bytes.unsafe_to_string (Base64.decode s) in + let ss = Base64.decode s in (* lprintf "Decoded/expected: %d/%d\n" (String.length ss) len; *) diff --git a/src/utils/cdk/file.ml b/src/utils/cdk/file.ml index fc50efa7..b63ce211 100644 --- a/src/utils/cdk/file.ml +++ b/src/utils/cdk/file.ml @@ -19,25 +19,25 @@ (* read a whole file *) let to_string name = - Bytes.to_string (Unix2.tryopen_read_bin name (fun chan -> + Unix2.tryopen_read_bin name (fun chan -> let buf_size = 1024 in - let buf = String.create buf_size in + let buf = Bytes.create buf_size in let rec iter buf nb_read = let buf_size = Bytes.length buf in let to_read = min (buf_size - nb_read) 8192 in let tmp = input chan buf nb_read to_read in if tmp = 0 then - Bytes.sub buf 0 nb_read + Bytes.sub_string buf 0 nb_read else let nb_read = nb_read + tmp in let buf = if nb_read = buf_size then - String2.resize_bytes buf (2 * buf_size) + String2.resize buf (2 * buf_size) else buf in iter buf nb_read in - iter buf 0)) + iter buf 0) let read_whole_chan chan = let buf = Buffer.create 1024 in diff --git a/src/utils/cdk/filename2.ml b/src/utils/cdk/filename2.ml index a0c67057..3b3e49f1 100644 --- a/src/utils/cdk/filename2.ml +++ b/src/utils/cdk/filename2.ml @@ -116,20 +116,19 @@ let to_string filename = List.fold_left (fun file f -> f file) filename !to_strings let path_of_filename filename = + let len = String.length filename in let filename = Bytes.of_string filename in - let len = Bytes.length filename in for i = 0 to len - 1 do - if Bytes.get filename i = '\\' then Bytes.set filename i '/' + if Bytes.get filename i = '\\' then Bytes.set filename i '/'; done; - let filename = Bytes.to_string filename in - let filename = - if len > 2 && filename.[1] = ':' && - (match filename.[0] with - | 'a' .. 'z' | 'A' .. 'Z' -> true - | _ -> false) then - Printf.sprintf "%s/%s" (String.sub filename 0 2) - (String.sub filename 2 (len-2)) - else filename + let filename = + if len > 2 && Bytes.get filename 1 = ':' && + match Bytes.get filename 0 with + 'a' .. 'z' | 'A' .. 'Z' -> true + | _ -> false then + Printf.sprintf "%s/%s" (Bytes.sub_string filename 0 2) + (Bytes.sub_string filename 2 (len-2)) + else Bytes.unsafe_to_string filename in split_simplify filename '/' @@ -143,11 +142,12 @@ let filesystem_compliant name fstype namemax = (* replace all illegal characters with a valid one. assumes all filesystems accept '_'s in filenames *) let escape_chars p filename = - let s = Bytes.of_string filename in - for i = 0 to Bytes.length s - 1 do - if p (Bytes.get s i) then Bytes.set s i '_' - done; - Bytes.to_string s in + let s = Bytes.of_string filename in + for i = 0 to String.length filename - 1 do + if p (Bytes.get s i) then Bytes.set s i '_' + done; + Bytes.unsafe_to_string s + in (* remove all illegal characters at the beginning of filename *) let trim_left p filename = diff --git a/src/utils/cdk/string2.ml b/src/utils/cdk/string2.ml index 6ef5a108..84f20643 100644 --- a/src/utils/cdk/string2.ml +++ b/src/utils/cdk/string2.ml @@ -162,12 +162,7 @@ let check_suffix s suffix = let slen = String.length suffix in len >= slen && String.sub s (len - slen) slen = suffix -let upp_initial s = - if String.length s > 0 then - let first_char = Char.uppercase_ascii s.[0] in - String.make 1 first_char ^ String.sub s 1 (String.length s - 1) - else - s +let upp_initial = String.capitalize_ascii (* not optimal !*) let subequal s1 pos1 s2 pos2 len = @@ -197,30 +192,13 @@ let of_char c = String.make 1 c let resize s newlen = - let len = String.length s in - if len > newlen then - String.sub s 0 newlen - else - let str = Bytes.create newlen in - Bytes.blit_string s 0 str 0 len; - Bytes.to_string str - -let resize_bytes s newlen = let len = Bytes.length s in - if len > newlen then - Bytes.sub s 0 newlen + if len > newlen then Bytes.sub s 0 newlen else - let str = Bytes.create newlen in - Bytes.blit s 0 str 0 len; - str - -let init len f = - let s = String.create len in - for i = 0 to len - 1 do - s.[i] <- f i - done; - s - + let b = Bytes.create newlen in + Bytes.blit s 0 b 0 len; + b + let is_space c = c = ' ' || c = '\n' || c = '\r' || c = '\t' let tokens s = @@ -277,20 +255,21 @@ let starts_with s1 s2 = len2 <= len1 && strneql s1 s2 len2 let replace_char s c1 c2 = - let rep c = if c == c1 then c2 else c in - String.map rep s; - () + let s = Bytes.of_string s in + for i = 0 to Bytes.length s - 1 do + if Bytes.get s i = c1 then Bytes.set s i c2 + done; + Bytes.unsafe_to_string s let stem s = - let s = String.lowercase_ascii s in - let result = Bytes.of_string s in - for i = 0 to Bytes.length result - 1 do - let c = Bytes.get result i in + let s = Bytes.of_string (String.lowercase_ascii s) in + for i = 0 to Bytes.length s - 1 do + let c = Bytes.get s i in match c with - | 'a'..'z' | '0'..'9' -> () - | _ -> Bytes.set result i ' ' + 'a'..'z' | '0' .. '9' -> () + | _ -> Bytes.set s i ' '; done; - split_simplify (Bytes.to_string result) ' ' + split_simplify (Bytes.unsafe_to_string s) ' ' let map f s = let len = String.length s in @@ -308,12 +287,7 @@ let iteri f s = f i s.[i] done -let init n f = - let s = String.create n in - for i = 0 to n - 1 do - s.[i] <- f i - done; - Bytes.to_string s +let init = String.init let exists p s = let l = String.length s in diff --git a/src/utils/cdk/string2.mli b/src/utils/cdk/string2.mli index 413cd893..854c5b1c 100644 --- a/src/utils/cdk/string2.mli +++ b/src/utils/cdk/string2.mli @@ -79,12 +79,9 @@ val subcontains : string -> string -> bool val of_char : char -> string (*d [of_char c] returns the string containing one [c]. *) -val resize : string -> int -> string +val resize : bytes -> int -> bytes (*d [resize s len] returns a string of length [len] starting with [s]. *) - -val resize_bytes: bytes -> int -> bytes -(*d [resize s len] returns a byffer of length [len] starting with [s]. *) - + val init : int -> (int -> char) -> string val tokens: string -> string list @@ -96,7 +93,7 @@ external contains : string -> string -> bool = "ml_strstr" val starts_with : (* string *) string -> (* start *) string -> bool (* [replace_char s c1 c2] replaces char [c1] by char [c2] in [s] *) -val replace_char : string -> char -> char -> unit +val replace_char : string -> char -> char -> string (* [stem s] cuts the string [s] in small words, for indexation eg *) val stem : string -> string list diff --git a/src/utils/cdk/unix2.ml b/src/utils/cdk/unix2.ml index 60fc85a5..051e99de 100644 --- a/src/utils/cdk/unix2.ml +++ b/src/utils/cdk/unix2.ml @@ -130,7 +130,7 @@ let rec really_write fd s pos len = (* lprintf "really_write 0 BYTES !!!!!!!!!\n"; *) raise End_of_file end else - let nwrite = Unix.write fd s pos len in + let nwrite = Unix.write_substring fd s pos len in if nwrite = 0 then raise End_of_file else if nwrite < len then really_write fd s (pos + nwrite) (len - nwrite) @@ -205,18 +205,18 @@ let rec remove_all_directory dirname = Unix.rmdir dirname let random () = - let s = Bytes.create 7 in + let s = String.create 7 in for i = 0 to 6 do s.[i] <- char_of_int (97 + Random.int 26) done; - (Bytes.to_string s) + Bytes.unsafe_to_string s let can_write_to_directory dirname = let temp_file = Filename.concat dirname "tmp_" ^ random () ^ "_mld.tmp" in let check () = with_remove temp_file (fun _ -> tryopen_openfile temp_file [O_WRONLY; O_CREAT] 0o600 (fun fd -> let test_string = "mldonkey accesstest - this file can be deleted\n" in - really_write fd (Bytes.of_string test_string) 0 (String.length test_string))) + really_write fd test_string 0 (String.length test_string))) in try check () diff --git a/src/utils/cdk/zlib2.ml b/src/utils/cdk/zlib2.ml index 1e16b774..5e7d1170 100644 --- a/src/utils/cdk/zlib2.ml +++ b/src/utils/cdk/zlib2.ml @@ -10,54 +10,54 @@ let zlib_version_num () = end let grow_buffer s = - let s' = String.create (2 * Bytes.length s) in + let s' = Bytes.create (2 * Bytes.length s) in Bytes.blit s 0 s' 0 (Bytes.length s); s' let compress_string ?(level = 6) inbuf = let zs = deflate_init level true in let rec compr inpos outbuf outpos = - let inavail = Bytes.length inbuf - inpos in + let inavail = String.length inbuf - inpos in let outavail = Bytes.length outbuf - outpos in if outavail = 0 then compr inpos (grow_buffer outbuf) outpos else begin let (finished, used_in, used_out) = - deflate zs inbuf inpos inavail outbuf outpos outavail + deflate_string zs inbuf inpos inavail outbuf outpos outavail (if inavail = 0 then Z_FINISH else Z_NO_FLUSH) in if finished then - Bytes.sub outbuf 0 (outpos + used_out) + Bytes.sub_string outbuf 0 (outpos + used_out) else compr (inpos + used_in) outbuf (outpos + used_out) end in - let res = compr 0 (String.create (Bytes.length inbuf)) 0 in + let res = compr 0 (Bytes.create (String.length inbuf)) 0 in deflate_end zs; res (* header info from camlzip/gpl *) -let gzip_bytes ?(level = 6) inbuf = - if Bytes.length inbuf <= 0 then Bytes.empty else +let gzip_string ?(level = 6) inbuf = + if String.length inbuf <= 0 then "" else begin let zs = deflate_init level false in let out_crc = ref Int32.zero in let rec compr inpos outbuf outpos = - let inavail = Bytes.length inbuf - inpos in + let inavail = String.length inbuf - inpos in let outavail = Bytes.length outbuf - outpos in if outavail = 0 then compr inpos (grow_buffer outbuf) outpos else begin let (finished, used_in, used_out) = - deflate zs inbuf inpos inavail outbuf outpos outavail + deflate_string zs inbuf inpos inavail outbuf outpos outavail (if inavail = 0 then Z_FINISH else Z_NO_FLUSH) in - out_crc := update_crc !out_crc inbuf inpos used_in; + out_crc := update_crc_string !out_crc inbuf inpos used_in; if finished then - Bytes.sub outbuf 0 (outpos + used_out) + Bytes.sub_string outbuf 0 (outpos + used_out) else compr (inpos + used_in) outbuf (outpos + used_out) end in - let res = compr 0 (String.create (Bytes.length inbuf)) 0 in + let res = compr 0 (Bytes.create (String.length inbuf)) 0 in deflate_end zs; - let buf = Buffer.create (18 + Bytes.length res) in + let buf = Buffer.create (18 + String.length res) in let write_int wbuf n = Buffer.add_char wbuf (char_of_int n) in @@ -75,15 +75,12 @@ let gzip_bytes ?(level = 6) inbuf = for i = 1 to 4 do write_int buf 0 done; write_int buf 0; write_int buf 0xFF; - Buffer.add_bytes buf res; + Buffer.add_string buf res; write_int32 buf !out_crc; - write_int32 buf (Int32.of_int (Bytes.length inbuf)); - Buffer.to_bytes buf + write_int32 buf (Int32.of_int (String.length inbuf)); + Buffer.contents buf end -let gzip_string ?(level = 6) instr = - gzip_bytes ~level:level (Bytes.of_string instr) - let uncompress_string2 inbuf = let zs = inflate_init true in let rec uncompr inpos outbuf outpos = @@ -113,7 +110,7 @@ let uncompress_string s = String.blit s !pos b 0 n; pos := !pos + n; n end - ) (fun s len -> Buffer.add_bytes buf (Bytes.sub s 0 len)); + ) (fun s len -> Buffer.add_string buf (Bytes.sub_string s 0 len)); Buffer.contents buf diff --git a/src/utils/cdk/zlib2.mli b/src/utils/cdk/zlib2.mli index f7ec113f..6e27f954 100644 --- a/src/utils/cdk/zlib2.mli +++ b/src/utils/cdk/zlib2.mli @@ -1,8 +1,7 @@ val uncompress_string : string -> string val uncompress_string2 : string -> string -val compress_string : ?level:int -> bytes -> bytes -val gzip_string : ?level:int -> string -> bytes -val gzip_bytes : ?level:int -> bytes -> bytes +val compress_string : ?level:int -> string -> string +val gzip_string : ?level:int -> string -> string val zlib_version_num : unit -> string diff --git a/src/utils/lib/misc2.mlcpp b/src/utils/lib/misc2.mlcpp index 2f66a393..6f60f623 100644 --- a/src/utils/lib/misc2.mlcpp +++ b/src/utils/lib/misc2.mlcpp @@ -26,7 +26,7 @@ let bz2_extract filename = else begin let file = ref "" in try - let buffer = String.create 4096 in + let buffer = Bytes.create 4096 in let file_out = Filename2.temp_file "arch_" ".tmp" in file := file_out; let ic = Bzip2.open_in filename diff --git a/src/utils/lib/unix32.ml b/src/utils/lib/unix32.ml index d9e2c197..6ba7e089 100644 --- a/src/utils/lib/unix32.ml +++ b/src/utils/lib/unix32.ml @@ -318,7 +318,7 @@ module FDCache = struct file_pos len string_pos - (Bytes.length string) + (String.length string) (Printexc2.to_string e); raise e @@ -333,7 +333,7 @@ module FDCache = struct let len = Int64.to_int len64 in if len > 0 then begin read t1 pos1 buffer 0 len; - write t2 pos2 buffer 0 len; + write t2 pos2 (Bytes.unsafe_to_string buffer) 0 len; iter (remaining -- len64) (pos1 ++ len64) (pos2 ++ len64) end in @@ -364,7 +364,7 @@ module type File = sig val exists : t -> bool val remove : t -> unit val read : t -> int64 -> bytes -> int -> int -> unit - val write : t -> int64 -> bytes -> int -> int -> unit + val write : t -> int64 -> string -> int -> int -> unit val destroy : t -> unit val is_closed : t -> bool end @@ -1110,7 +1110,7 @@ type file = { mutable filename : string; mutable writable : bool; mutable error : exn option; - mutable buffers : (bytes * int * int * int64 * int64) list; + mutable buffers : (string * int * int * int64 * int64) list; } module H = Weak.Make(struct @@ -1216,14 +1216,16 @@ let write file file_pos string string_pos len = | Destroyed -> failwith "Unix32.write on destroyed FD" else lprintf_nl "Unix32.write: error, invalid argument len = 0" + +let write_bytes f fpos b bpos len = write f fpos (Bytes.unsafe_to_string b) bpos len let buffer = Buffer.create 65000 let flush_buffer t offset = if !verbose then lprintf_nl "flush_buffer"; - let s = Buffer.to_bytes buffer in + let s = Buffer.contents buffer in Buffer.reset buffer; - let len = Bytes.length s in + let len = String.length s in try if !verbose then lprintf_nl "seek64 %Ld" offset; if len > 0 then write t offset s 0 len; @@ -1258,7 +1260,7 @@ let flush_fd t = | [] -> () | (s, pos_s, len_s, offset, len) :: tail -> Buffer.reset buffer; - Buffer.add_subbytes buffer s pos_s len_s; + Buffer.add_substring buffer s pos_s len_s; t.buffers <- tail; iter_in offset len @@ -1268,7 +1270,7 @@ let flush_fd t = | (s, pos_s, len_s, offset2, len2) :: tail -> let in_offset = offset ++ len -- offset2 in if in_offset = Int64.zero then begin - Buffer.add_subbytes buffer s pos_s len_s; + Buffer.add_substring buffer s pos_s len_s; t.buffers <- tail; iter_in offset (len ++ len2); end else @@ -1284,7 +1286,7 @@ let flush_fd t = iter_in offset len end else begin let new_pos = len2 -- keep_len in - Buffer.add_subbytes buffer s + Buffer.add_substring buffer s (pos_s + Int64.to_int new_pos) (Int64.to_int keep_len); buffered_bytes := !buffered_bytes -- new_pos; iter_in offset (len ++ keep_len) @@ -1343,7 +1345,7 @@ let buffered_write t offset s pos_s len_s = raise e let buffered_write_copy t offset s pos_s len_s = - buffered_write t offset (Bytes.sub s pos_s len_s) 0 len_s + buffered_write t offset (String.sub s pos_s len_s) 0 len_s let copy_chunk t1 t2 pos1 pos2 len = flush_fd t1; @@ -1354,7 +1356,7 @@ let copy_chunk t1 t2 pos1 pos2 len = let len = mini remaining buffer_size in if len > 0 then begin read t1 pos1 buffer 0 len; - write t2 pos2 buffer 0 len; + write t2 pos2 (Bytes.unsafe_to_string buffer) 0 len; let len64 = Int64.of_int len in iter (remaining - len) (pos1 ++ len64) (pos2 ++ len64) end diff --git a/src/utils/lib/unix32.mli b/src/utils/lib/unix32.mli index 1a8cfcd2..2145f18b 100644 --- a/src/utils/lib/unix32.mli +++ b/src/utils/lib/unix32.mli @@ -52,9 +52,10 @@ val owner : string -> (string * string) val flush : unit -> unit val flush_fd : t -> unit -val buffered_write : t -> int64 -> bytes -> int -> int -> unit -val buffered_write_copy : t -> int64 -> bytes -> int -> int -> unit -val write : t -> int64 -> bytes -> int -> int -> unit +val buffered_write : t -> int64 -> string -> int -> int -> unit +val buffered_write_copy : t -> int64 -> string -> int -> int -> unit +val write : t -> int64 -> string -> int -> int -> unit +val write_bytes : t -> int64 -> bytes -> int -> int -> unit val max_buffered : int64 ref val remove : t -> unit diff --git a/src/utils/net/anyEndian.ml b/src/utils/net/anyEndian.ml index d3f44ad1..3370a3e5 100644 --- a/src/utils/net/anyEndian.ml +++ b/src/utils/net/anyEndian.ml @@ -199,6 +199,3 @@ let sdump s = let dump s = lprintf "%s" (sdump s) - -let dump_bytes s = - lprintf "%s" (sdump (Bytes.unsafe_to_string s)) diff --git a/src/utils/net/base64.ml b/src/utils/net/base64.ml index 24f4a295..6f788345 100644 --- a/src/utils/net/base64.ml +++ b/src/utils/net/base64.ml @@ -75,10 +75,10 @@ let encode_with_options b64 equal s pos len linelen crlf = (Char.code (String.unsafe_get s (p+2))) in (* Obviously, 'bits' is a 24 bit entity (i.e. bits < 2**24) *) assert(!j + 3 < l_t'); - String.unsafe_set t !j (Array.unsafe_get b64 ( bits lsr 18)); - String.unsafe_set t (!j+1) (Array.unsafe_get b64 ((bits lsr 12) land 63)); - String.unsafe_set t (!j+2) (Array.unsafe_get b64 ((bits lsr 6) land 63)); - String.unsafe_set t (!j+3) (Array.unsafe_get b64 ( bits land 63)); + Bytes.unsafe_set t !j (Array.unsafe_get b64 ( bits lsr 18)); + Bytes.unsafe_set t (!j+1) (Array.unsafe_get b64 ((bits lsr 12) land 63)); + Bytes.unsafe_set t (!j+2) (Array.unsafe_get b64 ((bits lsr 6) land 63)); + Bytes.unsafe_set t (!j+3) (Array.unsafe_get b64 ( bits land 63)); j := !j + 4; if linelen > 3 then begin q := !q + 4; @@ -135,15 +135,13 @@ let encode_with_options b64 equal s pos len linelen crlf = end; end; - t ;; + Bytes.unsafe_to_string t let encode s = encode_with_options rfc_pattern '=' s 0 (String.length s) 0 false;; -let encode_to_string s = - Bytes.to_string (encode s) let encode_substring s pos len = encode_with_options rfc_pattern '=' s pos len 0 false;; @@ -209,7 +207,7 @@ let decode_substring t ~pos ~len ~url_variant:p_url ~accept_spaces:p_spaces = in let l_s = (l_t / 4) * 3 - pad_chars in (* sic! *) - let s = String.create l_s in + let s = Bytes.create l_s in let decode_char c = match c with @@ -250,9 +248,9 @@ let decode_substring t ~pos ~len ~url_variant:p_url ~accept_spaces:p_spaces = let x0 = (n0 lsl 2) lor (n1 lsr 4) in let x1 = ((n1 lsl 4) land 0xf0) lor (n2 lsr 2) in let x2 = ((n2 lsl 6) land 0xc0) lor n3 in - String.unsafe_set s q (Char.chr x0); - String.unsafe_set s (q+1) (Char.chr x1); - String.unsafe_set s (q+2) (Char.chr x2); + Bytes.unsafe_set s q (Char.chr x0); + Bytes.unsafe_set s (q+1) (Char.chr x1); + Bytes.unsafe_set s (q+2) (Char.chr x2); done; end else begin @@ -271,9 +269,9 @@ let decode_substring t ~pos ~len ~url_variant:p_url ~accept_spaces:p_spaces = let x0 = (n0 lsl 2) lor (n1 lsr 4) in let x1 = ((n1 lsl 4) land 0xf0) lor (n2 lsr 2) in let x2 = ((n2 lsl 6) land 0xc0) lor n3 in - String.unsafe_set s q (Char.chr x0); - String.unsafe_set s (q+1) (Char.chr x1); - String.unsafe_set s (q+2) (Char.chr x2); + Bytes.unsafe_set s q (Char.chr x0); + Bytes.unsafe_set s (q+1) (Char.chr x1); + Bytes.unsafe_set s (q+2) (Char.chr x2); done; cursor := pos + l_t - 4; end; @@ -318,7 +316,7 @@ let decode_substring t ~pos ~len ~url_variant:p_url ~accept_spaces:p_spaces = end; - s ;; + Bytes.unsafe_to_string s ;; diff --git a/src/utils/net/base64.mli b/src/utils/net/base64.mli index 3c329706..c776b6f8 100644 --- a/src/utils/net/base64.mli +++ b/src/utils/net/base64.mli @@ -1,5 +1,4 @@ -val encode : string -> bytes -val encode_to_string : string -> string -val encode_substring : string -> int -> int -> bytes -val decode : string -> bytes +val encode : string -> string +val encode_substring : string -> int -> int -> string +val decode : string -> string diff --git a/src/utils/net/cobs.ml b/src/utils/net/cobs.ml index b8993e45..6441343c 100644 --- a/src/utils/net/cobs.ml +++ b/src/utils/net/cobs.ml @@ -98,16 +98,16 @@ let encodeData pdest psrc srclen = let decode psrc = let srclen = String.length psrc in let dstlen = calcDecodedLength psrc srclen in - let pdest = String.create dstlen in + let pdest = Bytes.create dstlen in decodeData pdest psrc srclen; - (Bytes.to_string pdest) + Bytes.unsafe_to_string pdest let encode psrc = let srclen = String.length psrc in let dstlen = calcEncodedLength psrc srclen in - let pdest = String.create dstlen in + let pdest = Bytes.create dstlen in encodeData pdest psrc srclen; - pdest + Bytes.unsafe_to_string pdest (* ggep: @@ -261,15 +261,15 @@ let write_ggep buf put_magic last_block b = let id_len = String.length id in if put_magic then Buffer.add_char buf '\195'; let cobs_encoded = String.contains data '\000' in - let data = if cobs_encoded then encode data else (Bytes.of_string data) in + let data = if cobs_encoded then encode data else data in let flags = id_len in let flags = if cobs_encoded then flags lor (1 lsl 6) else flags in let flags = if last_block then flags lor (1 lsl 7) else flags in buf_int8 buf flags; Buffer.add_string buf id; - let data_len = Bytes.length data in + let data_len = String.length data in put_len buf true data_len; - Buffer.add_bytes buf data + Buffer.add_string buf data let write_block buf list = let rec iter put_magic list = @@ -352,17 +352,17 @@ let write buf list = String.make 1 (char_of_int up) else if up land 0xffff = up then - let s = String.create 2 in + let s = Bytes.create 2 in LittleEndian.str_int16 s 0 up; - (Bytes.to_string s) + Bytes.unsafe_to_string s else if up land 0xffffff = up then - let s = String.create 3 in + let s = Bytes.create 3 in LittleEndian.str_int24 s 0 up; - (Bytes.to_string s) + Bytes.unsafe_to_string s else - let s = String.create 4 in + let s = Bytes.create 4 in LittleEndian.str_int s 0 up; - (Bytes.to_string s) + Bytes.unsafe_to_string s in GGEP.GGEP ("DU", s) ) list diff --git a/src/utils/net/http_client.ml b/src/utils/net/http_client.ml index 7bb568a4..98f430e3 100644 --- a/src/utils/net/http_client.ml +++ b/src/utils/net/http_client.ml @@ -124,12 +124,12 @@ let make_full_request r = end; begin match r.req_proxy with | Some (_,_,Some (login,password)) -> - Printf.bprintf res "Proxy-Authorization: Basic %s\n" (Base64.encode_to_string (login ^ ":" ^ password)) + Printf.bprintf res "Proxy-Authorization: Basic %s\n" (Base64.encode (login ^ ":" ^ password)) | _ -> () end; if url.user <> "" then begin let userpass = Printf.sprintf "%s:%s" url.user url.passwd in - Printf.bprintf res "Authorization: Basic %s\r\n" (Base64.encode_to_string userpass) + Printf.bprintf res "Authorization: Basic %s\r\n" (Base64.encode userpass) end; if is_real_post then begin let post = Buffer.create 80 in @@ -203,13 +203,13 @@ let read_header header_handler sock nread = let c = (Bytes.get b.buf (i+1)) in if c = '\n' then let len = i + 2 - b.pos in - let header = Bytes.sub b.buf b.pos len |> Bytes.to_string in + let header = Bytes.sub_string b.buf b.pos len in buf_used b len; header_handler sock header else if c = '\r' && i <= end_pos - 3 && (Bytes.get b.buf (i+2)) = '\n' then let len = i + 3 - b.pos in - let header = Bytes.sub b.buf b.pos len |> Bytes.to_string in + let header = Bytes.sub_string b.buf b.pos len in buf_used b len; header_handler sock header else @@ -539,8 +539,7 @@ let split_header header = ) else if Bytes.get header_bytes i = ',' then Bytes.set header_bytes (i - 1) ',' done; - let modified_header = Bytes.to_string header_bytes in - String2.split_simplify modified_header '\n' + String2.split_simplify (Bytes.unsafe_to_string header_bytes) '\n' let cut_headers headers = try diff --git a/src/utils/net/http_server.ml b/src/utils/net/http_server.ml index 06abce08..e8adad69 100644 --- a/src/utils/net/http_server.ml +++ b/src/utils/net/http_server.ml @@ -80,7 +80,7 @@ let decode64 s = if s.[len-1] = '=' then if s.[len-2] = '=' then 2 else 1 else 0 in - Bytes.sub res 0 (len_res - nb_cut) + Bytes.sub_string res 0 (len_res - nb_cut) let debug = ref false @@ -282,7 +282,7 @@ let parse_head sock s = "authorization" -> let _, pass = String2.cut_at value ' ' in let pass = decode64 pass in - let login, pswd = String2.cut_at (Bytes.to_string pass) ':' in + let login, pswd = String2.cut_at pass ':' in { options with login = login; passwd = pswd } @@ -794,16 +794,16 @@ let request_handler config sock nread = let end_pos = b.pos + b.len in if i < end_pos then if Bytes.get b.buf i = '\n' && i <= end_pos - 2 then - let c = (Bytes.get b.buf (i+1)) in + let c = Bytes.get b.buf (i+1) in if c = '\n' then let len = i + 2 - b.pos in - let header = Bytes.to_string (Bytes.sub b.buf b.pos len) in + let header = Bytes.sub_string b.buf b.pos len in buf_used b len; manage config sock header else if c = '\r' && i <= end_pos - 3 && Bytes.get b.buf (i+2) = '\n' then let len = i + 3 - b.pos in - let header = Bytes.to_string (Bytes.sub b.buf b.pos len) in + let header = Bytes.sub_string b.buf b.pos len in buf_used b len; manage config sock header else diff --git a/src/utils/net/mailer.ml b/src/utils/net/mailer.ml index d825700b..7de49172 100644 --- a/src/utils/net/mailer.ml +++ b/src/utils/net/mailer.ml @@ -73,10 +73,8 @@ let rfc2047_encode h encoding s = copy ending; Buffer.contents buf -let send_bytes oc s = Printf.fprintf oc "%a\r\n" output_bytes s; flush oc -let send_string oc s = Printf.fprintf oc "%s\r\n" s; flush oc -let send1_bytes oc s p = Printf.fprintf oc "%a %a\r\n" output_bytes s output_bytes p; flush oc -let send1_string oc s p = Printf.fprintf oc "%s %s\r\n" s p; flush oc +let send oc s = Printf.fprintf oc "%s\r\n" s; flush oc +let send1 oc s p = Printf.fprintf oc "%s %s\r\n" s p; flush oc let simple_connect hostname port = let s = socket PF_INET SOCK_STREAM 0 in @@ -145,23 +143,24 @@ let canon_addr s = iter_end s (len - 1) let string_xor s1 s2 = - assert (Bytes.length s1 = Bytes.length s2); - let s = Bytes.create (Bytes.length s1) in + assert (String.length s1 = String.length s2); + let s = Bytes.create (String.length s1) in for i = 0 to Bytes.length s - 1 do - s.[i] <- Char.chr (Char.code (Bytes.get s1 i) lxor Char.code (Bytes.get s2 i)); + s.[i] <- Char.chr (Char.code s1.[i] lxor Char.code s2.[i]); done; - s + Bytes.unsafe_to_string s (* HMAC-MD5, RFC 2104 *) let hmac_md5 = - let ipad = Bytes.make 64 '\x36' in - let opad = Bytes.make 64 '\x5C' in + let ipad = String.make 64 '\x36' in + let opad = String.make 64 '\x5C' in let md5 s = Md5.direct_to_string (Md5.string s) in fun secret challenge -> let secret = if String.length secret > 64 then md5 secret else secret in let k = Bytes.make 64 '\x00' in String.blit secret 0 k 0 (String.length secret); - md5 (Bytes.to_string (string_xor k opad) ^ md5 (Bytes.to_string(string_xor k ipad) ^ challenge)) + let k = Bytes.unsafe_to_string k in + md5 (string_xor k opad ^ md5 (string_xor k ipad ^ challenge)) let sendmail smtp_server smtp_port new_style mail = (* a completely synchronous function (BUG) *) @@ -194,63 +193,63 @@ let sendmail smtp_server smtp_port new_style mail = try if read_response ic <> 220 then bad_response (); - send1_string oc "EHLO" (gethostname ()); + send1 oc "EHLO" (gethostname ()); if read_response_auth ic <> 250 then bad_response (); if mail.smtp_login <> "" then begin if !auth_cram_enabled then (* prefer CRAM-MD5 *) begin - send_string oc "AUTH CRAM-MD5"; + send oc "AUTH CRAM-MD5"; match get_response ic with | (334,true,s) -> (* RFC 2195 *) - let digest = hmac_md5 mail.smtp_password (Bytes.to_string (Base64.decode s)) in - send_bytes oc (Base64.encode (Printf.sprintf "%s %s" mail.smtp_login digest)); + let digest = hmac_md5 mail.smtp_password (Base64.decode s) in + send oc (Base64.encode (Printf.sprintf "%s %s" mail.smtp_login digest)); if read_response ic <> 235 then bad_response () | _ -> bad_response () end else if !auth_login_enabled then begin - send_string oc "AUTH LOGIN"; + send oc "AUTH LOGIN"; if read_response ic <> 334 then bad_response (); - send_bytes oc (Base64.encode mail.smtp_login); + send oc (Base64.encode mail.smtp_login); if read_response ic <> 334 then bad_response (); - send_bytes oc (Base64.encode mail.smtp_password); + send oc (Base64.encode mail.smtp_password); if read_response ic <> 235 then bad_response () end else if !auth_plain_enabled then begin let auth = Printf.sprintf "\x00%s\x00%s" mail.smtp_login mail.smtp_password in - send1_bytes oc (Bytes.of_string "AUTH PLAIN") (Base64.encode auth); + send1 oc "AUTH PLAIN" (Base64.encode auth); if read_response ic <> 235 then bad_response () end end; - send1_string oc "MAIL FROM:" (mail_address new_style (canon_addr mail.mail_from)); + send1 oc "MAIL FROM:" (mail_address new_style (canon_addr mail.mail_from)); if read_response ic <> 250 then bad_response (); List.iter begin fun address -> - send1_string oc "RCPT TO:" (mail_address new_style (canon_addr address)); + send1 oc "RCPT TO:" (mail_address new_style (canon_addr address)); if read_response ic <> 250 then bad_response (); end mail.mail_to; - send_string oc "DATA"; + send oc "DATA"; if read_response ic <> 354 then bad_response (); let body = make_mail mail new_style in - send_string oc body; - send_string oc "."; + send oc body; + send oc "."; if read_response ic <> 250 then bad_response (); - send_string oc "QUIT"; + send oc "QUIT"; if read_response ic <> 221 then bad_response (); close_out oc; with e -> - send_string oc "QUIT"; + send oc "QUIT"; if read_response ic <> 221 then bad_response (); close_out oc; raise e diff --git a/src/utils/net/tcpBufferedSocket.ml b/src/utils/net/tcpBufferedSocket.ml index 3f123ace..614a27a6 100644 --- a/src/utils/net/tcpBufferedSocket.ml +++ b/src/utils/net/tcpBufferedSocket.ml @@ -1349,7 +1349,7 @@ let connect token name host port handler = Printf.bprintf buf "Proxy-Connection: Keep-Alive\n"; begin match proxy_auth with | Some (login,password) -> - Printf.bprintf buf "Proxy-Authorization: Basic %s\n" (Base64.encode_to_string (login ^ ":" ^ password)) + Printf.bprintf buf "Proxy-Authorization: Basic %s\n" (Base64.encode (login ^ ":" ^ password)) | None -> () end; Printf.bprintf buf "User-Agent: MLdonkey/%s\n" Autoconf.current_version; From be98e729d7988b764182b9fa9b8c2da5b7c34287 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Thu, 27 Jun 2024 20:14:31 +0200 Subject: [PATCH 65/69] Sync with upstream. --- src/utils/cdk/bzip2.ml | 4 +- src/utils/cdk/bzip2.mli | 4 +- src/utils/lib/CryptoPP.h | 5 -- src/utils/lib/bitv.ml | 2 +- src/utils/lib/magiclib.ml | 4 +- src/utils/lib/md4.ml | 79 +++++++++++++++-------------- src/utils/lib/misc.ml | 2 +- src/utils/lib/verificationBitmap.ml | 42 +++++++-------- 8 files changed, 69 insertions(+), 73 deletions(-) diff --git a/src/utils/cdk/bzip2.ml b/src/utils/cdk/bzip2.ml index 694f82af..d542a613 100644 --- a/src/utils/cdk/bzip2.ml +++ b/src/utils/cdk/bzip2.ml @@ -88,7 +88,7 @@ let rec really_input iz buf pos len = really_input iz buf (pos + n) (len - n) end -let char_buffer = String.create 1 +let char_buffer = Bytes.create 1 let input_char iz = if input iz char_buffer 0 1 = 0 then raise End_of_file else Bytes.get char_buffer 0 @@ -115,7 +115,7 @@ type out_channel = let open_out_chan ?(level = 6) oc = if level < 1 || level > 9 then invalid_arg "Bzip2.open_out: bad level"; { out_chan = oc; - out_buffer = String.create buffer_size; + out_buffer = Bytes.create buffer_size; out_pos = 0; out_avail = buffer_size; out_stream = Bzlib.compress_init level 0 0; diff --git a/src/utils/cdk/bzip2.mli b/src/utils/cdk/bzip2.mli index 04287079..01969973 100644 --- a/src/utils/cdk/bzip2.mli +++ b/src/utils/cdk/bzip2.mli @@ -25,7 +25,7 @@ val input_byte: in_channel -> int val input: in_channel -> bytes -> int -> int -> int (* [input ic buf pos len] uncompresses up to [len] characters from the given channel [ic], - storing them in string [buf], starting at character number [pos]. + storing them in buffer [buf], starting at character number [pos]. It returns the actual number of characters read, between 0 and [len] (inclusive). A return value of 0 means that the end of file was reached. @@ -41,7 +41,7 @@ val input: in_channel -> bytes -> int -> int -> int val really_input: in_channel -> bytes -> int -> int -> unit (* [really_input ic buf pos len] uncompresses [len] characters from the given channel, storing them in - string [buf], starting at character number [pos]. + buffer [buf], starting at character number [pos]. Raise [End_of_file] if fewer than [len] characters can be read. Raise [Invalid_argument "Bzip2.input"] if [pos] and [len] do not designate a valid substring of [buf]. *) diff --git a/src/utils/lib/CryptoPP.h b/src/utils/lib/CryptoPP.h index 52d1009f..01229bed 100644 --- a/src/utils/lib/CryptoPP.h +++ b/src/utils/lib/CryptoPP.h @@ -86,8 +86,6 @@ #define CRYPTOPP_H #include -#define CAML_NAME_SPACE -#include #include //////////////////////////////////////////////////////////////////////////////// @@ -102,9 +100,6 @@ # define IS_LITTLE_ENDIAN #endif -// override #define in caml/compatibility.h -#undef flush - // define this if you want to disable all OS-dependent features, // such as sockets and OS-provided random number generators // #define NO_OS_DEPENDENCE diff --git a/src/utils/lib/bitv.ml b/src/utils/lib/bitv.ml index 78225879..2f82fda4 100644 --- a/src/utils/lib/bitv.ml +++ b/src/utils/lib/bitv.ml @@ -459,7 +459,7 @@ let to_string v = for i = 0 to n - 1 do if unsafe_get v i then s.[i] <- '1' done; - (Bytes.to_string s) + Bytes.unsafe_to_string s let print fmt v = Format.pp_print_string fmt (to_string v) diff --git a/src/utils/lib/magiclib.ml b/src/utils/lib/magiclib.ml index f07a221a..392b712f 100644 --- a/src/utils/lib/magiclib.ml +++ b/src/utils/lib/magiclib.ml @@ -69,13 +69,13 @@ let escape_colon s = let n = ref 0 in for i = 0 to len - 1 do if s.[i] = ':' then incr n done; if !n = 0 then s else - let s' = String.create (len + !n) in + let s' = Bytes.create (len + !n) in let j = ref 0 in for i = 0 to len - 1 do if s.[i] = ':' then (s'.[!j] <- '\\'; incr j); s'.[!j] <- s.[i]; incr j done; - Bytes.to_string s' + Bytes.unsafe_to_string s' (* Concatenate the filenames with ":". If ":" is present in a filename, escape it. *) diff --git a/src/utils/lib/md4.ml b/src/utils/lib/md4.ml index dc09d345..146af068 100644 --- a/src/utils/lib/md4.ml +++ b/src/utils/lib/md4.ml @@ -45,7 +45,7 @@ module Base16 = struct else Char.chr (Char.code '0' + x) let to_string hash_length s = - let p = String.create (hash_length * 2) in + let p = Bytes.create (hash_length * 2) in for i = 0 to hash_length - 1 do let c = s.[i] in let n = int_of_char c in @@ -54,7 +54,7 @@ module Base16 = struct p.[2 * i] <- hexa_digit i0; p.[2 * i+1] <- hexa_digit i1; done; - (Bytes.to_string p) + Bytes.unsafe_to_string p let hexa_digit_case upper x = if x >= 10 then Char.chr (Char.code ( @@ -62,7 +62,7 @@ module Base16 = struct else Char.chr (Char.code '0' + x) let to_string_case upper hash_length s = - let p = String.create (hash_length * 2) in + let p = Bytes.create (hash_length * 2) in for i = 0 to hash_length - 1 do let c = s.[i] in let n = int_of_char c in @@ -71,7 +71,7 @@ module Base16 = struct p.[2 * i] <- hexa_digit_case upper i0; p.[2 * i+1] <- hexa_digit_case upper i1; done; - (Bytes.to_string p) + Bytes.unsafe_to_string p let digit_hexa c = let i = int_of_char c in @@ -82,13 +82,13 @@ module Base16 = struct let of_string hash_length s = assert (String.length s = hash_length*2); - let p = String.create hash_length in + let p = Bytes.create hash_length in for i = 0 to hash_length - 1 do let c0 = s.[2*i] in let c1 = s.[2*i+1] in p.[i] <- char_of_int ((16 * digit_hexa c0) + digit_hexa c1); done; - (Bytes.to_string p) + Bytes.unsafe_to_string p end @@ -103,17 +103,17 @@ module Base32 = struct 'A' .. 'Z' -> int_of_char n - 65 | 'a' .. 'z' -> int_of_char n - 97 | _ -> (int_of_char n+26)-50 - + let of_string hash_length r = let len = String.length r in assert (len = (hash_length * 8 + 4)/5); - let s = String.create hash_length in + let s = Bytes.make hash_length '\000' in for i = 0 to len - 1 do let pos = i * 5 in let byte = pos / 8 in let bit = pos mod 8 in let c = int5_of_char r.[i] in - if bit < 3 then + if bit < 3 then let x = c lsl (3-bit) in s.[byte] <- char_of_int (int_of_char (Bytes.get s byte) lor x); else @@ -123,12 +123,12 @@ module Base32 = struct let y = (c lsl (11 - bit)) land 0xff in s.[byte+1] <- char_of_int (int_of_char (Bytes.get s (byte+1)) lor y); done; - (Bytes.to_string s) - + Bytes.unsafe_to_string s + let to_string hash_length s = assert (String.length s = hash_length); let len = (hash_length * 8 + 4)/5 in - let r = String.create len in + let r = Bytes.create len in for i = 0 to len - 1 do let pos = i * 5 in let byte = pos / 8 in @@ -145,16 +145,16 @@ module Base32 = struct let c = (x lsr (11 - bit)) land 0x1f in r.[i] <- char_of_int5 c done; - (Bytes.to_string r) + Bytes.unsafe_to_string r let char_of_int5 upper n = char_of_int (if n < 26 then (if upper then 65 else 97)+n else 50+(n-26)) - + let to_string_case upper hash_length s = assert (String.length s = hash_length); let len = (hash_length * 8 + 4)/5 in - let r = String.create len in + let r = Bytes.create len in for i = 0 to len - 1 do let pos = i * 5 in let byte = pos / 8 in @@ -171,7 +171,7 @@ module Base32 = struct let c = (x lsr (11 - bit)) land 0x1f in r.[i] <- char_of_int5 upper c done; - (Bytes.to_string r) + Bytes.unsafe_to_string r end @@ -181,7 +181,7 @@ module Base6427 = struct let _ = assert (String.length base64tbl = 64) let to_string _ hashbin = - let hash64 = String.create 30 in + let hash64 = Bytes.create 30 in let hashbin n = int_of_char hashbin.[n] in hash64.[0] <- '='; let j = ref 1 in @@ -198,19 +198,20 @@ module Base6427 = struct done done; hash64.[!j-1] <- '='; - String.sub (Bytes.to_string hash64) 0 !j + Bytes.sub_string hash64 0 !j - let base64tbl_inv = String.create 126 - let _ = + let base64tbl_inv = + let table = Bytes.create 126 in for i = 0 to 63 do - base64tbl_inv.[int_of_char base64tbl.[i]] <- char_of_int i - done + table.[int_of_char base64tbl.[i]] <- char_of_int i + done; + Bytes.unsafe_to_string table let of_string _ hash64 = - let hashbin = Bytes.create 20 in + let hashbin = Bytes.make 20 '\000' in let hash64 n = let c = hash64.[n] in - int_of_char (Bytes.get base64tbl_inv (int_of_char c)) + int_of_char base64tbl_inv.[int_of_char c] in let j = ref 0 in for i = 0 to 6 do @@ -233,7 +234,7 @@ module Base6427 = struct hashbin.[!j+1] <- char_of_int ((!tmp lsr 8) land 0xff); j := !j + 2; done; - (Bytes.to_string hashbin) + Bytes.unsafe_to_string hashbin let to_string_case _ = to_string end @@ -294,7 +295,7 @@ module Make(M: sig val unsafe_string : bytes -> string -> int -> unit (* [unsafe_file digest filename filesize] *) - val unsafe_file : bytes -> string -> int64 -> unit + val unsafe_file : bytes -> string -> int64 -> unit (* [unsafe_string digest file_fd offset len] *) val digest_subfile : bytes -> Unix.file_descr -> int64 -> int64 -> unit @@ -314,13 +315,13 @@ module Make(M: sig let string s = let len = String.length s in - let digest = Bytes.make hash_length '\000' in + let digest = Bytes.create hash_length in unsafe_string digest s len; - Bytes.to_string digest + Bytes.unsafe_to_string digest let to_bits s = let len = String.length s in - let digest = String.create (8*len) in + let digest = Bytes.create (8*len) in for i = 0 to len-1 do let c = int_of_char s.[i] in for j = 7 downto 0 do @@ -329,39 +330,39 @@ module Make(M: sig done done; - (Bytes.to_string digest) + Bytes.unsafe_to_string digest external xor_c : t -> t -> bytes -> unit = "md4_xor" "noalloc" let xor m1 m2 = - let m3 = Bytes.make hash_length '\000' in + let m3 = Bytes.create hash_length in xor_c m1 m2 m3; - Bytes.to_string m3 + Bytes.unsafe_to_string m3 let file s = - let digest = Bytes.make hash_length '\000' in + let digest = Bytes.create hash_length in let file_size = Unix32.getsize s in unsafe_file digest s file_size; - digest + Bytes.unsafe_to_string digest let digest_subfile fd pos len = - let digest = Bytes.make hash_length '\000' in + let digest = Bytes.create hash_length in Unix32.apply_on_chunk fd pos len (fun fd pos -> digest_subfile digest fd pos len); - Bytes.to_string digest + Bytes.unsafe_to_string digest - let create () = String.make hash_length '\000' + let create () = String.make hash_length '\x00' let direct_to_string s = s let direct_of_string s = s let random () = - let s = (Bytes.of_string (create ())) in + let s = Bytes.create hash_length in for i = 0 to hash_length - 1 do s.[i] <- char_of_int (Random.int 256) done; - (Bytes.to_string s) + Bytes.unsafe_to_string s let of_string = Base.of_string hash_length let to_string = Base.to_string hash_length diff --git a/src/utils/lib/misc.ml b/src/utils/lib/misc.ml index e6284243..6d2c64cb 100644 --- a/src/utils/lib/misc.ml +++ b/src/utils/lib/misc.ml @@ -92,7 +92,7 @@ let zip_create zipfile files = let gz_extract filename = let file = ref "" in try - let buffer = String.create 4096 in + let buffer = Bytes.create 4096 in let file_out = Filename2.temp_file "arch_" ".tmp" in file := file_out; Unix2.tryopen_read_gzip filename (fun ic -> diff --git a/src/utils/lib/verificationBitmap.ml b/src/utils/lib/verificationBitmap.ml index a8f5d25d..69515d5e 100644 --- a/src/utils/lib/verificationBitmap.ml +++ b/src/utils/lib/verificationBitmap.ml @@ -1,60 +1,60 @@ type t = bytes -type part_state = +type part_state = State_missing | State_partial | State_complete | State_verified - + let state_to_char = function | State_missing -> '0' | State_partial -> '1' | State_complete -> '2' | State_verified -> '3' -;; + let char_to_state = function | '0' -> State_missing | '1' -> State_partial | '2' -> State_complete - | '3' -> State_verified + | '3' -> State_verified | _ -> assert false let create n c = Bytes.make n (state_to_char c) -let get x i = (char_to_state (Bytes.get x i)) -let set (x : Bytes.t) i c = Bytes.set x i (state_to_char c) -let length = Bytes.length +let get x i = char_to_state (Bytes.get x i) +let set x i c = Bytes.set x i (state_to_char c) +let length = Bytes.length let init n f = let s = Bytes.create n in for i = 0 to n - 1 do - Bytes.set s i (state_to_char (f i)) + set s i (f i) done; s let to_string x = Bytes.to_string x let of_string x = Bytes.of_string x - -let iteri f x = + +let iteri f x = let l = Bytes.length x in let rec aux i = if i < l then begin - f i (char_to_state (Bytes.get x i)); + f i (get x i); aux (i+1) end in aux 0 - + let mapi f x = Array.init (length x) (fun i -> f i (get x i)) - + let fold_lefti f acc x = - let l = Bytes.length x in + let l = length x in let rec aux acc i = if i = l then acc else aux (f acc i (get x i)) (i + 1) in aux acc 0 - -let existsi p x = - let l = Bytes.length x in + +let existsi p x = + let l = length x in let rec aux i = - i < l && (p i (char_to_state (Bytes.get x i)) || aux (i+1)) in + i < l && (p i (get x i) || aux (i+1)) in aux 0 - + let for_all p s = - let l = Bytes.length s in + let l = length s in let rec aux i = - i >= l || p (char_to_state (Bytes.get s i)) && aux (i+1) in + i >= l || p (get s i) && aux (i+1) in aux 0 From 2655cb5d94dedf60945f24ed5459d3cdc1d06a2a Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 28 Jun 2024 18:29:43 +0200 Subject: [PATCH 66/69] Sync with upstream. --- src/daemon/common/commonComplexOptions.ml | 4 +- src/daemon/common/commonFile.ml | 8 +- src/daemon/common/commonFile.mli | 3 +- src/daemon/common/commonMultimedia.ml | 111 ++++++++++------------ src/daemon/common/commonSwarming.ml | 2 +- src/gtk2/gui/guiArt.ml | 2 +- src/networks/direct_connect/dcProtocol.ml | 29 ++---- src/networks/donkey/donkeyGlobals.ml | 2 +- src/networks/donkey/donkeyInteractive.ml | 6 +- src/networks/donkey/donkeyMftp.ml | 8 +- src/networks/donkey/donkeyOptions.ml | 5 +- src/networks/fasttrack/fst_crypt_ml.c | 2 +- src/utils/cdk/tar.mlcpp | 91 +++++++++--------- src/utils/cdk/tar.mli | 2 +- 14 files changed, 121 insertions(+), 154 deletions(-) diff --git a/src/daemon/common/commonComplexOptions.ml b/src/daemon/common/commonComplexOptions.ml index b5088d52..0986c3ce 100644 --- a/src/daemon/common/commonComplexOptions.ml +++ b/src/daemon/common/commonComplexOptions.ml @@ -1156,9 +1156,9 @@ let backup_tar archive files = t_devminor = 0; t_prefix = ""; t_gnu = None;} in - let s = String.create size in + let s = Bytes.create size in Pervasives.really_input ic s 0 size; - header, s) in + header, Bytes.unsafe_to_string s) in Tar.output otar header s with | e -> diff --git a/src/daemon/common/commonFile.ml b/src/daemon/common/commonFile.ml index 7887a1f6..46778767 100644 --- a/src/daemon/common/commonFile.ml +++ b/src/daemon/common/commonFile.ml @@ -1126,18 +1126,16 @@ let _ = (* *) (*************************************************************************) -let file_write_bytes file offset s pos len = +let file_write file offset s pos len = (* lprintf "DOWNLOADED: %d/%d/%d\n" pos len (String.length s); AnyEndian.dump_sub s pos len; *) if !!CommonOptions.buffer_writes then - Unix32.buffered_write_copy (file_fd file) offset (Bytes.unsafe_to_string s) pos len + Unix32.buffered_write_copy (file_fd file) offset s pos len else - Unix32.write_bytes (file_fd file) offset s pos len - -let file_write_string file offset s pos len = file_write_bytes file offset (Bytes.unsafe_of_string s) pos len + Unix32.write (file_fd file) offset s pos len let file_verify file key begin_pos end_pos = Unix32.flush_fd (file_fd file); diff --git a/src/daemon/common/commonFile.mli b/src/daemon/common/commonFile.mli index 40f4a8da..db8abe1c 100644 --- a/src/daemon/common/commonFile.mli +++ b/src/daemon/common/commonFile.mli @@ -134,8 +134,7 @@ val file_comment : CommonTypes.file -> string val file_magic : CommonTypes.file -> string option val check_magic : CommonTypes.file -> unit val recover_bytes : CommonTypes.file -> (int64 * int64) list -val file_write_bytes : CommonTypes.file -> int64 -> bytes -> int -> int -> unit -val file_write_string : CommonTypes.file -> int64 -> string -> int -> int -> unit +val file_write : CommonTypes.file -> int64 -> string -> int -> int -> unit val file_verify : CommonTypes.file -> CommonTypes.uid_type -> int64 -> int64 -> bool val file_mtime : CommonTypes.file -> float diff --git a/src/daemon/common/commonMultimedia.ml b/src/daemon/common/commonMultimedia.ml index 0fb48dc8..71dbd1c0 100644 --- a/src/daemon/common/commonMultimedia.ml +++ b/src/daemon/common/commonMultimedia.ml @@ -41,10 +41,7 @@ let input_int ic = let i1 = input_int16 ic in i0 lor (i1 lsl 16) -let input_string4 ic = - let s = String.create 4 in - really_input ic s 0 4; - s +let input_string4 ic = really_input_string ic 4 let print_string4 v s = lprintf "%s :" v; @@ -242,7 +239,7 @@ let rec page_seek ic s pos = (**********************************************************************************) let normalize_stream_type s ct = - let s = Bytes.sub_string s 0 6 in + let s = String.sub s 0 6 in if s = "vorbis" && ct = 0x1 then OGG_VORBIS_STREAM else if s = "theora" && ct = 0x80 @@ -278,12 +275,10 @@ let rec next_ogg_stream ic ogg_infos str stream_number = lprintf "Stream Serial Number: %0.f\n" stream_number; *) seek_in ic (pos+24); - let content_type = String.create 1 in - really_input ic content_type 0 1; - let content_type = int_of_char (Bytes.get content_type 0) in + let content_type = really_input_string ic 1 in + let content_type = int_of_char content_type.[0] in seek_in ic (pos+25); - let stream_type = String.create 8 in - really_input ic stream_type 0 8; + let stream_type = really_input_string ic 8 in let stream_type = normalize_stream_type stream_type content_type in incr stream_number; let pos = pos_in ic in @@ -299,19 +294,18 @@ let rec next_ogg_stream ic ogg_infos str stream_number = | OGG_THEORA_STREAM -> get_ogg_theora_info ic ogg_infos str stream_number and get_ogg_video_info ic ogg_infos str sizeof_packet stream_number = - let s = String.create sizeof_packet in - really_input ic s 0 sizeof_packet; - let codec = String.lowercase (Bytes.sub_string s 0 4) in - let time_unit = read64 (Bytes.sub_string s 8 8) in + let s = really_input_string ic sizeof_packet in + let codec = String.lowercase (String.sub s 0 4) in + let time_unit = read64 (String.sub s 8 8) in let video_width = if sizeof_packet >= sizeof_old_ogm_packet - then read32 (Bytes.sub_string s 36 4) - else read32 (Bytes.sub_string s 34 4) + then read32 (String.sub s 36 4) + else read32 (String.sub s 34 4) in let video_height = if sizeof_packet >= sizeof_old_ogm_packet - then read32 (Bytes.sub_string s 40 4) - else read32 (Bytes.sub_string s 38 4) + then read32 (String.sub s 40 4) + else read32 (String.sub s 38 4) in let sample_rate = 10000000. /. time_unit in ogg_infos := { @@ -326,24 +320,23 @@ and get_ogg_video_info ic ogg_infos str sizeof_packet stream_number = next_ogg_stream ic ogg_infos str stream_number and get_ogg_audio_info ic ogg_infos str sizeof_packet stream_number = - let s = String.create sizeof_packet in - really_input ic s 0 sizeof_packet; - let codec = get_audio_codec (Bytes.sub_string s 0 4) in - let sample_per_unit = read64 (Bytes.sub_string s 16 8) in + let s = really_input_string ic sizeof_packet in + let codec = get_audio_codec (String.sub s 0 4) in + let sample_per_unit = read64 (String.sub s 16 8) in let channels = if sizeof_packet >= sizeof_old_ogm_packet - then read16 (Bytes.sub_string s 36 2) - else read16 (Bytes.sub_string s 34 2) + then read16 (String.sub s 36 2) + else read16 (String.sub s 34 2) in let blockalign = if sizeof_packet >= sizeof_old_ogm_packet - then read16 (Bytes.sub_string s 38 2) - else read16 (Bytes.sub_string s 36 2) + then read16 (String.sub s 38 2) + else read16 (String.sub s 36 2) in let avgbytespersec = if sizeof_packet >= sizeof_old_ogm_packet - then read32 (Bytes.sub_string s 40 4) - else read32 (Bytes.sub_string s 38 4) + then read32 (String.sub s 40 4) + else read32 (String.sub s 38 4) in ogg_infos := { stream_no = !stream_number; @@ -359,16 +352,15 @@ and get_ogg_audio_info ic ogg_infos str sizeof_packet stream_number = and get_ogg_vorbis_info ic ogg_infos str stream_number = seek_in ic (pos_in ic - 2); (* ogm sets 8 octets in the common header as vorbis uses 6 octects for 'vorbis' *) - let s = String.create 22 in - really_input ic s 0 22; - let version = read32 (Bytes.sub_string s 0 4) in - let audio_channels = int_of_char (Bytes.get s 4) in - let sample_rate = read32 (Bytes.sub_string s 5 4) in - let br_max = read32 (Bytes.sub_string s 9 4) in - let br_nom = read32 (Bytes.sub_string s 13 4) in - let br_min = read32 (Bytes.sub_string s 17 4) in - let blocksize_1 = ((int_of_char (Bytes.get s 21)) asr 4) land 15 in - let blocksize_0 = (int_of_char (Bytes.get s 21)) land 15 in + let s = really_input_string ic 22 in + let version = read32 (String.sub s 0 4) in + let audio_channels = int_of_char s.[4] in + let sample_rate = read32 (String.sub s 5 4) in + let br_max = read32 (String.sub s 9 4) in + let br_nom = read32 (String.sub s 13 4) in + let br_min = read32 (String.sub s 17 4) in + let blocksize_1 = ((int_of_char s.[21]) asr 4) land 15 in + let blocksize_0 = (int_of_char s.[21]) land 15 in let l = ref [] in (if br_max > 0. then l := (Maximum_br br_max) :: !l); (if br_nom > 0. then l := (Nominal_br br_nom) :: !l); @@ -389,29 +381,28 @@ and get_ogg_vorbis_info ic ogg_infos str stream_number = and get_ogg_theora_info ic ogg_infos str stream_number = seek_in ic (pos_in ic - 2); (* ogm sets 8 octets in the common header as theora uses 6 octects for 'theora' *) - let s = String.create 34 in - really_input ic s 0 34; - let vmaj = int_of_char (Bytes.get s 0) in - let vmin = int_of_char (Bytes.get s 1) in - let vrev = int_of_char (Bytes.get s 2) in + let s = really_input_string ic 34 in + let vmaj = int_of_char s.[0] in + let vmin = int_of_char s.[1] in + let vrev = int_of_char s.[2] in let codec = Printf.sprintf "theora-%d.%d.%d" vmaj vmin vrev in (* multiply by 16 to get the actual frame width in pixels *) (* multiply by 16 to get the actual frame height in pixels *) - let picw = read24B (Bytes.sub_string s 7 3) in - let pich = read24B (Bytes.sub_string s 10 3) in - let frn = read32B (Bytes.sub_string s 15 4) in - let frd = read32B (Bytes.sub_string s 19 4) in + let picw = read24B (String.sub s 7 3) in + let pich = read24B (String.sub s 10 3) in + let frn = read32B (String.sub s 15 4) in + let frd = read32B (String.sub s 19 4) in let sample_rate = frn /. frd in - let parn = read24B (Bytes.sub_string s 23 3) in - let pard = read24B (Bytes.sub_string s 26 3) in + let parn = read24B (String.sub s 23 3) in + let pard = read24B (String.sub s 26 3) in let parn, pard = if parn = 0 then (1, 1) else (parn, pard) in - let cs = int_of_char (Bytes.get s 29) in - let nombr = read24B (Bytes.sub_string s 30 3) in - let qual = (int_of_char (Bytes.get s 33) asr 2) land 63 in + let cs = int_of_char s.[29] in + let nombr = read24B (String.sub s 30 3) in + let qual = (int_of_char s.[33] asr 2) land 63 in ogg_infos := { stream_no = !stream_number; stream_type = OGG_THEORA_STREAM; @@ -451,7 +442,7 @@ and get_ogg_index_info ic ogg_infos str stream_number = let search_info_ogg ic = let stream_number = ref 0 in - let str = String.create 4 in + let str = Bytes.create 4 in let ogg_infos = ref [] in (* make sure the current reading position is at the file beginning *) seek_in ic 0; @@ -474,7 +465,7 @@ let search_info_avi ic = try (* pos: 0 *) let s = input_string4 ic in - if not (Misc.bytes_equal_string s "RIFF") then failwith "Not an AVI file (RIFF absent)"; + if s <> "RIFF" then failwith "Not an AVI file (RIFF absent)"; (* pos: 4 *) let size = input_int32 ic in @@ -484,11 +475,11 @@ let search_info_avi ic = (* pos: 8 *) let s = input_string4 ic in - if not (Misc.bytes_equal_string s "AVI ") then failwith "Not an AVI file (AVI absent)"; + if s <> "AVI " then failwith "Not an AVI file (AVI absent)"; (* pos: 12 *) let s = input_string4 ic in - if not (Misc.bytes_equal_string s "LIST") then failwith "Not an AVI file (LIST absent)"; + if s <> "LIST" then failwith "Not an AVI file (LIST absent)"; (* position 16 *) let rec iter_list pos end_pos = @@ -508,12 +499,12 @@ let search_info_avi ic = (* lprint_string4 "header\n" header_name; *) (* pos: pos + 8 *) begin - match Bytes.to_string header_name with + match header_name with "hdrl" -> (* lprintf "HEADER\n"; *) let s = input_string4 ic in - if not (Misc.bytes_equal_string s "avih") then failwith "Bad AVI file (avih absent)"; + if s <> "avih" then failwith "Bad AVI file (avih absent)"; (* pos: pos + 12 *) let main_header_len = 52 in @@ -545,7 +536,7 @@ let search_info_avi ic = ignore (input_string4 ic); let fccType = input_string4 ic in - let fccHandler = Bytes.to_string (input_string4 ic) in + let fccHandler = input_string4 ic in let _dwFlags = input_int32 ic in (* Contains AVITF_* flags *) let _wPriority = input_int16 ic in let _wLanguage = input_int16 ic in @@ -562,7 +553,7 @@ let search_info_avi ic = let rcFrame_dx = input_int16 ic in let rcFrame_dy = input_int16 ic in - if Misc.bytes_equal_string fccType "vids" then + if fccType = "vids" then raise (FormatFound (AVI { avi_codec = fccHandler; avi_width = rcFrame_dx; diff --git a/src/daemon/common/commonSwarming.ml b/src/daemon/common/commonSwarming.ml index a74f046e..a81a51bf 100644 --- a/src/daemon/common/commonSwarming.ml +++ b/src/daemon/common/commonSwarming.ml @@ -2909,7 +2909,7 @@ let received up file_begin str string_begin string_len = (Printexc2.to_string e) r.range_begin file_end (file_best_name t.t_file)); - file_write_string tprim.t_file + file_write tprim.t_file r.range_begin str string_pos string_length; range_received (Some t) r r.range_begin file_end; diff --git a/src/gtk2/gui/guiArt.ml b/src/gtk2/gui/guiArt.ml index 4d3db8a5..0c03b516 100644 --- a/src/gtk2/gui/guiArt.ml +++ b/src/gtk2/gui/guiArt.ml @@ -241,7 +241,7 @@ open Zlib (* Return a pixbuf for a given svg data *) let pixb icon_name pixel_size = - let svg = Zlib2.uncompress_string icon_name in + let svg = uncompress_string icon_name in let z = float_of_int pixel_size /. 48. in let size_cb = (Rsvg.at_zoom z z) in let pb = Rsvg.render_from_string ~size_cb svg in diff --git a/src/networks/direct_connect/dcProtocol.ml b/src/networks/direct_connect/dcProtocol.ml index b77e6314..cc0ab678 100644 --- a/src/networks/direct_connect/dcProtocol.ml +++ b/src/networks/direct_connect/dcProtocol.ml @@ -584,12 +584,9 @@ module Search = struct let words = (* strip TTH: from TTH-search or return search words *) if filetype = 9 then (* TTH *) dc_replace_str_to_str words s_tth empty_string (* Strip TTH: *) - else begin (* normal search words *) - let s = ref (String.copy words) in - String2.replace_char !s '$' ' '; - String.lowercase !s - end - in + else + String.lowercase (String2.replace_char words '$' ' ') + in let words = dc_to_utf words in let size = (match has_size, size_kind with @@ -625,11 +622,7 @@ module Search = struct t.filetype (let words = if t.filetype = 9 then s_tth ^ t.words_or_tth (* if TTH search is wanted, send root hash *) - else begin - let s = ref (String.copy t.words_or_tth) in (* otherwise send search words *) - String2.replace_char !s char32 '$'; - !s - end + else String2.replace_char t.words_or_tth char32 '$'; (* otherwise send search words *) in utf_to_dc words); (*if !verbose_msg_clients then lprintf_nl "Sending: (%s)" (Buffer.contents buf)*) @@ -1132,12 +1125,11 @@ let dc_handler_server f sock nread = let pos = Bytes.index_from b.buf b.pos '|' in if pos < (b.pos + b.len) then begin let len = pos - b.pos in - let s = Bytes.sub b.buf b.pos len in + let s = Bytes.sub_string b.buf b.pos len in buf_used b (len+1); begin - let ss = Bytes.to_string s in - try f (dc_parse true ss) sock - with exn -> lprintf_nl "server handler %S : %s" ss (Printexc2.to_string exn) + try f (dc_parse true s) sock + with exn -> lprintf_nl "server handler %S : %s" s (Printexc2.to_string exn) end; iter b.len end @@ -1161,15 +1153,14 @@ let dc_handler_client c fm nm dm sock nread = (* fm = (read_first_message false) let pos = Bytes.index_from b.buf b.pos '|' in if pos < (b.pos + b.len) then begin let len = pos - b.pos in - let s = Bytes.sub b.buf b.pos len in - let ss = Bytes.to_string s in - let msg = dc_parse false ss in + let s = Bytes.sub_string b.buf b.pos len in + let msg = dc_parse false s in buf_used b (len+1); begin try (match !c with | None -> c := fm msg sock (* do this only once per new non-existing client eg. we are in ACTIVE mode *) | Some c -> nm c msg sock); (* after initial connection is established *) - with exn -> lprintf_nl "client handler %S : %s" ss (Printexc2.to_string exn) + with exn -> lprintf_nl "client handler %S : %s" s (Printexc2.to_string exn) end; iter b.len end ) diff --git a/src/networks/donkey/donkeyGlobals.ml b/src/networks/donkey/donkeyGlobals.ml index a67add12..420cf609 100644 --- a/src/networks/donkey/donkeyGlobals.ml +++ b/src/networks/donkey/donkeyGlobals.ml @@ -298,7 +298,7 @@ let md4_of_array md4s = Array.iteri (fun i v -> String.blit (Md4.direct_to_string v) 0 s (i*16) 16 ) md4s; - Md4.string (Bytes.to_string s) + Md4.string @@ Bytes.unsafe_to_string s (* compute the name used to save the file *) diff --git a/src/networks/donkey/donkeyInteractive.ml b/src/networks/donkey/donkeyInteractive.ml index f405aa0b..43a9b4d9 100644 --- a/src/networks/donkey/donkeyInteractive.ml +++ b/src/networks/donkey/donkeyInteractive.ml @@ -465,12 +465,10 @@ let import_config dirname = import_temp !temp_dir -let newline = Bytes.of_string "\n" let broadcast msg = - let s = Bytes.cat msg newline in - let len = Bytes.length s in + let s = msg ^ "\n" in List.iter (fun sock -> - TcpBufferedSocket.write sock s 0 len + TcpBufferedSocket.write_string sock s ) !user_socks (* diff --git a/src/networks/donkey/donkeyMftp.ml b/src/networks/donkey/donkeyMftp.ml index 6f9f2140..7ab1d364 100644 --- a/src/networks/donkey/donkeyMftp.ml +++ b/src/networks/donkey/donkeyMftp.ml @@ -122,13 +122,7 @@ let read_request ic = assert (c = 227); let len32 = read_uint64_32 ic in let len = Int64.to_int len32 in - let s = String.create len in - really_input ic s 0 len; - (* - lprintf "read_request %d [%s]" len (String.escaped s); -lprint_newline (); - *) - Bytes.to_string s + really_input_string ic len let output_request oc s = output_char oc (char_of_int 227); diff --git a/src/networks/donkey/donkeyOptions.ml b/src/networks/donkey/donkeyOptions.ml index 17a74580..b03644f5 100644 --- a/src/networks/donkey/donkeyOptions.ml +++ b/src/networks/donkey/donkeyOptions.ml @@ -132,10 +132,11 @@ let keep_sources = define_expert_option donkey_section ["keep_sources"] open Md4 let mldonkey_md4 md4 = - let md4 = (Bytes.of_string (Md4.direct_to_string md4)) in + (* not sure if mutation in-place is necessary, keeping behaviour as it was *) + let md4 = Bytes.unsafe_of_string @@ Md4.direct_to_string md4 in md4.[5] <- Char.chr 14; md4.[14] <- Char.chr 111; - Md4.direct_of_string (Bytes.to_string md4) + Md4.direct_of_string @@ Bytes.unsafe_to_string md4 let client_md4 = define_option donkey_section ["client_md4"] "The MD4 of this client" diff --git a/src/networks/fasttrack/fst_crypt_ml.c b/src/networks/fasttrack/fst_crypt_ml.c index c55772fb..5519803f 100755 --- a/src/networks/fasttrack/fst_crypt_ml.c +++ b/src/networks/fasttrack/fst_crypt_ml.c @@ -158,7 +158,7 @@ value ml_cipher_packet_set_xored(value cipher_v, value s_v, value pos_v, value x { FSTCipher* cipher = (FSTCipher*) cipher_v; FSTCipher* xor_cipher = (FSTCipher*) xor_cipher_v; - const char *s = String_val(s_v); + char *s = Bytes_val(s_v); int pos = Int_val(pos_v); unsigned int seed = cipher->seed; diff --git a/src/utils/cdk/tar.mlcpp b/src/utils/cdk/tar.mlcpp index 9987ac97..193a5486 100644 --- a/src/utils/cdk/tar.mlcpp +++ b/src/utils/cdk/tar.mlcpp @@ -146,9 +146,6 @@ let extract_int32 raw pos len = Int32.of_string ("0o" ^ trim_spaces raw pos len) with Failure x -> raise (Error "Invalid number in header") -let extract_int32_bytes raw pos len = - extract_int32 (Bytes.unsafe_to_string raw) pos len - let typeflag = function | '0' | '\000' -> REGULAR | '1' -> LINK @@ -181,15 +178,14 @@ let align_at_header t = t.last_header <- None let empty_block = String.make blocksize '\000' -let empty_bytes = Bytes.create blocksize let compute_chksum buf = let chksum = ref 256 in (* 256 is the sum of 8 ' ' characters for the chksum field *) for i = 0 to 147 do - chksum := !chksum + Char.code (Bytes.get buf i) + chksum := !chksum + Char.code buf.[i] done; for i = 156 to 511 do - chksum := !chksum + Char.code (Bytes.get buf i) + chksum := !chksum + Char.code buf.[i] done; !chksum @@ -209,36 +205,38 @@ let read_oldgnu_header header = t_realsize = extract_int32 header 483 12; } +let really_input_string t size = + let buf = Bytes.create size in + t.chan#really_input buf 0 size; + Bytes.unsafe_to_string buf + let read_gnu_header t = - let buf = String.create blocksize in - t.chan#really_input buf 0 blocksize; - { t_atime = extract_int32_bytes buf 0 12; - t_ctime = extract_int32_bytes buf 12 12; - t_offset = extract_int32_bytes buf 24 12; - t_realsize = extract_int32_bytes buf 36 12; + let buf = really_input_string t blocksize in + { t_atime = extract_int32 buf 0 12; + t_ctime = extract_int32 buf 12 12; + t_offset = extract_int32 buf 24 12; + t_realsize = extract_int32 buf 36 12; } let read_header t = - align_at_header t; - let buf = String.create blocksize in - t.chan#really_input buf 0 blocksize; - if buf = empty_bytes then raise End_of_file; - let sbuf = Bytes.to_string buf in - let head1 = { t_name = c_string sbuf 0; - t_mode = extract_num sbuf 100 8; - t_uid = extract_num sbuf 108 8; - t_gid = extract_num sbuf 116 8; - t_size = extract_num sbuf 124 12; - t_mtime = extract_int32 sbuf 136 12; - t_chksum = extract_num sbuf 148 8; - t_typeflag = typeflag sbuf.[156]; - t_linkname = c_string sbuf 157; - t_format = read_magic sbuf sbuf.[156]; - t_uname = c_string sbuf 265; - t_gname = c_string sbuf 297; - t_devmajor = extract_num sbuf 329 8; - t_devminor = extract_num sbuf 337 8; - t_prefix = String.sub sbuf 345 155; + align_at_header t; + let buf = really_input_string t blocksize in + if buf = empty_block then raise End_of_file; + let head1 = { t_name = c_string buf 0; + t_mode = extract_num buf 100 8; + t_uid = extract_num buf 108 8; + t_gid = extract_num buf 116 8; + t_size = extract_num buf 124 12; + t_mtime = extract_int32 buf 136 12; + t_chksum = extract_num buf 148 8; + t_typeflag = typeflag buf.[156]; + t_linkname = c_string buf 157; + t_format = read_magic buf buf.[156]; + t_uname = c_string buf 265; + t_gname = c_string buf 297; + t_devmajor = extract_num buf 329 8; + t_devminor = extract_num buf 337 8; + t_prefix = String.sub buf 345 155; t_gnu = None; } in let chksum = compute_chksum buf in @@ -246,7 +244,7 @@ let read_header t = raise (Error (Printf.sprintf "Invalid checksum in tar header. Calculated %d, expected %d" chksum head1.t_chksum)); let head = if head1.t_format = OLDGNU_FORMAT then - {head1 with t_gnu = Some (read_oldgnu_header sbuf) } + {head1 with t_gnu = Some (read_oldgnu_header buf) } else if head1.t_format = GNU_FORMAT then {head1 with t_gnu = Some (read_gnu_header t) } else @@ -269,14 +267,11 @@ let read_body t = let header = get_header t in t.last_header <- None; if header.t_size = 0 then "" - else let buf = String.create header.t_size in - t.chan#really_input buf 0 header.t_size; + else + let buf = really_input_string t header.t_size in let align = blocksize - (header.t_size mod blocksize) in - if align <> blocksize then begin - let leftover = String.create blocksize in - t.chan#really_input leftover 0 align - end; - (Bytes.to_string buf) + if align <> blocksize then ignore (really_input_string t align : string); + buf let read_entry t = let head = read_header t in @@ -394,8 +389,8 @@ let write_gnu_header t buf = write_int32 buf 36 ext.t_realsize let output t head body = - let size = Bytes.length body in - let buf = Bytes.copy empty_bytes in + let size = String.length body in + let buf = Bytes.of_string empty_block in write_str buf 0 100 head.t_name; write_num8 buf 100 head.t_mode; write_num8 buf 108 head.t_uid; @@ -412,23 +407,23 @@ let output t head body = write_str buf 345 155 head.t_prefix; if head.t_format = OLDGNU_FORMAT then write_oldgnu_header head buf; - let chksum = compute_chksum buf in + let chksum = compute_chksum @@ Bytes.unsafe_to_string buf in write_padded_num buf 148 chksum; t.ochan#output buf 0 blocksize; - if head.t_format = GNU_FORMAT && isdigit (Bytes.get buf 156) then begin - let buf2 = Bytes.copy empty_bytes in + if head.t_format = GNU_FORMAT && isdigit @@ Bytes.get buf 156 then begin + let buf2 = Bytes.of_string empty_block in write_gnu_header head buf2; t.ochan#output buf2 0 blocksize end; if size > 0 then begin - t.ochan#output body 0 size; + t.ochan#output (Bytes.unsafe_of_string body) 0 size; let align = blocksize - (size mod blocksize) in if align > 0 && align < blocksize then - t.ochan#output empty_bytes 0 align + t.ochan#output (Bytes.unsafe_of_string empty_block) 0 align end let flush t = - t.ochan#output empty_bytes 0 blocksize; + t.ochan#output (Bytes.unsafe_of_string empty_block) 0 blocksize; t.ochan#flush () let close_out t = diff --git a/src/utils/cdk/tar.mli b/src/utils/cdk/tar.mli index 1c1d3f4e..0d4e2a13 100644 --- a/src/utils/cdk/tar.mli +++ b/src/utils/cdk/tar.mli @@ -95,7 +95,7 @@ val open_out_chan: ?compress:[<`Plain|`Gzip|`Bzip2>`Plain] -> out_channel -> t_o body. [header.t_size] is set based on the length of the string that's used as the file. [header.t_chksum] is also filled in automatically. *) -val output: t_out -> header -> bytes -> unit +val output: t_out -> header -> string -> unit (** Flush out the tar archive but don't close the underlying [out_channel] *) From 0168c2987a5ae98abb85393478b574f4e2bba65c Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 28 Jun 2024 18:44:19 +0200 Subject: [PATCH 67/69] Sync with upstream. --- src/networks/bittorrent/bTClients.ml | 2 +- src/networks/direct_connect/dcInteractive.ml | 68 +++++++++----------- 2 files changed, 31 insertions(+), 39 deletions(-) diff --git a/src/networks/bittorrent/bTClients.ml b/src/networks/bittorrent/bTClients.ml index c3ef05bb..f509ef87 100644 --- a/src/networks/bittorrent/bTClients.ml +++ b/src/networks/bittorrent/bTClients.ml @@ -1385,7 +1385,7 @@ and client_to_client c sock msg = (* regexp ee is a fugly way to find the end of the 1st dict before the real payload *) let metaindex = (2 + (Str.search_forward (Str.regexp_string "ee") chunk 0 )) in let chunklength = ((String.length chunk) - metaindex) in - Unix32.write fd !fileindex (Bytes.unsafe_of_string chunk) + Unix32.write fd !fileindex chunk metaindex chunklength; fileindex := Int64.add !fileindex (Int64.of_int chunklength); diff --git a/src/networks/direct_connect/dcInteractive.ml b/src/networks/direct_connect/dcInteractive.ml index ce31df29..e0b98487 100644 --- a/src/networks/direct_connect/dcInteractive.ml +++ b/src/networks/direct_connect/dcInteractive.ml @@ -403,13 +403,28 @@ let html_show_shared dcsh = let html_show_file file = html_show_tth file.file_name file.file_file.impl_file_size file.file_unchecked_tiger_root +(* TODO better *) +let translate' s = + let s = String2.replace_char s char32 char42 in (* to * *) + let s = String2.replace_char s char39 char58 in (* ' to : *) + let s = String2.replace_char s char38 char60 in (* & to < *) + s + +let translate s = + String2.replace_char (translate' s) char43 char62 (* + to > *) + +let untranslate' s = + let s = String2.replace_char s char42 char32 in (* * to *) + let s = String2.replace_char s char58 char39 in (* : to ' *) + let s = String2.replace_char s char60 char38 in (* < to & *) + s + +let untranslate s = + String2.replace_char (untranslate' s) char62 char43 (* > to + *) + (* print in html or txt list of files *) let file_print file num o = let buf = o.conn_buf in - let fname = ref (String.copy file.file_name) in - String2.replace_char !fname char32 char42; (* to * *) - String2.replace_char !fname char39 char58; (* ' to : *) - String2.replace_char !fname char60 char38; (* & to < *) if use_html_mods o then begin Printf.bprintf buf " \\ @@ -424,7 +439,7 @@ let file_print file num o = (html_mods_cntr ()) num file.file_name file.file_file.impl_file_size (html_show_file file) (List.length file.file_clients) file.file_autosearch_count (td_command "Find TTH" "Find new client for this file by TTH" ["dcfindsource"; file.file_unchecked_tiger_root]) - (td_command "Find similar" "Find new client for this file by similar name" ["dcfindsource"; !fname]) + (td_command "Find similar" "Find new client for this file by similar name" ["dcfindsource"; translate' file.file_name]) end else Printf.bprintf buf "[%5d] %40s %-15Ld %5d\n" num file.file_name file.file_file.impl_file_size (List.length file.file_clients) @@ -545,16 +560,6 @@ let filelist_file_print is_file spaces username dir fname fsize ftth line o = fsize = filesize from mylist ftth = tth from mylist *) let buf = o.conn_buf in - let sdir = ref (String.copy dir) in - let sname = ref (String.copy fname) in - String2.replace_char !sdir char32 char42; (* to * *) - String2.replace_char !sdir char39 char58; (* ' to : *) - String2.replace_char !sdir char38 char60; (* & to < *) - String2.replace_char !sdir char43 char62; (* + to > *) - String2.replace_char !sname char32 char42; - String2.replace_char !sname char39 char58; - String2.replace_char !sname char38 char60; - String2.replace_char !sname char43 char62; if use_html_mods o then begin Printf.bprintf buf " \\ @@ -566,7 +571,7 @@ let filelist_file_print is_file spaces username dir fname fsize ftth line o = line (if is_file then td_command (spaces^fname) "Start downloading" ~target:`Status - ["dcloadfile"; username; ftth; !sdir; !sname; fsize] + ["dcloadfile"; username; ftth; translate dir; translate fname; fsize] else Printf.sprintf "\\\\%s%s\\\\" spaces fname ) @@ -1002,21 +1007,11 @@ msgWindow.location.reload(); (match args with | [uname ; tth ; dir ; fname ; fsize] -> (* convert filenames back to normal *) if !verbose_download then lprintf_nl "dcloadfile: (%s) (%s) (%s)" dir fname tth; - let sdir = ref (String.copy dir) in - let sname = ref (String.copy fname) in - String2.replace_char !sdir char42 char32; (* * to *) - String2.replace_char !sdir char58 char39; (* : to ' *) - String2.replace_char !sdir char60 char38; (* < to & *) - String2.replace_char !sdir char62 char43; (* > to + *) - String2.replace_char !sname char42 char32; - String2.replace_char !sname char58 char39; - String2.replace_char !sname char60 char38; - String2.replace_char !sname char62 char43; - Printf.bprintf buf "Trying to download file: %s from user: %s\n" !sname uname; + Printf.bprintf buf "Trying to download file: %s from user: %s\n" fname uname; (try let u = search_user_by_name uname in let user = o.conn_user.ui_user in - let (_ : _ option) = start_new_download (Some u) tth !sdir !sname (Int64.of_string fsize) user user.user_default_group in + let (_ : _ option) = start_new_download (Some u) tth (untranslate dir) (untranslate fname) (Int64.of_string fsize) user user.user_default_group in () with _ -> if !verbose_download then lprintf_nl "dcloadfile: No user found" ) | _ -> @@ -1078,12 +1073,9 @@ msgWindow.location.reload(); (match args with | tth_or_filename -> (*lprintf_nl "Got dcfindsource command: (%s)" tth_or_filename;*) - let tth_or_filename = ref (String.copy tth_or_filename) in - String2.replace_char !tth_or_filename char42 char32; - String2.replace_char !tth_or_filename char58 char39; - String2.replace_char !tth_or_filename char38 char60; - if (is_valid_tiger_hash !tth_or_filename) then begin - let query = QAnd (QHasField (Field_Type , "TTH") , (QHasWord !tth_or_filename)) in + let tth_or_filename = untranslate' tth_or_filename in + if (is_valid_tiger_hash tth_or_filename) then begin + let query = QAnd (QHasField (Field_Type , "TTH") , (QHasWord tth_or_filename)) in let search = CommonSearch.new_search o.conn_user (let module G = GuiTypes in { G.search_num = 0; @@ -1093,10 +1085,10 @@ msgWindow.location.reload(); G.search_network = network.network_num; } ) in - dc_with_connected_servers (fun s -> DcClients.server_send_search s search 9 !tth_or_filename); + dc_with_connected_servers (fun s -> DcClients.server_send_search s search 9 tth_or_filename); dc_last_manual_search := current_time (); end else begin - let fname = Filename.basename !tth_or_filename in + let fname = Filename.basename tth_or_filename in let words = clean_string fname in let words_list = String2.split_simplify words ' ' in let rec add_query list = @@ -1115,7 +1107,7 @@ msgWindow.location.reload(); G.search_network = network.network_num; } ) in - dc_with_connected_servers (fun s -> DcClients.server_send_search s search 1 !tth_or_filename); + dc_with_connected_servers (fun s -> DcClients.server_send_search s search 1 tth_or_filename); dc_last_manual_search := current_time (); end ); empty_string @@ -1203,8 +1195,8 @@ msgWindow.location.reload(); let s = file_to_che3_to_string (Filename.concat filelist_directory filename) in if not (Charset.is_utf8 s) then lprintf_nl "not utf8 : %S" s; let s = Charset.Locale.to_utf8 s in (* really needed? *) + let s = String2.replace_char s char13 '\n' in (try - String2.replace_char s char13 '\n'; let lines = String2.split_simplify s '\n' in let mlist = ref ([] : dc_mylistnode list) in (* root node of the MyList *) let tablist = ref [(-1, mlist)] in (* list of previous open directory node for every tab *) From be7ea25aba11d45c5dba2542edaa028f24f542b2 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 28 Jun 2024 18:48:45 +0200 Subject: [PATCH 68/69] Fix typo. --- src/networks/fasttrack/fasttrackPandora.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/networks/fasttrack/fasttrackPandora.ml b/src/networks/fasttrack/fasttrackPandora.ml index cc4122cb..0f01f5cd 100644 --- a/src/networks/fasttrack/fasttrackPandora.ml +++ b/src/networks/fasttrack/fasttrackPandora.ml @@ -323,7 +323,7 @@ let find_header s pos = String.sub s pos (pos2 - pos) let hescaped s = - String2.replace_char s '\r' ' ';s + String2.replace_char s '\r' ' '; let is_http_stream s = String2.starts_with s "GET" || From 687e04bc7d63b12899840d70cc6f2bf5bbf66863 Mon Sep 17 00:00:00 2001 From: Luca Carlon Date: Fri, 28 Jun 2024 23:00:49 +0200 Subject: [PATCH 69/69] Fix build. --- src/networks/fasttrack/fasttrackPandora.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/networks/fasttrack/fasttrackPandora.ml b/src/networks/fasttrack/fasttrackPandora.ml index 0f01f5cd..d2ebe401 100644 --- a/src/networks/fasttrack/fasttrackPandora.ml +++ b/src/networks/fasttrack/fasttrackPandora.ml @@ -89,7 +89,7 @@ X-KazaaTag: 6=Christina Aguliera(13) X-KazaaTag: 8=Stripped(13) X-KazaaTag: 14=Other(13) X-KazaaTag: 1=2002(13) -X-KazaaTag: 26=� christinas_eyedol 2002(13) +X-KazaaTag: 26=© christinas_eyedol 2002(13) X-KazaaTag: 12=album version, stripped, fighter, real, christina, aguilera(13) X-KazaaTag: 10=en(13) X-KazaaTag: 18=Video Clip(13) @@ -322,8 +322,10 @@ let find_header s pos = let pos2 = iter s pos in String.sub s pos (pos2 - pos) +(* let hescaped s = - String2.replace_char s '\r' ' '; + String2.replace_char s '\r' ' ';s +*) let is_http_stream s = String2.starts_with s "GET" ||