[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Mldonkey-commits] mldonkey config/Makefile.in config/configure.in...
|
From: |
mldonkey-commits |
|
Subject: |
[Mldonkey-commits] mldonkey config/Makefile.in config/configure.in... |
|
Date: |
Sun, 29 Aug 2010 20:17:57 +0000 |
CVSROOT: /sources/mldonkey
Module name: mldonkey
Changes by: spiralvoice <spiralvoice> 10/08/29 20:17:57
Modified files:
config : Makefile.in configure.in
distrib : ChangeLog
src/networks/bittorrent: bTClients.ml bTComplexOptions.ml
bTGlobals.ml bTInteractive.ml
bTTorrent.ml bTTypes.ml
src/utils/lib : options.ml4
src/utils/net : basicSocket.ml ip.ml udpSocket.ml
Added files:
src/networks/bittorrent: bTUdpTracker.mlp
src/utils/bitstring: bitstring.ml.in bitstring.mli bitstring_c.c
bitstring_persistent.mlc4
bitstring_persistent.mli byteswap.h
pa_bitstring.mlt
Log message:
patch 7144
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/mldonkey/config/Makefile.in?cvsroot=mldonkey&r1=1.189&r2=1.190
http://cvs.savannah.gnu.org/viewcvs/mldonkey/config/configure.in?cvsroot=mldonkey&r1=1.337&r2=1.338
http://cvs.savannah.gnu.org/viewcvs/mldonkey/distrib/ChangeLog?cvsroot=mldonkey&r1=1.1466&r2=1.1467
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTClients.ml?cvsroot=mldonkey&r1=1.105&r2=1.106
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTComplexOptions.ml?cvsroot=mldonkey&r1=1.43&r2=1.44
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTGlobals.ml?cvsroot=mldonkey&r1=1.86&r2=1.87
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTInteractive.ml?cvsroot=mldonkey&r1=1.160&r2=1.161
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTTorrent.ml?cvsroot=mldonkey&r1=1.22&r2=1.23
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTTypes.ml?cvsroot=mldonkey&r1=1.47&r2=1.48
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTUdpTracker.mlp?cvsroot=mldonkey&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/bitstring/bitstring.ml.in?cvsroot=mldonkey&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/bitstring/bitstring.mli?cvsroot=mldonkey&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/bitstring/bitstring_c.c?cvsroot=mldonkey&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/bitstring/bitstring_persistent.mlc4?cvsroot=mldonkey&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/bitstring/bitstring_persistent.mli?cvsroot=mldonkey&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/bitstring/byteswap.h?cvsroot=mldonkey&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/bitstring/pa_bitstring.mlt?cvsroot=mldonkey&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/lib/options.ml4?cvsroot=mldonkey&r1=1.30&r2=1.31
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/net/basicSocket.ml?cvsroot=mldonkey&r1=1.34&r2=1.35
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/net/ip.ml?cvsroot=mldonkey&r1=1.29&r2=1.30
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/net/udpSocket.ml?cvsroot=mldonkey&r1=1.23&r2=1.24
Patches:
Index: config/Makefile.in
===================================================================
RCS file: /sources/mldonkey/mldonkey/config/Makefile.in,v
retrieving revision 1.189
retrieving revision 1.190
diff -u -b -r1.189 -r1.190
--- config/Makefile.in 29 Aug 2010 20:11:20 -0000 1.189
+++ config/Makefile.in 29 Aug 2010 20:17:56 -0000 1.190
@@ -68,6 +68,7 @@
CDK=src/utils/cdk
+BITSTRING=src/utils/bitstring
LIB=src/utils/lib
NET=src/utils/net
RSS=src/utils/ocamlrss
@@ -88,7 +89,7 @@
SRC_DIRECTCONNECT=src/networks/direct_connect
SRC_FILETP=src/networks/fileTP
-SUBDIRS=$(CDK) $(LIB) $(RSS) $(XML) $(NET) tools \
+SUBDIRS=$(CDK) $(BITSTRING) $(LIB) $(RSS) $(XML) $(NET) tools \
$(COMMON) $(DRIVER) $(MP3) src/config/$(OS_FILES)
INCLUDES += $(foreach file, $(SUBDIRS), -I $(file)) -I +camlp4
@@ -132,6 +133,16 @@
LIBS_flags += -cclib "resfile.o"
endif
+BITSTRING_SRCS = \
+ $(BITSTRING)/bitstring.ml \
+ $(BITSTRING)/bitstring_persistent.mlc4 \
+ $(BITSTRING)/bitstring_c.c
+
+BITSTRING_LIBS_flags = -I +camlp4
+BITSTRING_LIBS_opt = $(CAMLP4LIB_OPT)
+BITSTRING_STATIC_LIBS_opt = $(BITSTRING_LIBS_opt)
+BITSTRING_LIBS_byte = $(CAMLP4LIB_BYTE)
+
ifeq ("$(BZIP2)", "yes")
LIBS_flags += -cclib -lbz2
CDK_SRCS += $(CDK)/bzlib.ml $(CDK)/bzip2.ml
@@ -425,11 +436,19 @@
$(SRC_FASTTRACK)/fasttrackInteractive.mlt \
$(SRC_FASTTRACK)/fasttrackMain.mlt
+$(BITSTRING)/pa_bitstring.cmo: $(BITSTRING)/pa_bitstring.mlt
build/bitstring.cma
+ $(OCAMLC) build/bitstring.cma -I $(BITSTRING) -I +camlp4 camlp4lib.cma
-pp '$(CAMLP4OF) -impl' -c $<
+
+$(SRC_BITTORRENT)/bTUdpTracker.ml: $(SRC_BITTORRENT)/bTUdpTracker.mlp
$(BITSTRING)/pa_bitstring.cmo
+ $(CAMLP4OF) build/bitstring.cma $(BITSTRING)/pa_bitstring.cmo -impl $<
-o $@
+
BITTORRENT_SRCS= \
+ $(BITSTRING_SRCS) \
$(SRC_BITTORRENT)/bencode.ml \
$(SRC_BITTORRENT)/bTRate.ml \
$(SRC_BITTORRENT)/bTTypes.ml \
$(SRC_BITTORRENT)/bTOptions.ml \
+ $(SRC_BITTORRENT)/bTUdpTracker.ml \
$(SRC_BITTORRENT)/bTProtocol.ml \
$(SRC_BITTORRENT)/bTTorrent.ml \
$(SRC_BITTORRENT)/bTGlobals.ml \
@@ -1101,16 +1120,17 @@
$1_MLL := $(filter %.mll, $($1_SRCS))
$1_MLY := $(filter %.mly, $($1_SRCS))
$1_ML4 := $(filter %.ml4, $($1_SRCS))
+$1_MLC4 := $(filter %.mlc4, $($1_SRCS))
$1_MLT := $(filter %.mlt, $($1_SRCS))
$1_MLP := $(filter %.mlcpp, $($1_SRCS))
-$1_ML := $(filter %.ml %.mll %.zog %.mly %.ml4 %.mlt %.mlcpp, $($1_SRCS))
-$1_DOC := $(filter %.ml %.mll %.zog %.mly %.ml4 %.mlcpp, $($1_SRCS))
+$1_ML := $(filter %.ml %.mll %.zog %.mly %.ml4 %.mlc4 %.mlt %.mlcpp,
$($1_SRCS))
+$1_DOC := $(filter %.ml %.mll %.zog %.mly %.ml4 %.mlc4 %.mlcpp, $($1_SRCS))
$1_C := $(filter %.c %.cc, $($1_SRCS))
$1_CMOS=$(foreach file, $($1_ML), $(basename $(file)).cmo)
$1_CMXS=$(foreach file, $($1_ML), $(basename $(file)).cmx)
$1_OBJS=$(foreach file, $($1_C), $(basename $(file)).o)
-TMPSOURCES += $($1_ML4:.ml4=.ml) $($1_MLT:.mlt=.ml) $($1_MLP:.mlcpp=.ml)
$($1_MLL:.mll=.ml) $($1_MLY:.mly=.ml) $($1_MLY:.mly=.mli) $($1_ZOG:.zog=.ml)
+TMPSOURCES += $($1_ML4:.ml4=.ml) $($1_MLC4:.mlc4=.ml) $($1_MLT:.mlt=.ml)
$($1_MLP:.mlcpp=.ml) $($1_MLL:.mll=.ml) $($1_MLY:.mly=.ml) $($1_MLY:.mly=.mli)
$($1_ZOG:.zog=.ml)
ZOGSOURCES += $($1_ZOG:.zog=.ml)
MLTSOURCES += $($1_MLT:.mlt=.ml)
@@ -1170,6 +1190,7 @@
libcdk_SRCS= $(CDK_SRCS) $(LIB_SRCS) $(NET_SRCS) $(MP3TAG_SRCS)
libmagic_SRCS= $(MAGIC_SRCS)
+libbitstring_SRCS= $(BITSTRING_SRCS)
libcommon_SRCS= $(COMMON_SRCS)
libclient_SRCS= $(COMMON_CLIENT_SRCS)
ifeq ("$(GUI)", "newgui2")
@@ -1185,6 +1206,7 @@
EXPAND_LIB(libicons,icons)
EXPAND_LIB(libcdk,cdk)
EXPAND_LIB(libmagic,magic)
+EXPAND_LIB(libbitstring,bitstring)
EXPAND_LIB(libcommon,common)
EXPAND_LIB(libclient,client)
EXPAND_LIB(DRIVER,driver)
@@ -1209,9 +1231,10 @@
$1_MLL := $(filter %.mll, $($1_SRCS))
$1_MLY := $(filter %.mly, $($1_SRCS))
$1_ML4 := $(filter %.ml4, $($1_SRCS))
+$1_MLC4 := $(filter %.mlc4, $($1_SRCS))
$1_MLT := $(filter %.mlt, $($1_SRCS))
$1_MLP := $(filter %.mlcpp, $($1_SRCS))
-$1_ML := $(filter %.ml %.mll %.zog %.mly %.ml4 %.mlt %.mlcpp, $($1_SRCS))
+$1_ML := $(filter %.ml %.mll %.zog %.mly %.ml4 %.mlc4 %.mlt %.mlcpp,
$($1_SRCS))
$1_C := $(filter %.c %.cc, $($1_SRCS))
$1_CMOS=$(foreach file, $($1_ML), $(basename $(file)).cmo)
$1_CMXS=$(foreach file, $($1_ML), $(basename $(file)).cmx)
@@ -1220,7 +1243,7 @@
$1_CMXAS := $(foreach file, $($1_CMXA), build/$(basename $(file)).cmxa)
$1_CMAS=$(foreach file, $($1_CMXA), build/$(basename $(file)).cma)
-TMPSOURCES += $($1_ML4:.ml4=.ml) $($1_MLT:.mlt=.ml) $($1_MLP:.mlcpp=.ml)
$($1_MLL:.mll=.ml) $($1_MLY:.mly=.ml) $($1_MLY:.mly=.mli) $($1_ZOG:.zog=.ml)
+TMPSOURCES += $($1_ML4:.ml4=.ml) $($1_MLC4:.mlc4=.ml) $($1_MLT:.mlt=.ml)
$($1_MLP:.mlcpp=.ml) $($1_MLL:.mll=.ml) $($1_MLY:.mly=.ml) $($1_MLY:.mly=.mli)
$($1_ZOG:.zog=.ml)
$2: $($1_OBJS) $($1_CMXS) $($1_CMXAS)
$(OCAMLOPT) -linkall -o address@hidden \
@@ -1229,6 +1252,7 @@
$($5_LIBS_opt) $($5_LIBS_flags) \
$($6_LIBS_opt) $($6_LIBS_flags) \
$($7_LIBS_opt) $($7_LIBS_flags) \
+ $($8_LIBS_opt) $($8_LIBS_flags) \
-I build $($1_CMXAS) $($1_CMXS)
$2.byte: $($1_OBJS) $($1_CMOS) $($1_CMAS)
@@ -1238,6 +1262,7 @@
$($5_LIBS_byte) $($5_LIBS_flags) \
$($6_LIBS_byte) $($6_LIBS_flags) \
$($7_LIBS_byte) $($7_LIBS_flags) \
+ $($8_LIBS_byte) $($8_LIBS_flags) \
-I build $($1_CMAS) $($1_CMOS)
$2.static: $($1_OBJS) $($1_CMXS) $($1_CMXAS)
@@ -1247,6 +1272,7 @@
$($5_LIBS_flags) $($5_STATIC_LIBS_opt) \
$($6_LIBS_flags) $($6_STATIC_LIBS_opt) \
$($7_LIBS_flags) $($7_STATIC_LIBS_opt) \
+ $($8_LIBS_flags) $($8_STATIC_LIBS_opt) \
-I build $($1_CMXAS) $($1_CMXS)
$2.byte.static: $($1_OBJS) $($1_CMOS) $($1_CMAS)
@@ -1256,6 +1282,7 @@
$($5_LIBS_flags) $($5_STATIC_LIBS_opt) \
$($6_LIBS_flags) $($6_STATIC_LIBS_opt) \
$($7_LIBS_flags) $($7_STATIC_LIBS_opt) \
+ $($8_LIBS_flags) $($8_STATIC_LIBS_opt) \
-I build $($1_CMAS) $($1_CMOS)
]])
@@ -1266,6 +1293,7 @@
# $5 = if set link GD code
# $6 = if set link CryptoPP code (only for targets mlnet, mldonkey)
# $7 = if set link libmagic code (only for p2p core, not for GUIs, tools etc.)
+# $8 = if set link libbitstring code (only for Bittorrent p2p core)
EXPAND(mldonkey,mldonkey,NO,mldonkey,GD,CRYPTOPP,MAGIC)
EXPAND(mldonkey+gui,mldonkey+gui,GTK,mldonkey+gui,GD,CRYPTOPP,MAGIC)
@@ -1280,14 +1308,14 @@
EXPAND(mldc+gui,mldc+gui,GTK,mldc+gui,GD,NO,MAGIC)
EXPAND(mlnap,mlnap,NO,mlnap,GD,NO,MAGIC)
EXPAND(mlnap+gui,mlnap+gui,GTK,mlnap+gui,GD,NO,MAGIC)
-EXPAND(MLNET,mlnet,NO,MLNET,GD,CRYPTOPP,MAGIC)
-EXPAND(mlnet+gui,mlnet+gui,GTK,mlnet+gui,GD,CRYPTOPP,MAGIC)
+EXPAND(MLNET,mlnet,NO,MLNET,GD,CRYPTOPP,MAGIC,BITSTRING)
+EXPAND(mlnet+gui,mlnet+gui,GTK,mlnet+gui,GD,CRYPTOPP,MAGIC,BITSTRING)
EXPAND(mlgnut,mlgnut,NO,mlgnut,GD,NO,MAGIC)
EXPAND(mlgnut+gui,mlgnut+gui,GTK,mlgnut+gui,GD,NO,MAGIC)
EXPAND(mlg2,mlg2,NO,mlg2,GD,NO,MAGIC)
EXPAND(mlg2+gui,mlg2+gui,GTK,mlg2+gui,GD,NO,MAGIC)
-EXPAND(mlbt,mlbt,NO,mlbt,GD,NO,MAGIC)
-EXPAND(mlbt+gui,mlbt+gui,GTK,mlbt+gui,GD,NO,MAGIC)
+EXPAND(mlbt,mlbt,NO,mlbt,GD,NO,MAGIC,BITSTRING)
+EXPAND(mlbt+gui,mlbt+gui,GTK,mlbt+gui,GD,NO,MAGIC,BITSTRING)
EXPAND(mlfasttrack,mlfasttrack,NO,mlfasttrack,GD,NO,MAGIC)
EXPAND(mlfasttrack+gui,mlfasttrack+gui,GTK,mlfasttrack+gui,GD,NO,MAGIC)
EXPAND(mlfileTP,mlfiletp,NO,mlfileTP,GD,NO,MAGIC)
@@ -1298,7 +1326,7 @@
EXPAND(OBSERVER,observer)
EXPAND(MLD_HASH,mld_hash)
EXPAND(OCAMLPP,ocamlpp)
-EXPAND(MAKE_TORRENT,make_torrent,NO,NO,NO,NO,MAGIC)
+EXPAND(MAKE_TORRENT,make_torrent,NO,NO,NO,NO,MAGIC,BITSTRING)
EXPAND(SUBCONV,subconv)
EXPAND(MLSPLIT,mlsplit)
EXPAND(CONTESTER,contester,CRYPT)
@@ -1397,6 +1425,7 @@
rm -f build/*.a build/*.cma build/*.cmxa
rm -f *_plugin
rm -f mldonkey mlgui mlnet.exe mlgui.exe mldonkeytop mldonkeytop.exe
+ rm -f mlbt mlbt.exe mlfiletp mlfiletp.exe
rm -f svg_converter svg_converter.byte mld_hash make_torrent
copysources get_range subconv testrss
rm -f svg_converter.exe mld_hash.exe make_torrent.exe copysources.exe
get_range.exe subconv.exe testrss.exe
(for i in $(SUBDIRS); do \
@@ -1422,7 +1451,9 @@
rm -f packages/slackware/mldonkey.options
rm -f packages/windows/mlnet.nsi
rm -f src/daemon/driver/driverGraphics.ml
+ rm -f src/networks/bittorrent/bTUdpTracker.ml
rm -f src/networks/donkey/donkeySui.ml
+ rm -f src/utils/bitstring/bitstring.ml
rm -f src/utils/lib/autoconf.ml
rm -f src/utils/lib/autoconf.ml.new
rm -f src/utils/lib/gAutoconf.ml
@@ -1483,12 +1514,12 @@
depend: $(RESFILE) \
$(PA_ZOG) $(LIB)/http_lexer.ml $(TMPSOURCES)
- $(OCAMLDEP) $(OCAMLDEP_OPTIONS) $(patsubst -I +labl$(GTK),,$(INCLUDES))
*.ml *.mli > .depend
- (for i in $(SUBDIRS); do \
+ @$(OCAMLDEP) $(OCAMLDEP_OPTIONS) $(patsubst -I
+labl$(GTK),,$(INCLUDES)) *.ml *.mli > .depend
+ @(for i in $(SUBDIRS); do \
$(OCAMLDEP) $(OCAMLDEP_OPTIONS) $(patsubst -I
+labl$(GTK),,$(INCLUDES)) $$i/*.ml $$i/*.mli >> .depend; \
$(OCAMLPP) $$i/*.mlt >> .depend; \
done)
- if test "$(GUI)" = "newgui2"; then \
+ @if test "$(GUI)" = "newgui2"; then \
$(MAKE) svg_converter.byte; \
fi
@@ -1728,7 +1759,7 @@
-include .depend
-.SUFFIXES: .mli .ml .cmx .cmo .o .c .cmi .mll .mly .zog .plugindep .xpm .ml
.cc .ml_icons .ml4 .mlt .mlii .mlcpp .svg
+.SUFFIXES: .mli .ml .cmx .cmo .o .c .cmi .mll .mly .zog .plugindep .xpm .ml
.cc .ml_icons .ml4 .mlc4 .mlt .mlii .mlcpp .svg
.mli.cmi :
$(OCAMLC) $(INCLUDES) -c $<
@@ -1761,26 +1792,29 @@
$(OCAMLC) $(DEVFLAGS) $(INCLUDES) -c $<
.mlcpp.ml:
- cpp -P $< $(FIX_BROKEN_CPP) > $@
+ @cpp -P $< $(FIX_BROKEN_CPP) > $@
.mll.ml :
- $(OCAMLLEX) $<
+ @$(OCAMLLEX) -q $<
.mly.ml :
- $(OCAMLYACC) $<
+ @$(OCAMLYACC) $<
.mly.mli:
- $(OCAMLYACC) $<
+ @$(OCAMLYACC) $<
.zog.ml:
- $(CAMLP4) pa_o.cmo ./pa_zog.cma pr_o.cmo -impl $< > $@
+ @$(CAMLP4) pa_o.cmo ./pa_zog.cma pr_o.cmo -impl $< > $@
.ml4.ml:
- echo '# 1 "$<"' > $@
- $(CAMLP4) pa_o.cmo pa_op.cmo pr_o.cmo -impl $< >> $@
+ @echo '# 1 "$<"' > $@
+ @$(CAMLP4) pa_o.cmo pa_op.cmo pr_o.cmo -impl $< >> $@
+
+.mlc4.ml:
+ @$(CAMLP4OF) -I +camlp4 -impl $< -o $@
.mlt.ml:
- $(OCAMLPP) -pp $< > $@
+ @$(OCAMLPP) -pp $< > $@
.c.o :
$(OCAMLC) -verbose -ccopt "-I $(OCAML_SRC)/byterun -o $*.o" -ccopt
"$(CFLAGS)" $(LIBS_flags) -c $<
Index: config/configure.in
===================================================================
RCS file: /sources/mldonkey/mldonkey/config/configure.in,v
retrieving revision 1.337
retrieving revision 1.338
diff -u -b -r1.337 -r1.338
--- config/configure.in 29 Aug 2010 20:11:20 -0000 1.337
+++ config/configure.in 29 Aug 2010 20:17:56 -0000 1.338
@@ -718,6 +718,17 @@
])
+dnl Check for native endianness.
+AC_C_BIGENDIAN(,,
+ [AC_MSG_ERROR([Machine endianness could not be determined])]
+)
+if test "x$WORDS_BIGENDIAN" = "x"; then
+ NATIVEENDIAN=LittleEndian
+else
+ NATIVEENDIAN=BigEndian
+fi
+AC_SUBST(NATIVEENDIAN)
+
# various header files
AC_CHECK_FUNCS(setrlimit getrlimit strerror_r strerror posix_fallocate)
AC_CHECK_HEADERS(byteswap.h,,)
@@ -1446,6 +1457,7 @@
Makefile.config \
mldonkey.rc \
$AUTOCONF.new $GTK_AUTOCONF.new \
+ ../src/utils/bitstring/bitstring.ml \
../src/utils/lib/magic.ml \
../src/networks/donkey/donkeySui.ml \
../src/daemon/driver/driverGraphics.ml \
Index: distrib/ChangeLog
===================================================================
RCS file: /sources/mldonkey/mldonkey/distrib/ChangeLog,v
retrieving revision 1.1466
retrieving revision 1.1467
diff -u -b -r1.1466 -r1.1467
--- distrib/ChangeLog 29 Aug 2010 20:13:31 -0000 1.1466
+++ distrib/ChangeLog 29 Aug 2010 20:17:56 -0000 1.1467
@@ -15,6 +15,7 @@
=========
2010/08/29
+7144: BT: Support for UDP trackers (ygrek)
7288: HTML: Prepare localization (balamutick)
7287: Fix GTK1 oldgui compile with Ocaml 3.1* (ygrek)
7289: Raise minimum required Ocaml version to 3.10.1
Index: src/networks/bittorrent/bTClients.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/bittorrent/bTClients.ml,v
retrieving revision 1.105
retrieving revision 1.106
diff -u -b -r1.105 -r1.106
--- src/networks/bittorrent/bTClients.ml 23 May 2010 09:12:14 -0000
1.105
+++ src/networks/bittorrent/bTClients.ml 29 Aug 2010 20:17:56 -0000
1.106
@@ -19,6 +19,7 @@
(** Functions used in client<->client communication
+ and also client<->tracker
*)
(** A peer (or client) is always a remote peer in this file.
@@ -73,6 +74,142 @@
let next_uploaders = ref ([] : BTTypes.client list)
let current_uploaders = ref ([] : BTTypes.client list)
+(** Check that client is valid and record it *)
+let maybe_new_client file id ip port =
+ let cc = Geoip.get_country_code_option ip in
+ if id <> !!client_uid
+ && ip != Ip.null
+ && port <> 0
+ && (match !Ip.banned (ip, cc) with
+ | None -> true
+ | Some reason ->
+ if !verbose_connect then
+ lprintf_file_nl (as_file file) "%s:%d blocked: %s" (Ip.to_string
ip) port reason;
+ false)
+ then
+ ignore (new_client file id (ip,port) cc);
+ if !verbose_sources > 1 then
+ lprintf_file_nl (as_file file) "Received %s:%d" (Ip.to_string ip) port
+
+
+let resume_clients_hook = ref (fun _ -> assert false)
+
+include struct
+
+(* open modules locally *)
+open BTUdpTracker
+open UdpSocket
+
+let string_of_event = function
+ | READ_DONE -> "READ_DONE"
+ | WRITE_DONE -> "WRITE_DONE"
+ | CAN_REFILL -> "CAN_REFILL"
+ | BASIC_EVENT e -> match e with
+ | CLOSED reason -> "CLOSED " ^ (string_of_reason reason)
+ | RTIMEOUT -> "RTIMEOUT"
+ | WTIMEOUT -> "WTIMEOUT"
+ | LTIMEOUT -> "LTIMEOUT"
+ | CAN_READ -> "CAN_READ"
+ | CAN_WRITE -> "CAN_WRITE"
+
+(** talk to udp tracker and parse response
+ except of parsing should perform everything that
+ talk_to_tracker's inner function does FIXME refactor both
+
+ Better create single global udp socket and use it for all
+ tracker requests and distinguish trackers by txn? FIXME?
+ *)
+let talk_to_udp_tracker host port args file t need_sources =
+ let interact ip =
+ let socket = create (Ip.to_inet_addr !!client_bind_addr) 0 (fun sock event
->
+(* lprintf_nl "udpt got event %s for %s" (string_of_event event) host; *)
+ match event with
+ | WRITE_DONE | CAN_REFILL -> ()
+ | READ_DONE -> assert false (* set_reader prevents this *)
+ | BASIC_EVENT x -> match x with
+ | CLOSED _ -> ()
+ | CAN_READ | CAN_WRITE -> assert false (* udpSocket implementation
prevents this *)
+ | LTIMEOUT | WTIMEOUT | RTIMEOUT -> close sock (Closed_for_error "udpt
timeout"))
+ in
+ let set_reader f =
+ set_reader socket begin fun _ ->
+ try f () with exn ->
+ lprintf_nl "udpt interact exn %s" (Printexc2.to_string exn);
+ close socket (Closed_for_exception exn)
+ end
+ in
+ BasicSocket.set_wtimeout (sock socket) 60.;
+ 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;
+ set_reader begin fun () ->
+ let p = read socket in
+ let conn = connect_response 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; *)
+ let int s = Int64.of_string (List.assoc s args) in
+ let req = announce_request conn txn
+ ~info_hash:(List.assoc "info_hash" args)
+ ~peer_id:(List.assoc "peer_id" args)
+ (int "downloaded",int "left",int "uploaded")
+ (match try List.assoc "event" args with Not_found -> "" with
+ | "completed" -> 1l
+ | "started" -> 2l
+ | "stopped" -> 3l
+ | "" -> 0l
+ | s -> lprintf_nl "udpt event %s? for %s" s host; 0l)
+ ~ip:(if !!force_client_ip then (Int64.to_int32 (Ip.to_int64
!!set_client_ip)) else 0l)
+ ~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;
+ set_reader (fun () ->
+ let p = read socket in
+
+ t.tracker_last_conn <- last_time ();
+ file.file_tracker_connected <- true;
+ t.tracker_interval <- 600;
+ 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
+ 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
+ begin
+ t.tracker_interval <- Int32.to_int interval;
+ if t.tracker_min_interval > t.tracker_interval then
+ t.tracker_min_interval <- t.tracker_interval
+ end;
+ if need_sources then
+ List.iter (fun (ip',port) ->
+ let ip = Ip.of_int64 (Int64.logand 0xFFFFFFFFL (Int64.of_int32 ip'))
in
+(* lprintf_nl "udpt got %s:%d" (Ip.to_string ip) port; *)
+ t.tracker_last_clients_num <- t.tracker_last_clients_num + 1;
+ maybe_new_client file Sha1.null ip port
+ ) clients;
+ close socket Closed_by_user;
+ if !verbose_msg_servers then
+ lprintf_nl "udpt interact done for %s" host;
+ if need_sources then !resume_clients_hook file
+ ) end
+ in
+ try
+ if !verbose_msg_servers then
+ lprintf_nl "udpt start with %s:%d" host port;
+ Ip.async_ip host (fun ip ->
+(* lprintf_nl "udpt resolved %s to ip %s" host (Ip.to_string ip); *)
+ try interact ip with exn -> lprintf_nl "udpt interact exn %s"
(Printexc2.to_string exn))
+ (fun n ->
+ if !verbose_msg_servers then
+ lprintf_nl "udpt failed to resolve %s (%d)" host n)
+ with
+ exn ->
+ lprintf_nl "udpt start exn %s" (Printexc2.to_string exn)
+
+end (* include *)
(**
In this function we connect to a tracker.
@@ -182,14 +319,15 @@
then
begin
(* if we already tried to connect but failed, disable tracker, but
allow re-enabling *)
+ (* FIXME t.tracker_last_conn < 1 only at first connect, so later
failures will stay undetected! *)
if file.file_tracker_connected && t.tracker_last_clients_num = 0 &&
t.tracker_last_conn < 1 then
begin
if !verbose_msg_servers then
- lprintf_nl "Request error from tracker: disabling %s"
t.tracker_url;
+ lprintf_nl "Request error from tracker: disabling %s"
(show_tracker_url t.tracker_url);
t.tracker_status <- Disabled (intern "MLDonkey: Request error from
tracker")
end
(* Send request to tracker *)
- else begin
+ else
let args = if String.length t.tracker_id > 0 then
("trackerid", t.tracker_id) :: args else args
in
@@ -197,13 +335,14 @@
("key", t.tracker_key) :: args else args
in
if !verbose_msg_servers then
- lprintf_nl "connect_trackers: tracker_connected:%s id:%s
key:%s last_clients:%i last_conn-last_time:%i file: %s"
+ lprintf_nl "connect_trackers: connected:%s id:%s key:%s
last_clients:%i last_conn-last_time:%i numwant:%s file: %s"
(string_of_bool file.file_tracker_connected)
t.tracker_id t.tracker_key t.tracker_last_clients_num
- (t.tracker_last_conn - last_time()) file.file_name;
+ (t.tracker_last_conn - last_time()) (try List.assoc "numwant"
args with _ -> "_") file.file_name;
+ match t.tracker_url with
+ | `Http url ->
let module H = Http_client in
- let url = t.tracker_url in
let r = {
H.basic_request with
H.req_url = Url.of_string ~args: args url;
@@ -215,19 +354,20 @@
if !verbose_msg_servers then
lprintf_nl "Request sent to tracker %s for file: %s"
- t.tracker_url file.file_name;
+ url file.file_name;
H.wget r
(fun fileres ->
t.tracker_last_conn <- last_time ();
file.file_tracker_connected <- true;
f t fileres)
- end
+ | `Other url -> assert false (* should have been disabled *)
+ | `Udp (host,port) -> talk_to_udp_tracker host port args file t
need_sources
end
else
if !verbose_msg_servers then
lprintf_nl "Request NOT sent to tracker %s - next request in %ds for
file: %s"
- t.tracker_url (t.tracker_interval - (last_time () -
t.tracker_last_conn)) file.file_name
+ (show_tracker_url t.tracker_url) (t.tracker_interval - (last_time
() - t.tracker_last_conn)) file.file_name
) enabled_trackers
let start_upload c =
@@ -363,7 +503,9 @@
let download_finished file =
if List.memq file !current_files then
begin
- connect_trackers file "completed" false (fun _ _ -> ()); (*must be
called before swarmer gets removed from file*)
+ connect_trackers file "completed" false (fun _ _ ->
+ lprintf_file_nl (as_file file) "Tracker return: completed %s"
file.file_name;
+ ()); (*must be called before swarmer gets removed from file*)
(*CommonComplexOptions.file_completed*)
file_completed (as_file file);
(* Remove the swarmer for this file as it is not useful anymore... *)
@@ -1313,6 +1455,9 @@
lprintf_file_nl (as_file file) "Exception %s in resume_clients"
(Printexc2.to_string e)
) file.file_clients
+let () =
+ resume_clients_hook := resume_clients
+
(** Check if the value replied by the tracker is correct.
@param key the name of the key
@param n the value to check
@@ -1322,32 +1467,14 @@
let chk_keyval key n url name =
let int_n = (Int64.to_int n) in
if !verbose_msg_clients then
- lprintf_nl "Reply from %s in file: %s has %s: %d" url name key int_n;
+ lprintf_nl "Reply from %s in file: %s has %s: %d" (show_tracker_url url)
name key int_n;
if int_n > -1 then
int_n
else begin
- lprintf_nl "Reply from %s in file: %s has an invalid %s value: %d" url
name key int_n;
+ lprintf_nl "Reply from %s in file: %s has an invalid %s value: %d"
(show_tracker_url url) name key int_n;
0
end
-(** Check that client is valid and record it *)
-let maybe_new_client file id ip port =
- let cc = Geoip.get_country_code_option ip in
- if id <> !!client_uid
- && ip != Ip.null
- && port <> 0
- && (match !Ip.banned (ip, cc) with
- | None -> true
- | Some reason ->
- if !verbose_connect then
- lprintf_file_nl (as_file file) "%s:%d blocked: %s" (Ip.to_string
ip) port reason;
- false)
- then
- ignore (new_client file id (ip,port) cc);
- if !verbose_sources > 1 then
- lprintf_file_nl (as_file file) "Received %s:%d" (Ip.to_string ip) port;
- ()
-
let exn_catch f x = try `Ok (f x) with exn -> `Exn exn
(** In this function we interact with the tracker
@@ -1357,6 +1484,7 @@
let talk_to_tracker file need_sources =
(* This is the function which will be called by the http client for parsing
the response *)
let f t filename =
+ let tracker_url = show_tracker_url t.tracker_url in
let tracker_failed reason =
(* On failure, disable the tracker and count attempts (@see
is_tracker_enabled) *)
let num = match t.tracker_status with | Disabled_failure (i,_) -> i + 1
| _ -> 1 in
@@ -1364,7 +1492,7 @@
lprintf_file_nl (as_file file) "Failure no. %d%s from Tracker %s for
file: %s Reason: %s"
num
(if !!tracker_retries = 0 then "" else Printf.sprintf "/%d"
!!tracker_retries)
- t.tracker_url file.file_name (Charset.Locale.to_utf8 reason)
+ tracker_url file.file_name (Charset.Locale.to_utf8 reason)
in
match exn_catch File.to_string filename with
| `Exn _ | `Ok "" -> tracker_failed "empty reply"
@@ -1381,7 +1509,7 @@
begin match t.tracker_status with
| Disabled_failure (i, _) ->
lprintf_file_nl (as_file file) "Received good message from
Tracker %s after %d bad attempts"
- t.tracker_url i
+ tracker_url i
| _ -> () end;
(* Received good message from tracker after failures, re-enable
tracker *)
t.tracker_status <- Enabled;
@@ -1391,7 +1519,7 @@
| "failure reason", String failure -> tracker_failed failure
| "warning message", String warning ->
lprintf_file_nl (as_file file) "Warning from Tracker %s in
file: %s Reason: %s"
- t.tracker_url file.file_name warning
+ tracker_url file.file_name warning
| "interval", Int n ->
t.tracker_interval <- chk_keyval key n;
(* in case we don't receive "min interval" *)
@@ -1422,11 +1550,11 @@
| "key", String n ->
t.tracker_key <- n;
if !verbose_msg_clients then
- lprintf_file_nl (as_file file) "%s in file: %s has key: %s"
t.tracker_url file.file_name n
+ lprintf_file_nl (as_file file) "%s in file: %s has key: %s"
tracker_url file.file_name n
| "tracker id", String n ->
t.tracker_id <- n;
if !verbose_msg_clients then
- lprintf_file_nl (as_file file) "%s in file: %s has tracker
id %s" t.tracker_url file.file_name n
+ lprintf_file_nl (as_file file) "%s in file: %s has tracker
id %s" tracker_url file.file_name n
| "peers", List list ->
if need_sources then
Index: src/networks/bittorrent/bTComplexOptions.ml
===================================================================
RCS file:
/sources/mldonkey/mldonkey/src/networks/bittorrent/bTComplexOptions.ml,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -b -r1.43 -r1.44
--- src/networks/bittorrent/bTComplexOptions.ml 4 Apr 2010 09:16:28 -0000
1.43
+++ src/networks/bittorrent/bTComplexOptions.ml 29 Aug 2010 20:17:56 -0000
1.44
@@ -219,7 +219,7 @@
"file_uploaded", int64_to_value (file.file_uploaded);
"file_id", string_to_value (Sha1.to_string file.file_id);
"file_trackers", (list_to_value string_to_value)
- (List.map (fun t -> t.tracker_url) file.file_trackers);
+ (List.map (fun t -> show_tracker_url t.tracker_url)
file.file_trackers);
(* OK, but I still don't like the idea of forgetting all the clients.
We should have a better strategy, ie rating the clients and connecting
to them depending on the results of our last connections. And then,
Index: src/networks/bittorrent/bTGlobals.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/bittorrent/bTGlobals.ml,v
retrieving revision 1.86
retrieving revision 1.87
diff -u -b -r1.86 -r1.87
--- src/networks/bittorrent/bTGlobals.ml 4 Apr 2010 09:16:28 -0000
1.86
+++ src/networks/bittorrent/bTGlobals.ml 29 Aug 2010 20:17:56 -0000
1.87
@@ -230,16 +230,27 @@
file_temp);
file_fd
-let can_handle_tracker t =
- String2.check_prefix (String.lowercase t.tracker_url) "http://";
+let make_tracker_url url =
+ if String2.check_prefix (String.lowercase url) "http://"; then
+ `Http url (* do not change the case of the url *)
+ else
+ try Scanf.sscanf (String.lowercase url) "udp://%s@:%d" (fun host port ->
`Udp (host,port))
+ with _ -> `Other url
-let rec set_trackers file file_trackers =
- match file_trackers with
- | [] -> ()
- | url :: q ->
- if not (List.exists (fun tracker ->
- tracker.tracker_url = url
- ) file.file_trackers) then
+(** invariant: [make_tracker_url (show_tracker_url url) = url] *)
+let show_tracker_url : tracker_url -> string = function
+ | `Http url | `Other url -> url
+ | `Udp (host,port) -> Printf.sprintf "udp://%s:%d" host port
+
+let can_handle_tracker = function
+ | `Http _
+ | `Udp _ -> true
+ | `Other _ -> false
+
+let set_trackers file file_trackers =
+ List.iter (fun url ->
+ let url = make_tracker_url url in
+ if not (List.exists (fun tracker -> tracker.tracker_url = url)
file.file_trackers) then
let t = {
tracker_url = url;
tracker_interval = 600;
@@ -253,12 +264,11 @@
tracker_torrent_last_dl_req = 0;
tracker_id = "";
tracker_key = "";
- tracker_status = Enabled
+ tracker_status = if can_handle_tracker url then Enabled
+ else Disabled_mld (intern "Tracker type not
supported")
} in
- if not (can_handle_tracker t) then
- t.tracker_status <- Disabled_mld (intern "Tracker type not
supported");
- file.file_trackers <- t :: file.file_trackers;
- set_trackers file q
+ file.file_trackers <- t :: file.file_trackers)
+ file_trackers
let new_file file_id t torrent_diskname file_temp file_state user group =
try
@@ -878,7 +888,7 @@
let remove_tracker url file =
if !verbose_msg_servers then
List.iter (fun tracker ->
- lprintf_nl "Old tracker list :%s" tracker.tracker_url
+ lprintf_nl "Old tracker list: %s" (show_tracker_url tracker.tracker_url)
) file.file_trackers;
List.iter (fun bad_tracker ->
if bad_tracker.tracker_url = url then
@@ -886,7 +896,7 @@
) file.file_trackers;
if !verbose_msg_servers then
List.iter (fun tracker ->
- lprintf_nl "New tracker list :%s" tracker.tracker_url
+ lprintf_nl "New tracker list: %s" (show_tracker_url tracker.tracker_url)
) file.file_trackers
let tracker_is_enabled t =
Index: src/networks/bittorrent/bTInteractive.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/bittorrent/bTInteractive.ml,v
retrieving revision 1.160
retrieving revision 1.161
diff -u -b -r1.160 -r1.161
--- src/networks/bittorrent/bTInteractive.ml 7 Aug 2010 14:51:16 -0000
1.160
+++ src/networks/bittorrent/bTInteractive.ml 29 Aug 2010 20:17:56 -0000
1.161
@@ -234,14 +234,15 @@
Printf.bprintf buf "\\</tr\\>\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr
());
let tracker_header_printed = ref false in
List.iter (fun tracker ->
+ let tracker_url = show_tracker_url tracker.tracker_url in
let tracker_text =
match tracker.tracker_status with
| Disabled s | Disabled_mld s ->
- Printf.sprintf "\\<font color=\\\"red\\\"\\>disabled:
%s\\<br\\>\\--error: %s\\</font\\>" tracker.tracker_url s
+ Printf.sprintf "\\<font color=\\\"red\\\"\\>disabled:
%s\\<br\\>\\--error: %s\\</font\\>" tracker_url s
| Disabled_failure (i,s) ->
- Printf.sprintf "\\<font color=\\\"red\\\"\\>disabled:
%s\\<br\\>\\--error: %s (try %d)\\</font\\>" tracker.tracker_url s i
+ Printf.sprintf "\\<font color=\\\"red\\\"\\>disabled:
%s\\<br\\>\\--error: %s (try %d)\\</font\\>" tracker_url s i
| _ ->
- Printf.sprintf "enabled: %s" tracker.tracker_url
+ Printf.sprintf "enabled: %s" tracker_url
in
html_mods_td buf [
@@ -250,7 +251,7 @@
else
("", "sr br", "")
);
- (tracker.tracker_url, "sr", tracker_text)];
+ (tracker_url, "sr", tracker_text)];
Printf.bprintf buf "\\</tr\\>\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr
());
tracker_header_printed := true;
) file.file_trackers;
@@ -421,12 +422,13 @@
Printf.bprintf buf "Trackers:\n";
List.iter (fun tracker ->
+ let tracker_url = show_tracker_url tracker.tracker_url in
match tracker.tracker_status with
| Disabled s | Disabled_mld s ->
- Printf.bprintf buf "%s, disabled: %s\n" tracker.tracker_url s
+ Printf.bprintf buf "%s, disabled: %s\n" tracker_url s
| Disabled_failure (i,s) ->
- Printf.bprintf buf "%s, disabled (try %d): %s\n" tracker.tracker_url i
s
- | _ -> Printf.bprintf buf "%s\n" tracker.tracker_url
+ Printf.bprintf buf "%s, disabled (try %d): %s\n" tracker_url i s
+ | _ -> Printf.bprintf buf "%s\n" tracker_url
) file.file_trackers;
if file.file_torrent_diskname <> "" then
Printf.bprintf buf "Torrent diskname: %s\n" file.file_torrent_diskname;
@@ -697,9 +699,7 @@
(* Save the torrent, because we later want to put
it in the seeded directory. *)
let torrent_is_usable = ref false in
- let can_handle_tracker url =
- String2.check_prefix url "http://"; in
- List.iter (fun url -> if can_handle_tracker url then torrent_is_usable :=
true)
+ List.iter (fun url -> if can_handle_tracker (make_tracker_url url) then
torrent_is_usable := true)
(if torrent.torrent_announce_list <> [] then torrent.torrent_announce_list
else [torrent.torrent_announce]);
if not !torrent_is_usable then raise (Torrent_can_not_be_used
torrent.torrent_name);
Index: src/networks/bittorrent/bTTorrent.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/bittorrent/bTTorrent.ml,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -b -r1.22 -r1.23
--- src/networks/bittorrent/bTTorrent.ml 15 Aug 2010 15:05:18 -0000
1.22
+++ src/networks/bittorrent/bTTorrent.ml 29 Aug 2010 20:17:56 -0000
1.23
@@ -145,7 +145,7 @@
match key, value with
| "announce", String tracker_url ->
if !verbose_msg_servers then
- lprintf_nl "[BT] New tracker added :%s" tracker_url;
+ lprintf_nl "[BT] New tracker added: %s" tracker_url;
announce := tracker_url
| "announce-list", List list ->
List.iter (fun url_list ->
Index: src/networks/bittorrent/bTTypes.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/bittorrent/bTTypes.ml,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -b -r1.47 -r1.48
--- src/networks/bittorrent/bTTypes.ml 27 Mar 2010 13:22:35 -0000 1.47
+++ src/networks/bittorrent/bTTypes.ml 29 Aug 2010 20:17:56 -0000 1.48
@@ -232,6 +232,11 @@
| Disabled_mld of string
| Disabled_failure of (int * string)
+type tracker_url =
+[ `Http of string (* url *)
+| `Udp of string * int (* host and port *)
+| `Other of string ]
+
type client = {
client_client : client CommonClient.client_impl;
mutable client_file : file;
@@ -287,7 +292,7 @@
}
and tracker_info = {
- tracker_url : string;
+ tracker_url : tracker_url;
mutable tracker_interval : int;
mutable tracker_min_interval : int;
mutable tracker_last_conn : int;
Index: src/utils/lib/options.ml4
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/lib/options.ml4,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -b -r1.30 -r1.31
--- src/utils/lib/options.ml4 16 Jul 2010 13:56:35 -0000 1.30
+++ src/utils/lib/options.ml4 29 Aug 2010 20:17:57 -0000 1.31
@@ -256,10 +256,10 @@
let temp_file = filename ^ ".tmp" in
if Sys.file_exists temp_file then
begin
- Printf.eprintf "File %s exists\n" temp_file;
- Printf.eprintf "An error may have occurred during previous configuration
save.\n";
- Printf.eprintf "Please, check your configurations files, and
rename/remove this file\n";
- Printf.eprintf "before restarting\n";
+ lprintf "File %s exists\n" temp_file;
+ lprintf "An error may have occurred during previous configuration
save.\n";
+ lprintf "Please, check your configurations files, and rename/remove this
file\n";
+ lprintf "before restarting\n";
exit 70
end;
Unix2.tryopen_read filename (fun ic ->
@@ -271,10 +271,10 @@
try
parse_gwmlrc stream
with e ->
- Printf.eprintf "Syntax error while parsing file %s at pos %d:(%s)\n"
+ lprintf "Syntax error while parsing file %s at pos %d:(%s)\n"
filename (Stream.count s) (Printexc2.to_string e);
- Printf.eprintf "it seems that %s is corrupt,\n" filename;
- Printf.eprintf "try to use a backup from %s\n"
+ lprintf "it seems that %s is corrupt,\n" filename;
+ lprintf "try to use a backup from %s\n"
(Filename.concat (Sys.getcwd ()) "old_config");
exit 70 in
Hashtbl.clear once_values;
Index: src/utils/net/basicSocket.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/net/basicSocket.ml,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -b -r1.34 -r1.35
--- src/utils/net/basicSocket.ml 28 Jul 2010 16:25:44 -0000 1.34
+++ src/utils/net/basicSocket.ml 29 Aug 2010 20:17:57 -0000 1.35
@@ -260,13 +260,17 @@
(* *)
(*************************************************************************)
+let exn_log name f x =
+ try
+ f x
+ with e ->
+ lprintf_nl "[bS] %s : unexpected exn %s" name (Printexc2.to_string e)
+
let close t msg =
if t.fd <> dummy_fd then begin
if !debug then
lprintf_nl "[bS] CLOSING: %s (%s)" (sprint_socket t)
(string_of_reason msg);
- (try
- Unix.close t.fd;
- with _ -> ());
+ exn_log "close" Unix.close t.fd;
t.fd <- dummy_fd;
closed_tasks := t :: !closed_tasks;
t.closed <- true;
@@ -454,7 +458,7 @@
match list with
[] -> ()
| f :: tail ->
- (try f () with _ -> ());
+ exn_log "hook" f ();
exec_hooks tail
(*************************************************************************)
@@ -469,19 +473,19 @@
(
let time = !current_time in
if not t.closed && t.next_rtimeout < time then
- (try t.event_handler t RTIMEOUT with _ -> ());
+ exn_log "exec rtimeout" (t.event_handler t) RTIMEOUT;
if not t.closed && t.next_wtimeout < time then
- (try t.event_handler t WTIMEOUT with _ -> ());
+ exn_log "exec wtimeout" (t.event_handler t) WTIMEOUT;
if not t.closed && t.lifetime < time then
- (try t.event_handler t LTIMEOUT with _ -> ());
+ exn_log "exec ltimeout" (t.event_handler t) LTIMEOUT;
if not t.closed && t.flags land can_read <> 0 then
- (try
+ exn_log "exec can_read" (fun () ->
t.next_rtimeout <- time +. t.rtimeout;
- t.event_handler t CAN_READ with _ -> ());
+ t.event_handler t CAN_READ) ();
if not t.closed && t.flags land can_write <> 0 then
- (try
+ exn_log "exec can_write" (fun () ->
t.next_wtimeout <- time +. t.wtimeout;
- t.event_handler t CAN_WRITE with _ -> ());
+ t.event_handler t CAN_WRITE) ();
);
exec_tasks tail
@@ -497,7 +501,7 @@
(
if (not t.applied) && t.next_time <= !current_time then begin
t.applied <- true;
- try t.time_handler t with _ -> ()
+ begin try t.time_handler t with _ -> () end (* exn_log -> many
Fifo.empty *)
end
);
exec_timers tail
@@ -512,7 +516,7 @@
add_infinite_timer 1.0 (fun _ ->
if !verbose_bandwidth > 0 then
lprintf_nl "[BW1] Resetting bandwidth counters";
- List.iter (fun f -> try f () with _ -> ()) !bandwidth_second_timers
+ List.iter (fun f -> exn_log "reset bw ctr" f ()) !bandwidth_second_timers
);
while true do
try
@@ -527,7 +531,7 @@
[] -> ()
| t :: tail ->
closed_tasks := tail;
- (try t.event_handler t (CLOSED t.error) with _ -> ());
+ exn_log "exec closed" (t.event_handler t) (CLOSED t.error)
done;
(* lprintf "before iter_timer\n"; *)
Index: src/utils/net/ip.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/net/ip.ml,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -b -r1.29 -r1.30
--- src/utils/net/ip.ml 24 Feb 2009 18:35:47 -0000 1.29
+++ src/utils/net/ip.ml 29 Aug 2010 20:17:57 -0000 1.30
@@ -291,6 +291,11 @@
err_handler : (int -> unit);
}
+let exn_log name f x =
+ try
+ f x
+ with e ->
+ lprintf_nl "[Ip] %s : unexpected exn %s" name (Printexc2.to_string e)
external job_done : job -> bool = "ml_ip_job_done"
external job_start : job -> unit = "ml_ip_job_start"
@@ -302,7 +307,7 @@
try
(* lprintf "async_ip [%s]\n" name; *)
let ip = resolve_name_immediate name in
- (try f ip with _ -> ())
+ exn_log "async_ip" f ip
with Not_found ->
Fifo.put ip_fifo (name, f, ferr)
@@ -322,14 +327,14 @@
let (name, f, ferr) = Fifo.take ip_fifo in
(try
let ip = resolve_name_immediate name in
- (try f ip with _ -> ())
+ exn_log "ip_fifo immediate" f ip
with Not_found ->
(* lprintf "resolving name...\n"; *)
if !BasicSocket.use_threads &&
BasicSocket.has_threads () then
let job = {
- handler = f;
- err_handler = ferr;
+ handler = exn_log "ip_fifo handler" f;
+ err_handler = exn_log "ip_fifo err_handler" ferr;
name = name;
entries = [||];
error = false;
@@ -338,7 +343,7 @@
job_start job
else begin
(* lprintf "from_name ...\n"; *)
- f (from_name name)
+ exn_log "ip_fifo no threads" f (from_name name)
end
)
Index: src/utils/net/udpSocket.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/net/udpSocket.ml,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -b -r1.23 -r1.24
--- src/utils/net/udpSocket.ml 11 Apr 2010 10:42:06 -0000 1.23
+++ src/utils/net/udpSocket.ml 29 Aug 2010 20:17:57 -0000 1.24
@@ -31,6 +31,12 @@
let lprintf_n fmt =
lprintf2 log_prefix fmt
+let exn_log name f x =
+ try
+ f x
+ with e ->
+ lprintf_nl "%s : unexpected exn %s" name (Printexc2.to_string e)
+
type event =
WRITE_DONE
| CAN_REFILL
@@ -65,7 +71,6 @@
Fifo.put pings_fifo (ping.ping_die_time, ping)
let declare_pong ip =
- try
let ping = Hashtbl.find pings_hashtbl ip in
if ping.ping_obsolete_time > last_time () then begin
ping.ping_die_time <- 0;
@@ -82,7 +87,8 @@
with _ ->
Hashtbl.add latencies ip (ref delay, ref 1)
end
- with _ -> ()
+
+let declare_pong = exn_log "declare_pong" declare_pong
type udp_packet = {
udp_ping : bool;
@@ -171,13 +177,13 @@
let set_refill t f =
set_handler t CAN_REFILL f;
if PacketSet.is_empty t.wlist then
- (try f t with _ -> ())
+ exn_log "immediate refill" f t
let set_reader t f =
set_handler t READ_DONE f;
match t.rlist with
[] -> ()
- | _ -> (try f t with _ -> ())
+ | _ -> exn_log "immediate read" f t
let sock t = t.sock
let closed t = closed t.sock
@@ -425,9 +431,7 @@
PacketSet.is_empty t.wlist
let read_packets t f =
- List.iter (fun p ->
- try f p with _ -> ()
- ) t.rlist;
+ List.iter (exn_log "read_packets" f) t.rlist;
t.rlist <- []
let set_write_controler s c =
Index: src/networks/bittorrent/bTUdpTracker.mlp
===================================================================
RCS file: src/networks/bittorrent/bTUdpTracker.mlp
diff -N src/networks/bittorrent/bTUdpTracker.mlp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ src/networks/bittorrent/bTUdpTracker.mlp 29 Aug 2010 20:17:56 -0000
1.1
@@ -0,0 +1,60 @@
+(** UDP trackers
+ http://www.bittorrent.org/beps/bep_0015.html *)
+
+open Bitstring
+
+let of_bits = string_of_bitstring
+let bits = bitstring_of_string
+
+exception Error of string
+
+let fail fmt = Printf.ksprintf (fun s -> raise (Error s)) fmt
+
+let bitmatch error_response = { 3l : 32 ; txn : 32 ; msg : -1 : string }
+
+(** connect - obtain connection_id *)
+let connect_request txn =
+ of_bits ( BITSTRING { 0x41727101980L : 64 ; 0l : 32 ; txn : 32 } )
+
+(** connect response with connection_id for future use *)
+let connect_response s exp_txn =
+ bitmatch bits s with
+ | { 0l : 32 ; txn : 32 ; conn_id : 64 } ->
+ if txn = exp_txn then conn_id else fail "error connect_response txn %ld
expected %ld" txn exp_txn
+ | { :error_response } -> fail "error connect_response txn %ld : %s" txn msg
+ | { } -> fail "error connect_response"
+
+(** announce *)
+let announce_request conn txn ~info_hash ~peer_id (downloaded,left,uploaded)
event ?(ip=0l) ?(key=0l) ~numwant port =
+ of_bits (BITSTRING {
+ conn : 64 ;
+ 1l : 32 ;
+ txn : 32 ;
+ info_hash : 20 * 8 : string;
+ peer_id : 20 * 8 : string;
+ downloaded : 64 ;
+ left : 64 ;
+ uploaded : 64 ;
+ event : 32 ;
+ 0l : 32 ; (* ip *)
+ key : 32 ; (* key *)
+ numwant : 32 ; (* numwant *)
+ port : 16 })
+
+(** announce response *)
+let announce_response s exp_txn =
+ let rec clients rest l =
+ bitmatch rest with
+ | { ip : 32 ; port : 16 ; rest : -1 : bitstring } -> clients rest
((ip,port)::l)
+ | { } -> l
+ in
+ bitmatch bits s with
+ | { 1l : 32 ; txn : 32 ; interval : 32 ; leechers : 32 ; seeders : 32 ;
+ rest : -1 : bitstring } ->
+ if txn = exp_txn then
+ (interval,clients rest [])
+ else
+ fail "error announce_response txn %ld expected %ld" txn exp_txn
+ | { :error_response } -> fail "error announce_response txn %ld : %s" txn msg
+ | { } -> fail "error announce_response"
+
Index: src/utils/bitstring/bitstring.ml.in
===================================================================
RCS file: src/utils/bitstring/bitstring.ml.in
diff -N src/utils/bitstring/bitstring.ml.in
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ src/utils/bitstring/bitstring.ml.in 29 Aug 2010 20:17:57 -0000 1.1
@@ -0,0 +1,1185 @@
+(* Bitstring library.
+ * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+ *
+ * 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 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in COPYING.LIB.
+ *
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *
+ * $Id: bitstring.ml.in,v 1.1 2010/08/29 20:17:57 spiralvoice Exp $
+ *)
+
+open Printf
+
+(* Enable runtime debug messages. Must also have been enabled
+ * in pa_bitstring.ml.
+ *)
+let debug = ref false
+let version = "2.0.2"
+let package = "ocaml-bitstring"
+
+type endian = BigEndian | LittleEndian | NativeEndian
+
+let string_of_endian = function
+ | BigEndian -> "bigendian"
+ | LittleEndian -> "littleendian"
+ | NativeEndian -> "nativeendian"
+
+let nativeendian = @NATIVEENDIAN@
+
+(* Exceptions. *)
+exception Construct_failure of string * string * int * int
+
+(* A bitstring is simply the data itself (as a string), and the
+ * bitoffset and the bitlength within the string. Note offset/length
+ * are counted in bits, not bytes.
+ *)
+type bitstring = string * int * int
+
+type t = bitstring
+
+(* Functions to create and load bitstrings. *)
+let empty_bitstring = "", 0, 0
+
+let make_bitstring len c =
+ if len >= 0 then String.make ((len+7) lsr 3) c, 0, len
+ else
+ invalid_arg (
+ sprintf "make_bitstring/create_bitstring: len %d < 0" len
+ )
+
+let create_bitstring len = make_bitstring len '\000'
+
+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_chan chan =
+ let tmpsize = 16384 in
+ let buf = Buffer.create tmpsize in
+ let tmp = String.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;
+ done;
+ Buffer.contents 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 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 ()
+ )
+ )
+ in
+ loop ();
+ Buffer.contents 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 n = ref 0 in
+ while n := Unix.read fd tmp 0 tmpsize; !n > 0 do
+ Buffer.add_substring buf tmp 0 !n;
+ done;
+ Buffer.contents 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 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 ()
+ )
+ )
+ in
+ loop ();
+ Buffer.contents buf, 0, !len lsl 3
+
+let bitstring_of_file fname =
+ let chan = open_in_bin fname in
+ try
+ let bs = bitstring_of_chan chan in
+ close_in chan;
+ bs
+ with exn ->
+ close_in chan;
+ raise exn
+
+let bitstring_length (_, _, len) = len
+
+let subbitstring (data, off, len) off' len' =
+ let off = off + off' in
+ if len < off' + len' then invalid_arg "subbitstring";
+ (data, off, len')
+
+let dropbits n (data, off, len) =
+ let off = off + n in
+ let len = len - n in
+ if len < 0 then invalid_arg "dropbits";
+ (data, off, len)
+
+let takebits n (data, off, len) =
+ if len < n then invalid_arg "takebits";
+ (data, off, n)
+
+(*----------------------------------------------------------------------*)
+(* Bitwise functions.
+ *
+ * We try to isolate all bitwise functions within these modules.
+ *)
+
+module I = struct
+ (* Bitwise operations on ints. Note that we assume int <= 31 bits. *)
+ external (<<<) : int -> int -> int = "%lslint"
+ external (>>>) : int -> int -> int = "%lsrint"
+ external to_int : int -> int = "%identity"
+ let zero = 0
+ let one = 1
+ let minus_one = -1
+ let ff = 0xff
+
+ (* Create a mask 0-31 bits wide. *)
+ let mask bits =
+ if bits < 30 then
+ (one <<< bits) - 1
+ else if bits = 30 then
+ max_int
+ else if bits = 31 then
+ minus_one
+ else
+ invalid_arg "Bitstring.I.mask"
+
+ (* Byte swap an int of a given size. *)
+ let byteswap v bits =
+ if bits <= 8 then v
+ else if bits <= 16 then (
+ let shift = bits-8 in
+ let v1 = v >>> shift in
+ let v2 = ((v land (mask shift)) <<< 8) in
+ v2 lor v1
+ ) else if bits <= 24 then (
+ let shift = bits - 16 in
+ let v1 = v >>> (8+shift) in
+ let v2 = ((v >>> shift) land ff) <<< 8 in
+ let v3 = (v land (mask shift)) <<< 16 in
+ v3 lor v2 lor v1
+ ) else (
+ let shift = bits - 24 in
+ let v1 = v >>> (16+shift) in
+ let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
+ let v3 = ((v >>> shift) land ff) <<< 16 in
+ let v4 = (v land (mask shift)) <<< 24 in
+ v4 lor v3 lor v2 lor v1
+ )
+
+ (* Check a value is in range 0 .. 2^bits-1. *)
+ let range_unsigned v bits =
+ let mask = lnot (mask bits) in
+ (v land mask) = zero
+
+ (* Call function g on the top bits, then f on each full byte
+ * (big endian - so start at top).
+ *)
+ let rec map_bytes_be g f v bits =
+ if bits >= 8 then (
+ map_bytes_be g f (v >>> 8) (bits-8);
+ let lsb = v land ff in
+ f (to_int lsb)
+ ) else if bits > 0 then (
+ let lsb = v land (mask bits) in
+ g (to_int lsb) bits
+ )
+
+ (* Call function g on the top bits, then f on each full byte
+ * (little endian - so start at root).
+ *)
+ let rec map_bytes_le g f v bits =
+ if bits >= 8 then (
+ let lsb = v land ff in
+ f (to_int lsb);
+ map_bytes_le g f (v >>> 8) (bits-8)
+ ) else if bits > 0 then (
+ let lsb = v land (mask bits) in
+ g (to_int lsb) bits
+ )
+end
+
+module I32 = struct
+ (* Bitwise operations on int32s. Note we try to keep it as similar
+ * as possible to the I module above, to make it easier to track
+ * down bugs.
+ *)
+ let (<<<) = Int32.shift_left
+ let (>>>) = Int32.shift_right_logical
+ let (land) = Int32.logand
+ let (lor) = Int32.logor
+ let lnot = Int32.lognot
+ let pred = Int32.pred
+ let max_int = Int32.max_int
+ let to_int = Int32.to_int
+ let zero = Int32.zero
+ let one = Int32.one
+ let minus_one = Int32.minus_one
+ let ff = 0xff_l
+
+ (* Create a mask so many bits wide. *)
+ let mask bits =
+ if bits < 31 then
+ pred (one <<< bits)
+ else if bits = 31 then
+ max_int
+ else if bits = 32 then
+ minus_one
+ else
+ invalid_arg "Bitstring.I32.mask"
+
+ (* Byte swap an int of a given size. *)
+ let byteswap v bits =
+ if bits <= 8 then v
+ else if bits <= 16 then (
+ let shift = bits-8 in
+ let v1 = v >>> shift in
+ let v2 = (v land (mask shift)) <<< 8 in
+ v2 lor v1
+ ) else if bits <= 24 then (
+ let shift = bits - 16 in
+ let v1 = v >>> (8+shift) in
+ let v2 = ((v >>> shift) land ff) <<< 8 in
+ let v3 = (v land (mask shift)) <<< 16 in
+ v3 lor v2 lor v1
+ ) else (
+ let shift = bits - 24 in
+ let v1 = v >>> (16+shift) in
+ let v2 = ((v >>> (8+shift)) land ff) <<< 8 in
+ let v3 = ((v >>> shift) land ff) <<< 16 in
+ let v4 = (v land (mask shift)) <<< 24 in
+ v4 lor v3 lor v2 lor v1
+ )
+
+ (* Check a value is in range 0 .. 2^bits-1. *)
+ let range_unsigned v bits =
+ let mask = lnot (mask bits) in
+ (v land mask) = zero
+
+ (* Call function g on the top bits, then f on each full byte
+ * (big endian - so start at top).
+ *)
+ let rec map_bytes_be g f v bits =
+ if bits >= 8 then (
+ map_bytes_be g f (v >>> 8) (bits-8);
+ let lsb = v land ff in
+ f (to_int lsb)
+ ) else if bits > 0 then (
+ let lsb = v land (mask bits) in
+ g (to_int lsb) bits
+ )
+
+ (* Call function g on the top bits, then f on each full byte
+ * (little endian - so start at root).
+ *)
+ let rec map_bytes_le g f v bits =
+ if bits >= 8 then (
+ let lsb = v land ff in
+ f (to_int lsb);
+ map_bytes_le g f (v >>> 8) (bits-8)
+ ) else if bits > 0 then (
+ let lsb = v land (mask bits) in
+ g (to_int lsb) bits
+ )
+end
+
+module I64 = struct
+ (* Bitwise operations on int64s. Note we try to keep it as similar
+ * as possible to the I/I32 modules above, to make it easier to track
+ * down bugs.
+ *)
+ let (<<<) = Int64.shift_left
+ let (>>>) = Int64.shift_right_logical
+ let (land) = Int64.logand
+ let (lor) = Int64.logor
+ let lnot = Int64.lognot
+ let pred = Int64.pred
+ let max_int = Int64.max_int
+ let to_int = Int64.to_int
+ let zero = Int64.zero
+ let one = Int64.one
+ let minus_one = Int64.minus_one
+ let ff = 0xff_L
+
+ (* Create a mask so many bits wide. *)
+ let mask bits =
+ if bits < 63 then
+ pred (one <<< bits)
+ else if bits = 63 then
+ max_int
+ else if bits = 64 then
+ minus_one
+ else
+ invalid_arg "Bitstring.I64.mask"
+
+ (* Byte swap an int of a given size. *)
+ (* let byteswap v bits = *)
+
+ (* Check a value is in range 0 .. 2^bits-1. *)
+ let range_unsigned v bits =
+ let mask = lnot (mask bits) in
+ (v land mask) = zero
+
+ (* Call function g on the top bits, then f on each full byte
+ * (big endian - so start at top).
+ *)
+ let rec map_bytes_be g f v bits =
+ if bits >= 8 then (
+ map_bytes_be g f (v >>> 8) (bits-8);
+ let lsb = v land ff in
+ f (to_int lsb)
+ ) else if bits > 0 then (
+ let lsb = v land (mask bits) in
+ g (to_int lsb) bits
+ )
+
+ (* Call function g on the top bits, then f on each full byte
+ * (little endian - so start at root).
+ *)
+ let rec map_bytes_le g f v bits =
+ if bits >= 8 then (
+ let lsb = v land ff in
+ f (to_int lsb);
+ map_bytes_le g f (v >>> 8) (bits-8)
+ ) else if bits > 0 then (
+ let lsb = v land (mask bits) in
+ g (to_int lsb) bits
+ )
+end
+
+(*----------------------------------------------------------------------*)
+(* Extraction functions.
+ *
+ * NB: internal functions, called from the generated macros, and
+ * the parameters should have been checked for sanity already).
+ *)
+
+(* Extract and convert to numeric. A single bit is returned as
+ * a boolean. There are no endianness or signedness considerations.
+ *)
+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
+ 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
+let _get_byte32 data byteoff strlen =
+ if strlen > byteoff then Int32.of_int (Char.code data.[byteoff]) else 0l
+let _get_byte64 data byteoff strlen =
+ if strlen > byteoff then Int64.of_int (Char.code data.[byteoff]) else 0L
+
+(* Extract [2..8] bits. Because the result fits into a single
+ * byte we don't have to worry about endianness, only signedness.
+ *)
+let extract_char_unsigned data off len flen =
+ let byteoff = off lsr 3 in
+
+ (* Optimize the common (byte-aligned) case. *)
+ if off land 7 = 0 then (
+ let byte = Char.code 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 word =
+ (_get_byte data byteoff strlen lsl 8) +
+ _get_byte data (byteoff+1) strlen in
+
+ (* Mask off the top bits. *)
+ let bitmask = (1 lsl (16 - (off land 7))) - 1 in
+ let word = word land bitmask in
+ (* Shift right to get rid of the bottom bits. *)
+ let shift = 16 - ((off land 7) + flen) in
+ let word = word lsr shift in
+
+ word (*, off+flen, len-flen*)
+ )
+
+(* 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 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
+ 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
+ (* Mask off the top bits. *)
+ let bitmask = (1 lsl (31 - (off land 7))) - 1 in
+ let word = word land bitmask in
+ (* Shift right to get rid of the bottom bits. *)
+ let shift = 31 - ((off land 7) + flen) in
+ word lsr shift
+ ) 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
+ word lsr (31 - flen)
+ ) in
+ word (*, off+flen, len-flen*)
+
+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_ne_unsigned =
+ if nativeendian = BigEndian
+ then extract_int_be_unsigned
+ else extract_int_le_unsigned
+
+let extract_int_ee_unsigned = function
+ | BigEndian -> extract_int_be_unsigned
+ | LittleEndian -> extract_int_le_unsigned
+ | NativeEndian -> extract_int_ne_unsigned
+
+let _make_int32_be c0 c1 c2 c3 =
+ Int32.logor
+ (Int32.logor
+ (Int32.logor
+ (Int32.shift_left c0 24)
+ (Int32.shift_left c1 16))
+ (Int32.shift_left c2 8))
+ c3
+
+let _make_int32_le c0 c1 c2 c3 =
+ Int32.logor
+ (Int32.logor
+ (Int32.logor
+ (Int32.shift_left c3 24)
+ (Int32.shift_left c2 16))
+ (Int32.shift_left c1 8))
+ c0
+
+(* Extract exactly 32 bits. We have to consider endianness and signedness. *)
+let extract_int32_be_unsigned data off len flen =
+ let byteoff = off lsr 3 in
+
+ let strlen = String.length data in
+
+ let word =
+ (* Optimize the common (byte-aligned) case. *)
+ if off land 7 = 0 then (
+ let word =
+ let c0 = _get_byte32 data byteoff strlen in
+ let c1 = _get_byte32 data (byteoff+1) strlen in
+ let c2 = _get_byte32 data (byteoff+2) strlen in
+ let c3 = _get_byte32 data (byteoff+3) strlen in
+ _make_int32_be c0 c1 c2 c3 in
+ Int32.shift_right_logical word (32 - flen)
+ ) else (
+ (* Extract the next 32 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 in
+ let c0 = Int32.of_int c0 in
+ let c1 = Int32.of_int c1 in
+ let c2 = Int32.of_int c2 in
+ let c3 = Int32.of_int c3 in
+ _make_int32_be c0 c1 c2 c3 in
+ Int32.shift_right_logical word (32 - flen)
+ ) in
+ word (*, off+flen, len-flen*)
+
+let extract_int32_le_unsigned data off len flen =
+ let v = extract_int32_be_unsigned data off len flen in
+ let v = I32.byteswap v flen in
+ v
+
+let extract_int32_ne_unsigned =
+ if nativeendian = BigEndian
+ then extract_int32_be_unsigned
+ else extract_int32_le_unsigned
+
+let extract_int32_ee_unsigned = function
+ | BigEndian -> extract_int32_be_unsigned
+ | LittleEndian -> extract_int32_le_unsigned
+ | NativeEndian -> extract_int32_ne_unsigned
+
+let _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 =
+ Int64.logor
+ (Int64.logor
+ (Int64.logor
+ (Int64.logor
+ (Int64.logor
+ (Int64.logor
+ (Int64.logor
+ (Int64.shift_left c0 56)
+ (Int64.shift_left c1 48))
+ (Int64.shift_left c2 40))
+ (Int64.shift_left c3 32))
+ (Int64.shift_left c4 24))
+ (Int64.shift_left c5 16))
+ (Int64.shift_left c6 8))
+ c7
+
+let _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 =
+ _make_int64_be c7 c6 c5 c4 c3 c2 c1 c0
+
+(* Extract [1..64] bits. We have to consider endianness and signedness. *)
+let extract_int64_be_unsigned data off len flen =
+ let byteoff = off lsr 3 in
+
+ let strlen = String.length data in
+
+ let word =
+ (* Optimize the common (byte-aligned) case. *)
+ if off land 7 = 0 then (
+ let word =
+ let c0 = _get_byte64 data byteoff strlen in
+ let c1 = _get_byte64 data (byteoff+1) strlen in
+ let c2 = _get_byte64 data (byteoff+2) strlen in
+ let c3 = _get_byte64 data (byteoff+3) strlen in
+ let c4 = _get_byte64 data (byteoff+4) strlen in
+ let c5 = _get_byte64 data (byteoff+5) strlen in
+ let c6 = _get_byte64 data (byteoff+6) strlen in
+ let c7 = _get_byte64 data (byteoff+7) strlen in
+ _make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
+ Int64.shift_right_logical word (64 - 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
+ Int64.shift_right_logical word (64 - flen)
+ ) in
+ word (*, off+flen, len-flen*)
+
+let extract_int64_le_unsigned data off len flen =
+ let byteoff = off lsr 3 in
+
+ let strlen = String.length data in
+
+ let word =
+ (* Optimize the common (byte-aligned) case. *)
+ if off land 7 = 0 then (
+ let word =
+ let c0 = _get_byte64 data byteoff strlen in
+ let c1 = _get_byte64 data (byteoff+1) strlen in
+ let c2 = _get_byte64 data (byteoff+2) strlen in
+ let c3 = _get_byte64 data (byteoff+3) strlen in
+ let c4 = _get_byte64 data (byteoff+4) strlen in
+ let c5 = _get_byte64 data (byteoff+5) strlen in
+ let c6 = _get_byte64 data (byteoff+6) strlen in
+ let c7 = _get_byte64 data (byteoff+7) strlen in
+ _make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
+ Int64.logand word (I64.mask 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_le c0 c1 c2 c3 c4 c5 c6 c7 in
+ Int64.logand word (I64.mask flen)
+ ) in
+ word (*, off+flen, len-flen*)
+
+let extract_int64_ne_unsigned =
+ if nativeendian = BigEndian
+ then extract_int64_be_unsigned
+ else extract_int64_le_unsigned
+
+let extract_int64_ee_unsigned = function
+ | BigEndian -> extract_int64_be_unsigned
+ | 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_le_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc"
+
+external extract_fastpath_int16_ne_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc"
+
+external extract_fastpath_int16_be_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc"
+
+external extract_fastpath_int16_le_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc"
+
+external extract_fastpath_int16_ne_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc"
+
+(*
+external extract_fastpath_int24_be_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc"
+
+external extract_fastpath_int24_le_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc"
+
+external extract_fastpath_int24_ne_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc"
+
+external extract_fastpath_int24_be_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc"
+
+external extract_fastpath_int24_le_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc"
+
+external extract_fastpath_int24_ne_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc"
+*)
+
+external extract_fastpath_int32_be_unsigned : string -> int -> int32 -> int32
= "ocaml_bitstring_extract_fastpath_int32_be_unsigned" "noalloc"
+
+external extract_fastpath_int32_le_unsigned : string -> int -> int32 -> int32
= "ocaml_bitstring_extract_fastpath_int32_le_unsigned" "noalloc"
+
+external extract_fastpath_int32_ne_unsigned : string -> int -> int32 -> int32
= "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" "noalloc"
+
+external extract_fastpath_int32_be_signed : string -> int -> int32 -> int32 =
"ocaml_bitstring_extract_fastpath_int32_be_signed" "noalloc"
+
+external extract_fastpath_int32_le_signed : string -> int -> int32 -> int32 =
"ocaml_bitstring_extract_fastpath_int32_le_signed" "noalloc"
+
+external extract_fastpath_int32_ne_signed : string -> int -> int32 -> int32 =
"ocaml_bitstring_extract_fastpath_int32_ne_signed" "noalloc"
+
+(*
+external extract_fastpath_int40_be_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int40_be_unsigned" "noalloc"
+
+external extract_fastpath_int40_le_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int40_le_unsigned" "noalloc"
+
+external extract_fastpath_int40_ne_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" "noalloc"
+
+external extract_fastpath_int40_be_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int40_be_signed" "noalloc"
+
+external extract_fastpath_int40_le_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int40_le_signed" "noalloc"
+
+external extract_fastpath_int40_ne_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int40_ne_signed" "noalloc"
+
+external extract_fastpath_int48_be_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int48_be_unsigned" "noalloc"
+
+external extract_fastpath_int48_le_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int48_le_unsigned" "noalloc"
+
+external extract_fastpath_int48_ne_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" "noalloc"
+
+external extract_fastpath_int48_be_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int48_be_signed" "noalloc"
+
+external extract_fastpath_int48_le_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int48_le_signed" "noalloc"
+
+external extract_fastpath_int48_ne_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int48_ne_signed" "noalloc"
+
+external extract_fastpath_int56_be_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int56_be_unsigned" "noalloc"
+
+external extract_fastpath_int56_le_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int56_le_unsigned" "noalloc"
+
+external extract_fastpath_int56_ne_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" "noalloc"
+
+external extract_fastpath_int56_be_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int56_be_signed" "noalloc"
+
+external extract_fastpath_int56_le_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int56_le_signed" "noalloc"
+
+external extract_fastpath_int56_ne_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int56_ne_signed" "noalloc"
+*)
+
+external extract_fastpath_int64_be_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int64_be_unsigned" "noalloc"
+
+external extract_fastpath_int64_le_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int64_le_unsigned" "noalloc"
+
+external extract_fastpath_int64_ne_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" "noalloc"
+
+external extract_fastpath_int64_be_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int64_be_signed" "noalloc"
+
+external extract_fastpath_int64_le_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int64_le_signed" "noalloc"
+
+external extract_fastpath_int64_ne_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int64_ne_signed" "noalloc"
+
+(*----------------------------------------------------------------------*)
+(* Constructor functions. *)
+
+module Buffer = struct
+ type t = {
+ buf : Buffer.t;
+ mutable len : int; (* Length in bits. *)
+ (* Last byte in the buffer (if len is not aligned). We store
+ * it outside the buffer because buffers aren't mutable.
+ *)
+ mutable last : int;
+ }
+
+ let create () =
+ (* XXX We have almost enough information in the generator to
+ * choose a good initial size.
+ *)
+ { buf = Buffer.create 128; len = 0; last = 0 }
+
+ let contents { buf = buf; len = len; last = last } =
+ let data =
+ if len land 7 = 0 then
+ Buffer.contents buf
+ else
+ Buffer.contents buf ^ (String.make 1 (Char.chr last)) in
+ data, 0, len
+
+ (* Add exactly 8 bits. *)
+ let add_byte ({ buf = buf; len = len; last = last } as t) byte =
+ if byte < 0 || byte > 255 then invalid_arg "Bitstring.Buffer.add_byte";
+ let shift = len land 7 in
+ if shift = 0 then
+ (* Target buffer is byte-aligned. *)
+ Buffer.add_char buf (Char.chr byte)
+ else (
+ (* Target buffer is unaligned. 'last' is meaningful. *)
+ let first = byte lsr shift in
+ let second = (byte lsl (8 - shift)) land 0xff in
+ Buffer.add_char buf (Char.chr (last lor first));
+ t.last <- second
+ );
+ t.len <- t.len + 8
+
+ (* Add exactly 1 bit. *)
+ let add_bit ({ buf = buf; len = len; last = last } as t) bit =
+ let shift = 7 - (len land 7) in
+ if shift > 0 then
+ (* Somewhere in the middle of 'last'. *)
+ t.last <- last lor ((if bit then 1 else 0) lsl shift)
+ else (
+ (* Just a single spare bit in 'last'. *)
+ let last = last lor if bit then 1 else 0 in
+ Buffer.add_char buf (Char.chr last);
+ t.last <- 0
+ );
+ t.len <- len + 1
+
+ (* Add a small number of bits (definitely < 8). This uses a loop
+ * to call add_bit so it's slow.
+ *)
+ let _add_bits t c slen =
+ if slen < 1 || slen >= 8 then invalid_arg "Bitstring.Buffer._add_bits";
+ for i = slen-1 downto 0 do
+ let bit = c land (1 lsl i) <> 0 in
+ add_bit t bit
+ done
+
+ let add_bits ({ buf = buf; len = len } as t) str slen =
+ if slen > 0 then (
+ if len 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 (
+ (* Target buffer is aligned. Copy whole bytes then leave the
+ * 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 *)
+ let mask = 0xff lsl (8 - (slen land 7)) in
+ t.last <- last land mask
+ );
+ 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.
+ *)
+ let slenbytes = slen lsr 3 in
+ for i = 0 to slenbytes-1 do
+ let byte = Char.code 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
+ for i = 0 to bitsleft - 1 do
+ let bit = c land (0x80 lsr i) <> 0 in
+ add_bit t bit
+ done
+ )
+ );
+ )
+end
+
+(* Construct a single bit. *)
+let construct_bit buf b _ _ =
+ Buffer.add_bit buf b
+
+(* Construct a field, flen = [2..8]. *)
+let construct_char_unsigned buf v flen exn =
+ let max_val = 1 lsl flen in
+ if v < 0 || v >= max_val then raise exn;
+ if flen = 8 then
+ Buffer.add_byte buf v
+ else
+ Buffer._add_bits buf v flen
+
+(* Construct a field of up to 31 bits. *)
+let construct_int_be_unsigned buf v flen exn =
+ (* Check value is within range. *)
+ if not (I.range_unsigned v flen) then raise exn;
+ (* Add the bytes. *)
+ I.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
+
+(* Construct a field of up to 31 bits. *)
+let construct_int_le_unsigned buf v flen exn =
+ (* Check value is within range. *)
+ if not (I.range_unsigned v flen) then raise exn;
+ (* Add the bytes. *)
+ I.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
+
+let construct_int_ne_unsigned =
+ if nativeendian = BigEndian
+ then construct_int_be_unsigned
+ else construct_int_le_unsigned
+
+let construct_int_ee_unsigned = function
+ | BigEndian -> construct_int_be_unsigned
+ | LittleEndian -> construct_int_le_unsigned
+ | NativeEndian -> construct_int_ne_unsigned
+
+(* Construct a field of exactly 32 bits. *)
+let construct_int32_be_unsigned buf v flen _ =
+ Buffer.add_byte buf
+ (Int32.to_int (Int32.shift_right_logical v 24));
+ Buffer.add_byte buf
+ (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
+ Buffer.add_byte buf
+ (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
+ Buffer.add_byte buf
+ (Int32.to_int (Int32.logand v 0xff_l))
+
+let construct_int32_le_unsigned buf v flen _ =
+ Buffer.add_byte buf
+ (Int32.to_int (Int32.logand v 0xff_l));
+ Buffer.add_byte buf
+ (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 8) 0xff_l)));
+ Buffer.add_byte buf
+ (Int32.to_int ((Int32.logand (Int32.shift_right_logical v 16) 0xff_l)));
+ Buffer.add_byte buf
+ (Int32.to_int (Int32.shift_right_logical v 24))
+
+let construct_int32_ne_unsigned =
+ if nativeendian = BigEndian
+ then construct_int32_be_unsigned
+ else construct_int32_le_unsigned
+
+let construct_int32_ee_unsigned = function
+ | BigEndian -> construct_int32_be_unsigned
+ | LittleEndian -> construct_int32_le_unsigned
+ | NativeEndian -> construct_int32_ne_unsigned
+
+(* Construct a field of up to 64 bits. *)
+let construct_int64_be_unsigned buf v flen exn =
+ (* Check value is within range. *)
+ if not (I64.range_unsigned v flen) then raise exn;
+ (* Add the bytes. *)
+ I64.map_bytes_be (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
+
+(* Construct a field of up to 64 bits. *)
+let construct_int64_le_unsigned buf v flen exn =
+ (* Check value is within range. *)
+ if not (I64.range_unsigned v flen) then raise exn;
+ (* Add the bytes. *)
+ I64.map_bytes_le (Buffer._add_bits buf) (Buffer.add_byte buf) v flen
+
+let construct_int64_ne_unsigned =
+ if nativeendian = BigEndian
+ then construct_int64_be_unsigned
+ else construct_int64_le_unsigned
+
+let construct_int64_ee_unsigned = function
+ | BigEndian -> construct_int64_be_unsigned
+ | LittleEndian -> construct_int64_le_unsigned
+ | NativeEndian -> construct_int64_ne_unsigned
+
+(* Construct from a string of bytes, exact multiple of 8 bits
+ * in length of course.
+ *)
+let construct_string buf str =
+ let len = String.length str in
+ Buffer.add_bits buf str (len lsl 3)
+
+(* Construct from a bitstring. *)
+let construct_bitstring buf (data, off, len) =
+ (* Add individual bits until we get to the next byte boundary of
+ * the underlying string.
+ *)
+ let blen = 7 - ((off + 7) land 7) in
+ let blen = min blen len in
+ let rec loop off len blen =
+ if blen = 0 then (off, len)
+ else (
+ let b = extract_bit data off len 1
+ and off = off + 1 and len = len + 1 in
+ Buffer.add_bit buf b;
+ loop off len (blen-1)
+ )
+ in
+ let off, len = loop off len blen in
+ assert (len = 0 || (off land 7) = 0);
+
+ (* Add the remaining 'len' bits. *)
+ let data =
+ let off = off lsr 3 in
+ (* XXX dangerous allocation *)
+ if off = 0 then data
+ else String.sub data off (String.length data - off) in
+
+ Buffer.add_bits buf data len
+
+(* Concatenate bitstrings. *)
+let concat bs =
+ let buf = Buffer.create () in
+ List.iter (construct_bitstring buf) bs;
+ Buffer.contents buf
+
+(*----------------------------------------------------------------------*)
+(* Extract a string from a bitstring. *)
+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)
+ else (
+ (* Bit-twiddling case. *)
+ let strlen = (len + 7) lsr 3 in
+ let str = String.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;
+ loop data off len (i+1)
+ ) else if len > 0 then (
+ let c = extract_char_unsigned data off len len in
+ str.[i] <- Char.chr (c lsl (8-len))
+ )
+ in
+ loop data off len 0;
+ str
+ )
+
+(* To channel. *)
+
+let bitstring_to_chan ((data, off, len) as bits) chan =
+ (* Fail if the bitstring length isn't a multiple of 8. *)
+ if len land 7 <> 0 then invalid_arg "bitstring_to_chan";
+
+ if off land 7 = 0 then
+ (* Easy case: string is byte-aligned. *)
+ output chan data (off lsr 3) (len lsr 3)
+ else (
+ (* Bit-twiddling case: reuse string_of_bitstring *)
+ let str = string_of_bitstring bits in
+ output_string chan str
+ )
+
+let bitstring_to_file bits filename =
+ let chan = open_out_bin filename in
+ try
+ bitstring_to_chan bits chan;
+ close_out chan
+ with exn ->
+ close_out chan;
+ raise exn
+
+(*----------------------------------------------------------------------*)
+(* Comparison. *)
+let compare ((data1, off1, len1) as bs1) ((data2, off2, len2) as bs2) =
+ (* In the fully-aligned case, this is reduced to string comparison ... *)
+ if off1 land 7 = 0 && len1 land 7 = 0 && off2 land 7 = 0 && len2 land 7 = 0
+ then (
+ (* ... but we have to do that by hand because the bits may
+ * not extend to the full length of the underlying string.
+ *)
+ let off1 = off1 lsr 3 and off2 = off2 lsr 3
+ 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)
+ )
+ else len1 - len2
+ in
+ loop 0
+ )
+ else (
+ (* Slow/unaligned. *)
+ let str1 = string_of_bitstring bs1
+ and str2 = string_of_bitstring bs2 in
+ let r = String.compare str1 str2 in
+ if r <> 0 then r else len1 - len2
+ )
+
+let equals ((_, _, len1) as bs1) ((_, _, len2) as bs2) =
+ if len1 <> len2 then false
+ else if bs1 = bs2 then true
+ else 0 = compare bs1 bs2
+
+(*----------------------------------------------------------------------*)
+(* Bit get/set functions. *)
+
+let index_out_of_bounds () = invalid_arg "index out of bounds"
+
+let put (data, off, len) n v =
+ if n < 0 || n >= len then index_out_of_bounds ()
+ 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 = if v <> 0 then c lor mask else c land (lnot mask) in
+ data.[si] <- Char.unsafe_chr c
+ )
+
+let set bits n = put bits n 1
+
+let clear bits n = put bits n 0
+
+let get (data, off, len) n =
+ if n < 0 || n >= len then index_out_of_bounds ()
+ 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
+ c land mask
+ )
+
+let is_set bits n = get bits n <> 0
+
+let is_clear bits n = get bits n = 0
+
+(*----------------------------------------------------------------------*)
+(* Display functions. *)
+
+let isprint c =
+ let c = Char.code c in
+ c >= 32 && c < 127
+
+let hexdump_bitstring chan (data, off, len) =
+ let count = ref 0 in
+ let off = ref off in
+ let len = ref len in
+ let linelen = ref 0 in
+ let linechars = String.make 16 ' ' in
+
+ fprintf chan "00000000 ";
+
+ while !len > 0 do
+ let bits = min !len 8 in
+ let byte = extract_char_unsigned data !off !len bits in
+ off := !off + bits; len := !len - bits;
+
+ let byte = byte lsl (8-bits) in
+ fprintf chan "%02x " byte;
+
+ incr count;
+ 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;
+ linelen := 0;
+ for i = 0 to 15 do 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
+ ) else
+ fprintf chan "\n%!"
Index: src/utils/bitstring/bitstring.mli
===================================================================
RCS file: src/utils/bitstring/bitstring.mli
diff -N src/utils/bitstring/bitstring.mli
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ src/utils/bitstring/bitstring.mli 29 Aug 2010 20:17:57 -0000 1.1
@@ -0,0 +1,1081 @@
+(** Bitstring library. *)
+(* Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+ *
+ * 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 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in COPYING.LIB.
+ *
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *
+ * $Id: bitstring.mli,v 1.1 2010/08/29 20:17:57 spiralvoice Exp $
+ *)
+
+(**
+ {{:#reference}Jump straight to the reference section for
+ documentation on types and functions}.
+
+ {2 Introduction}
+
+ Bitstring adds Erlang-style bitstrings and matching over bitstrings
+ as a syntax extension and library for OCaml. You can use
+ this module to both parse and generate binary formats, for
+ example, communications protocols, disk formats and binary files.
+
+ {{:http://code.google.com/p/bitstring/}OCaml bitstring website}
+
+ This library used to be called "bitmatch".
+
+ {2 Examples}
+
+ A function which can parse IPv4 packets:
+
+{[
+let display pkt =
+ bitmatch pkt with
+ (* IPv4 packet header
+ 0 1 2 3
+ 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | 4 | IHL |Type of Service| Total Length |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Identification |Flags| Fragment Offset |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Time to Live | Protocol | Header Checksum |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Source Address |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Destination Address |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Options | Padding |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ *)
+ | { 4 : 4; hdrlen : 4; tos : 8; length : 16;
+ identification : 16; flags : 3; fragoffset : 13;
+ ttl : 8; protocol : 8; checksum : 16;
+ source : 32;
+ dest : 32;
+ options : (hdrlen-5)*32 : bitstring;
+ payload : -1 : bitstring } ->
+
+ printf "IPv4:\n";
+ printf " header length: %d * 32 bit words\n" hdrlen;
+ printf " type of service: %d\n" tos;
+ printf " packet length: %d bytes\n" length;
+ printf " identification: %d\n" identification;
+ printf " flags: %d\n" flags;
+ printf " fragment offset: %d\n" fragoffset;
+ printf " ttl: %d\n" ttl;
+ printf " protocol: %d\n" protocol;
+ printf " checksum: %d\n" checksum;
+ printf " source: %lx dest: %lx\n" source dest;
+ printf " header options + padding:\n";
+ Bitstring.hexdump_bitstring stdout options;
+ printf " packet payload:\n";
+ Bitstring.hexdump_bitstring stdout payload
+
+ | { version : 4 } ->
+ eprintf "unknown IP version %d\n" version;
+ exit 1
+
+ | { _ } as pkt ->
+ eprintf "data is smaller than one nibble:\n";
+ Bitstring.hexdump_bitstring stderr pkt;
+ exit 1
+]}
+
+ A program which can parse
+ {{:http://lxr.linux.no/linux/include/linux/ext3_fs.h}Linux EXT3 filesystem
superblocks}:
+
+{[
+let bits = Bitstring.bitstring_of_file "tests/ext3_sb"
+
+let () =
+ bitmatch bits with
+ | { s_inodes_count : 32 : littleendian; (* Inodes count *)
+ s_blocks_count : 32 : littleendian; (* Blocks count *)
+ s_r_blocks_count : 32 : littleendian; (* Reserved blocks count *)
+ s_free_blocks_count : 32 : littleendian; (* Free blocks count *)
+ s_free_inodes_count : 32 : littleendian; (* Free inodes count *)
+ s_first_data_block : 32 : littleendian; (* First Data Block *)
+ s_log_block_size : 32 : littleendian; (* Block size *)
+ s_log_frag_size : 32 : littleendian; (* Fragment size *)
+ s_blocks_per_group : 32 : littleendian; (* # Blocks per group *)
+ s_frags_per_group : 32 : littleendian; (* # Fragments per group *)
+ s_inodes_per_group : 32 : littleendian; (* # Inodes per group *)
+ s_mtime : 32 : littleendian; (* Mount time *)
+ s_wtime : 32 : littleendian; (* Write time *)
+ s_mnt_count : 16 : littleendian; (* Mount count *)
+ s_max_mnt_count : 16 : littleendian; (* Maximal mount count *)
+ 0xef53 : 16 : littleendian } -> (* Magic signature *)
+
+ printf "ext3 superblock:\n";
+ printf " s_inodes_count = %ld\n" s_inodes_count;
+ printf " s_blocks_count = %ld\n" s_blocks_count;
+ printf " s_free_inodes_count = %ld\n" s_free_inodes_count;
+ printf " s_free_blocks_count = %ld\n" s_free_blocks_count
+
+ | { _ } ->
+ eprintf "not an ext3 superblock!\n%!";
+ exit 2
+]}
+
+ Constructing packets for a simple binary message
+ protocol:
+
+{[
+(*
+ +---------------+---------------+--------------------------+
+ | type | subtype | parameter |
+ +---------------+---------------+--------------------------+
+ <-- 16 bits --> <-- 16 bits --> <------- 32 bits -------->
+
+ All fields are in network byte order.
+*)
+
+let make_message typ subtype param =
+ (BITSTRING {
+ typ : 16;
+ subtype : 16;
+ param : 32
+ }) ;;
+]}
+
+ {2 Loading, creating bitstrings}
+
+ The basic data type is the {!bitstring}, a string of bits of
+ arbitrary length. Bitstrings can be any length in bits and
+ operations do not need to be byte-aligned (although they will
+ generally be more efficient if they are byte-aligned).
+
+ Internally a bitstring is stored as a normal OCaml [string]
+ together with an offset and length, where the offset and length are
+ measured in bits. Thus one can efficiently form substrings of
+ bitstrings, overlay a bitstring on existing data, and load and save
+ bitstrings from files or other external sources.
+
+ To load a bitstring from a file use {!bitstring_of_file} or
+ {!bitstring_of_chan}.
+
+ There are also functions to create bitstrings from arbitrary data.
+ See the {{:#reference}reference} below.
+
+ {2 Matching bitstrings with patterns}
+
+ Use the [bitmatch] operator (part of the syntax extension) to break
+ apart a bitstring into its fields. [bitmatch] works a lot like the
+ OCaml [match] operator.
+
+ The general form of [bitmatch] is:
+
+ [bitmatch] {i bitstring-expression} [with]
+
+ [| {] {i pattern} [} ->] {i code}
+
+ [| {] {i pattern} [} ->] {i code}
+
+ [|] ...
+
+ As with normal match, the statement attempts to match the
+ bitstring against each pattern in turn. If none of the patterns
+ match then the standard library [Match_failure] exception is
+ thrown.
+
+ Patterns look a bit different from normal match patterns. They
+ consist of a list of bitfields separated by [;] where each bitfield
+ contains a bind variable, the width (in bits) of the field, and
+ other information. Some example patterns:
+
+{[
+bitmatch bits with
+
+| { version : 8; name : 8; param : 8 } -> ...
+
+ (* Bitstring of at least 3 bytes. First byte is the version
+ number, second byte is a field called name, third byte is
+ a field called parameter. *)
+
+| { flag : 1 } ->
+ printf "flag is %b\n" flag
+
+ (* A single flag bit (mapped into an OCaml boolean). *)
+
+| { len : 4; data : 1+len } ->
+ printf "len = %d, data = 0x%Lx\n" len data
+
+ (* A 4-bit length, followed by 1-16 bits of data, where the
+ length of the data is computed from len. *)
+
+| { ipv6_source : 128 : bitstring;
+ ipv6_dest : 128 : bitstring } -> ...
+
+ (* IPv6 source and destination addresses. Each is 128 bits
+ and is mapped into a bitstring type which will be a substring
+ of the main bitstring expression. *)
+]}
+
+ You can also add conditional when-clauses:
+
+{[
+| { version : 4 }
+ when version = 4 || version = 6 -> ...
+
+ (* Only match and run the code when version is 4 or 6. If
+ it isn't we will drop through to the next case. *)
+]}
+
+ Note that the pattern is only compared against the first part of
+ the bitstring (there may be more data in the bitstring following
+ the pattern, which is not matched). In terms of regular
+ expressions you might say that the pattern matches [^pattern], not
+ [^pattern$]. To ensure that the bitstring contains only the
+ pattern, add a length -1 bitstring to the end and test that its
+ length is zero in the when-clause:
+
+{[
+| { n : 4;
+ rest : -1 : bitstring }
+ when Bitstring.bitstring_length rest = 0 -> ...
+
+ (* Only matches exactly 4 bits. *)
+]}
+
+ Normally the first part of each field is a binding variable,
+ but you can also match a constant, as in:
+
+{[
+| { (4|6) : 4 } -> ...
+
+ (* Only matches if the first 4 bits contain either
+ the integer 4 or the integer 6. *)
+]}
+
+ One may also match on strings:
+
+{[
+| { "MAGIC" : 5*8 : string } -> ...
+
+ (* Only matches if the string "MAGIC" appears at the start
+ of the input. *)
+]}
+
+ {3:patternfieldreference Pattern field reference}
+
+ The exact format of each pattern field is:
+
+ [pattern : length [: qualifier [,qualifier ...]]]
+
+ [pattern] is the pattern, binding variable name, or constant to
+ match. [length] is the length in bits which may be either a
+ constant or an expression. The length expression is just an OCaml
+ expression and can use any values defined in the program, and refer
+ back to earlier fields (but not to later fields).
+
+ Integers can only have lengths in the range \[1..64\] bits. See the
+ {{:#integertypes}integer types} section below for how these are
+ mapped to the OCaml int/int32/int64 types. This is checked
+ at compile time if the length expression is constant, otherwise it is
+ checked at runtime and you will get a runtime exception eg. in
+ the case of a computed length expression.
+
+ A bitstring field of length -1 matches all the rest of the
+ bitstring (thus this is only useful as the last field in a
+ pattern).
+
+ A bitstring field of length 0 matches an empty bitstring
+ (occasionally useful when matching optional subfields).
+
+ Qualifiers are a list of identifiers/expressions which control the type,
+ signedness and endianness of the field. Permissible qualifiers are:
+
+ - [int]: field has an integer type
+ - [string]: field is a string type
+ - [bitstring]: field is a bitstring type
+ - [signed]: field is signed
+ - [unsigned]: field is unsigned
+ - [bigendian]: field is big endian - a.k.a network byte order
+ - [littleendian]: field is little endian - a.k.a Intel byte order
+ - [nativeendian]: field is same endianness as the machine
+ - [endian (expr)]: [expr] should be an expression which evaluates to
+ a {!endian} type, ie. [LittleEndian], [BigEndian] or [NativeEndian].
+ The expression is an arbitrary OCaml expression and can use the
+ value of earlier fields in the bitmatch.
+ - [offset (expr)]: see {{:#computedoffsets}computed offsets} below.
+
+ The default settings are [int], [unsigned], [bigendian], no offset.
+
+ Note that many of these qualifiers cannot be used together,
+ eg. bitstrings do not have endianness. The syntax extension should
+ give you a compile-time error if you use incompatible qualifiers.
+
+ {3 Other cases in bitmatch}
+
+ As well as a list of fields, it is possible to name the
+ bitstring and/or have a default match case:
+
+{[
+| { _ } -> ...
+
+ (* Default match case. *)
+
+| { _ } as pkt -> ...
+
+ (* Default match case, with 'pkt' bound to the whole bitstring. *)
+]}
+
+ {2 Constructing bitstrings}
+
+ Bitstrings may be constructed using the [BITSTRING] operator (as an
+ expression). The [BITSTRING] operator takes a list of fields,
+ similar to the list of fields for matching:
+
+{[
+let version = 1 ;;
+let data = 10 ;;
+let bits =
+ BITSTRING {
+ version : 4;
+ data : 12
+ } ;;
+
+ (* Constructs a 16-bit bitstring with the first four bits containing
+ the integer 1, and the following 12 bits containing the integer 10,
+ arranged in network byte order. *)
+
+Bitstring.hexdump_bitstring stdout bits ;;
+
+ (* Prints:
+
+ 00000000 10 0a |.. |
+ *)
+]}
+
+ The format of each field is the same as for pattern fields (see
+ {{:#patternfieldreference}Pattern field reference section}), and
+ things like computed length fields, fixed value fields, insertion
+ of bitstrings within bitstrings, etc. are all supported.
+
+ {3 Construction exception}
+
+ The [BITSTRING] operator may throw a {!Construct_failure}
+ exception at runtime.
+
+ Runtime errors include:
+
+ - int field length not in the range \[1..64\]
+ - a bitstring with a length declared which doesn't have the
+ same length at runtime
+ - trying to insert an out of range value into an int field
+ (eg. an unsigned int field which is 2 bits wide can only
+ take values in the range \[0..3\]).
+
+ {2:integertypes Integer types}
+
+ Integer types are mapped to OCaml types [bool], [int], [int32] or
+ [int64] using a system which tries to ensure that (a) the types are
+ reasonably predictable and (b) the most efficient type is
+ preferred.
+
+ The rules are slightly different depending on whether the bit
+ length expression in the field is a compile-time constant or a
+ computed expression.
+
+ Detection of compile-time constants is quite simplistic so only
+ simple integer literals and simple expressions (eg. [5*8]) are
+ recognized as constants.
+
+ In any case the bit size of an integer is limited to the range
+ \[1..64\]. This is detected as a compile-time error if that is
+ possible, otherwise a runtime check is added which can throw an
+ [Invalid_argument] exception.
+
+ The mapping is thus:
+
+ {v
+ Bit size ---- OCaml type ----
+ Constant Computed expression
+
+ 1 bool int64
+ 2..31 int int64
+ 32 int32 int64
+ 33..64 int64 int64
+ v}
+
+ A possible future extension may allow people with 64 bit computers
+ to specify a more optimal [int] type for bit sizes in the range
+ [32..63]. If this was implemented then such code {i could not even
+ be compiled} on 32 bit platforms, so it would limit portability.
+
+ Another future extension may be to allow computed
+ expressions to assert min/max range for the bit size,
+ allowing a more efficient data type than int64 to be
+ used. (Of course under such circumstances there would
+ still need to be a runtime check to enforce the
+ size).
+
+ {2 Advanced pattern-matching features}
+
+ {3:computedoffsets Computed offsets}
+
+ You can add an [offset(..)] qualifier to bitmatch patterns in order
+ to move the current offset within the bitstring forwards.
+
+ For example:
+
+{[
+bitmatch bits with
+| { field1 : 8;
+ field2 : 8 : offset(160) } -> ...
+]}
+
+ matches [field1] at the start of the bitstring and [field2]
+ at 160 bits into the bitstring. The middle 152 bits go
+ unmatched (ie. can be anything).
+
+ The generated code is efficient. If field lengths and offsets
+ are known to be constant at compile time, then almost all
+ runtime checks are avoided. Non-constant field lengths and/or
+ non-constant offsets can result in more runtime checks being added.
+
+ Note that moving the offset backwards, and moving the offset in
+ [BITSTRING] constructors, are both not supported at present.
+
+ {3 Check expressions}
+
+ You can add a [check(expr)] qualifier to bitmatch patterns.
+ If the expression evaluates to false then the current match case
+ fails to match (in other words, we fall through to the next
+ match case - there is no error).
+
+ For example:
+{[
+bitmatch bits with
+| { field : 16 : check (field > 100) } -> ...
+]}
+
+ Note the difference between a check expression and a when-clause
+ is that the when-clause is evaluated after all the fields have
+ been matched. On the other hand a check expression is evaluated
+ after the individual field has been matched, which means it is
+ potentially more efficient (if the check expression fails then
+ we don't waste any time matching later fields).
+
+ We wanted to use the notation [when(expr)] here, but because
+ [when] is a reserved word we could not do this.
+
+ {3 Bind expressions}
+
+ A bind expression is used to change the value of a matched
+ field. For example:
+{[
+bitmatch bits with
+| { len : 16 : bind (len * 8);
+ field : len : bitstring } -> ...
+]}
+
+ In the example, after 'len' has been matched, its value would
+ be multiplied by 8, so the width of 'field' is the matched
+ value multiplied by 8.
+
+ In the general case:
+{[
+| { field : ... : bind (expr) } -> ...
+]}
+ evaluates the following after the field has been matched:
+{[
+ let field = expr in
+ (* remaining fields *)
+]}
+
+ {3 Order of evaluation of check() and bind()}
+
+ The choice is arbitrary, but we have chosen that check expressions
+ are evaluated first, and bind expressions are evaluated after.
+
+ This means that the result of bind() is {i not} available in
+ the check expression.
+
+ Note that this rule applies regardless of the order of check()
+ and bind() in the source code.
+
+ {3 save_offset_to}
+
+ Use [save_offset_to(variable)] to save the current bit offset
+ within the match to a variable (strictly speaking, to a pattern).
+ This variable is then made available in any [check()] and [bind()]
+ clauses in the current field, {i and} to any later fields, and
+ to the code after the [->].
+
+ For example:
+{[
+bitmatch bits with
+| { len : 16;
+ _ : len : bitstring;
+ field : 16 : save_offset_to (field_offset) } ->
+ printf "field is at bit offset %d in the match\n" field_offset
+]}
+
+ (In that example, [field_offset] should always have the value
+ [len+16]).
+
+ {2 Named patterns and persistent patterns}
+
+ Please see {!Bitstring_persistent} for documentation on this subject.
+
+ {2 Compiling}
+
+ Using the compiler directly you can do:
+
+ {v
+ ocamlc -I +bitstring \
+ -pp "camlp4of bitstring.cma bitstring_persistent.cma \
+ `ocamlc -where`/bitstring/pa_bitstring.cmo" \
+ unix.cma bitstring.cma test.ml -o test
+ v}
+
+ Simpler method using findlib:
+
+ {v
+ ocamlfind ocamlc \
+ -package bitstring,bitstring.syntax -syntax bitstring.syntax \
+ -linkpkg test.ml -o test
+ v}
+
+ {2 Security and type safety}
+
+ {3 Security on input}
+
+ The main concerns for input are buffer overflows and denial
+ of service.
+
+ It is believed that this library is robust against attempted buffer
+ overflows. In addition to OCaml's normal bounds checks, we check
+ that field lengths are >= 0, and many additional checks.
+
+ Denial of service attacks are more problematic. We only work
+ forwards through the bitstring, thus computation will eventually
+ terminate. As for computed lengths, code such as this is thought
+ to be secure:
+
+ {[
+ bitmatch bits with
+ | { len : 64;
+ buffer : Int64.to_int len : bitstring } ->
+ ]}
+
+ The [len] field can be set arbitrarily large by an attacker, but
+ when pattern-matching against the [buffer] field this merely causes
+ a test such as [if len <= remaining_size] to fail. Even if the
+ length is chosen so that [buffer] bitstring is allocated, the
+ allocation of sub-bitstrings is efficient and doesn't involve an
+ arbitary-sized allocation or any copying.
+
+ However the above does not necessarily apply to strings used in
+ matching, since they may cause the library to use the
+ {!Bitstring.string_of_bitstring} function, which allocates a string.
+ So you should take care if you use the [string] type particularly
+ with a computed length that is derived from external input.
+
+ The main protection against attackers should be to ensure that the
+ main program will only read input bitstrings up to a certain
+ length, which is outside the scope of this library.
+
+ {3 Security on output}
+
+ As with the input side, computed lengths are believed to be
+ safe. For example:
+
+ {[
+ let len = read_untrusted_source () in
+ let buffer = allocate_bitstring () in
+ BITSTRING {
+ buffer : len : bitstring
+ }
+ ]}
+
+ This code merely causes a check that buffer's length is the same as
+ [len]. However the program function [allocate_bitstring] must
+ refuse to allocate an oversized buffer (but that is outside the
+ scope of this library).
+
+ {3 Order of evaluation}
+
+ In [bitmatch] statements, fields are evaluated left to right.
+
+ Note that the when-clause is evaluated {i last}, so if you are
+ relying on the when-clause to filter cases then your code may do a
+ lot of extra and unncessary pattern-matching work on fields which
+ may never be needed just to evaluate the when-clause. Either
+ rearrange the code to do only the first part of the match,
+ followed by the when-clause, followed by a second inner bitmatch,
+ or use a [check()] qualifier within fields.
+
+ {3 Safety}
+
+ The current implementation is believed to be fully type-safe,
+ and makes compile and run-time checks where appropriate. If
+ you find a case where a check is missing please submit a
+ bug report or a patch.
+
+ {2 Limits}
+
+ These are thought to be the current limits:
+
+ Integers: \[1..64\] bits.
+
+ Bitstrings (32 bit platforms): maximum length is limited
+ by the string size, ie. 16 MBytes.
+
+ Bitstrings (64 bit platforms): maximum length is thought to be
+ limited by the string size, ie. effectively unlimited.
+
+ Bitstrings must be loaded into memory before we can match against
+ them. Thus available memory may be considered a limit for some
+ applications.
+
+ {2:reference Reference}
+ {3 Types}
+*)
+
+type bitstring = string * int * int
+(** [bitstring] is the basic type used to store bitstrings.
+
+ The type contains the underlying data (a string),
+ 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
+ in {b bits}, not bytes.
+
+ Normally you don't need to use the bitstring type
+ directly, since there are functions and syntax
+ extensions which hide the details.
+
+ See also {!bitstring_of_string}, {!bitstring_of_file},
+ {!hexdump_bitstring}, {!bitstring_length}.
+*)
+
+type t = bitstring
+(** [t] is a synonym for the {!bitstring} type.
+
+ This allows you to use this module with functors like
+ [Set] and [Map] from the stdlib. *)
+
+(** {3 Exceptions} *)
+
+exception Construct_failure of string * string * int * int
+(** [Construct_failure (message, file, line, char)] may be
+ raised by the [BITSTRING] constructor.
+
+ Common reasons are that values are out of range of
+ the fields that contain them, or that computed lengths
+ are impossible (eg. negative length bitfields).
+
+ [message] is the error message.
+
+ [file], [line] and [char] point to the original source
+ location of the [BITSTRING] constructor that failed.
+*)
+
+(** {3 Bitstring comparison} *)
+
+val compare : bitstring -> bitstring -> int
+(** [compare bs1 bs2] compares two bitstrings and returns zero
+ if they are equal, a negative number if [bs1 < bs2], or a
+ positive number if [bs1 > bs2].
+
+ This tests "semantic equality" which is not affected by
+ the offset or alignment of the underlying representation
+ (see {!bitstring}).
+
+ The ordering is total and lexicographic. *)
+
+val equals : bitstring -> bitstring -> bool
+(** [equals] returns true if and only if the two bitstrings are
+ semantically equal. It is the same as calling [compare] and
+ testing if the result is [0], but usually more efficient. *)
+
+(** {3 Bitstring manipulation} *)
+
+val bitstring_length : bitstring -> int
+(** [bitstring_length bitstring] returns the length of
+ the bitstring in bits.
+
+ Note this just returns the third field in the {!bitstring} tuple. *)
+
+val subbitstring : bitstring -> int -> int -> bitstring
+(** [subbitstring bits off len] returns a sub-bitstring
+ of the bitstring, starting at offset [off] bits and
+ with length [len] bits.
+
+ If the original bitstring is not long enough to do this
+ then the function raises [Invalid_argument "subbitstring"].
+
+ Note that this function just changes the offset and length
+ fields of the {!bitstring} tuple, so is very efficient. *)
+
+val dropbits : int -> bitstring -> bitstring
+(** Drop the first n bits of the bitstring and return a new
+ bitstring which is shorter by n bits.
+
+ If the length of the original bitstring is less than n bits,
+ this raises [Invalid_argument "dropbits"].
+
+ Note that this function just changes the offset and length
+ fields of the {!bitstring} tuple, so is very efficient. *)
+
+val takebits : int -> bitstring -> bitstring
+(** Take the first n bits of the bitstring and return a new
+ bitstring which is exactly n bits long.
+
+ If the length of the original bitstring is less than n bits,
+ this raises [Invalid_argument "takebits"].
+
+ Note that this function just changes the offset and length
+ fields of the {!bitstring} tuple, so is very efficient. *)
+
+val concat : bitstring list -> bitstring
+(** Concatenate a list of bitstrings together into a single
+ bitstring. *)
+
+(** {3 Constructing bitstrings} *)
+
+val empty_bitstring : bitstring
+(** [empty_bitstring] is the empty, zero-length bitstring. *)
+
+val create_bitstring : int -> bitstring
+(** [create_bitstring n] creates an [n] bit bitstring
+ containing all zeroes. *)
+
+val make_bitstring : int -> char -> bitstring
+(** [make_bitstring n c] creates an [n] bit bitstring
+ containing the repeated 8 bit pattern in [c].
+
+ For example, [make_bitstring 16 '\x5a'] will create
+ the bitstring [0x5a5a] or in binary [0101 1010 0101 1010].
+
+ Note that the length is in bits, not bytes. The length does NOT
+ need to be a multiple of 8. *)
+
+val zeroes_bitstring : int -> bitstring
+(** [zeroes_bitstring] creates an [n] bit bitstring of all 0's.
+
+ Actually this is the same as {!create_bitstring}. *)
+
+val ones_bitstring : int -> bitstring
+(** [ones_bitstring] creates an [n] bit bitstring of all 1's. *)
+
+val bitstring_of_string : string -> bitstring
+(** [bitstring_of_string str] creates a bitstring
+ of length [String.length str * 8] (bits) containing the
+ bits in [str].
+
+ Note that the bitstring uses [str] as the underlying
+ string (see the representation of {!bitstring}) so you
+ should not change [str] after calling this. *)
+
+val bitstring_of_file : string -> bitstring
+(** [bitstring_of_file filename] loads the named file
+ into a bitstring. *)
+
+val bitstring_of_chan : in_channel -> bitstring
+(** [bitstring_of_chan chan] loads the contents of
+ the input channel [chan] as a bitstring.
+
+ The length of the final bitstring is determined
+ by the remaining input in [chan], but will always
+ be a multiple of 8 bits.
+
+ See also {!bitstring_of_chan_max}. *)
+
+val bitstring_of_chan_max : in_channel -> int -> bitstring
+(** [bitstring_of_chan_max chan max] works like
+ {!bitstring_of_chan} but will only read up to
+ [max] bytes from the channel (or fewer if the end of input
+ occurs before that). *)
+
+val bitstring_of_file_descr : Unix.file_descr -> bitstring
+(** [bitstring_of_file_descr fd] loads the contents of
+ the file descriptor [fd] as a bitstring.
+
+ See also {!bitstring_of_chan}, {!bitstring_of_file_descr_max}. *)
+
+val bitstring_of_file_descr_max : Unix.file_descr -> int -> bitstring
+(** [bitstring_of_file_descr_max fd max] works like
+ {!bitstring_of_file_descr} but will only read up to
+ [max] bytes from the channel (or fewer if the end of input
+ occurs before that). *)
+
+(** {3 Converting bitstrings} *)
+
+val string_of_bitstring : bitstring -> string
+(** [string_of_bitstring bitstring] converts a bitstring to a string
+ (eg. to allow comparison).
+
+ This function is inefficient. In the best case when the bitstring
+ is nicely byte-aligned we do a [String.sub] operation. If the
+ bitstring isn't aligned then this involves a lot of bit twiddling
+ and is particularly inefficient.
+
+ If the bitstring is not a multiple of 8 bits wide then the
+ final byte of the string contains the high bits set to the
+ remaining bits and the low bits set to 0. *)
+
+val bitstring_to_file : bitstring -> string -> unit
+(** [bitstring_to_file bits filename] writes the bitstring [bits]
+ to the file [filename]. It overwrites the output file.
+
+ Some restrictions apply, see {!bitstring_to_chan}. *)
+
+val bitstring_to_chan : bitstring -> out_channel -> unit
+(** [bitstring_to_file bits filename] writes the bitstring [bits]
+ to the channel [chan].
+
+ Channels are made up of bytes, bitstrings can be any bit length
+ including fractions of bytes. So this function only works
+ if the length of the bitstring is an exact multiple of 8 bits
+ (otherwise it raises [Invalid_argument "bitstring_to_chan"]).
+
+ Furthermore the function is efficient only in the case where
+ the bitstring is stored fully aligned, otherwise it has to
+ do inefficient bit twiddling like {!string_of_bitstring}.
+
+ In the common case where the bitstring was generated by the
+ [BITSTRING] operator and is an exact multiple of 8 bits wide,
+ then this function will always work efficiently.
+*)
+
+(** {3 Printing bitstrings} *)
+
+val hexdump_bitstring : out_channel -> bitstring -> unit
+(** [hexdump_bitstring chan bitstring] prints the bitstring
+ to the output channel in a format similar to the
+ Unix command [hexdump -C]. *)
+
+(** {3 Bitstring buffer} *)
+
+module Buffer : sig
+ type t
+ val create : unit -> t
+ val contents : t -> bitstring
+ val add_bits : t -> string -> int -> unit
+ val add_bit : t -> bool -> unit
+ val add_byte : t -> int -> unit
+end
+(** Buffers are mainly used by the [BITSTRING] constructor, but
+ may also be useful for end users. They work much like the
+ standard library [Buffer] module. *)
+
+(** {3 Get/set bits}
+
+ These functions let you manipulate individual bits in the
+ bitstring. However they are not particularly efficient and you
+ should generally use the [bitmatch] and [BITSTRING] operators when
+ building and parsing bitstrings.
+
+ These functions all raise [Invalid_argument "index out of bounds"]
+ if the index is out of range of the bitstring.
+*)
+
+val set : bitstring -> int -> unit
+ (** [set bits n] sets the [n]th bit in the bitstring to 1. *)
+
+val clear : bitstring -> int -> unit
+ (** [clear bits n] sets the [n]th bit in the bitstring to 0. *)
+
+val is_set : bitstring -> int -> bool
+ (** [is_set bits n] is true if the [n]th bit is set to 1. *)
+
+val is_clear : bitstring -> int -> bool
+ (** [is_clear bits n] is true if the [n]th bit is set to 0. *)
+
+val put : bitstring -> int -> int -> unit
+ (** [put bits n v] sets the [n]th bit in the bitstring to 1
+ if [v] is not zero, or to 0 if [v] is zero. *)
+
+val get : bitstring -> int -> int
+ (** [get bits n] returns the [n]th bit (returns non-zero or 0). *)
+
+(** {3 Miscellaneous} *)
+
+val package : string
+(** The package name, always ["ocaml-bitstring"] *)
+
+val version : string
+(** The package version as a string. *)
+
+val debug : bool ref
+(** Set this variable to true to enable extended debugging.
+ This only works if debugging was also enabled in the
+ [pa_bitstring.ml] file at compile time, otherwise it
+ does nothing. *)
+
+type endian = BigEndian | LittleEndian | NativeEndian
+
+val string_of_endian : endian -> string
+
+val nativeendian : endian
+
+(**/**)
+
+(* Private functions, called from generated code. Do not use
+ * these directly - they are not safe.
+ *)
+
+(* 'extract' functions are used in bitmatch statements. *)
+
+val extract_bit : string -> int -> int -> int -> bool
+
+val extract_char_unsigned : string -> int -> int -> int -> int
+
+val extract_int_be_unsigned : string -> int -> int -> int -> int
+
+val extract_int_le_unsigned : string -> int -> int -> int -> int
+
+val extract_int_ne_unsigned : string -> int -> int -> int -> int
+
+val extract_int_ee_unsigned : endian -> string -> int -> int -> int -> int
+
+val extract_int32_be_unsigned : string -> int -> int -> int -> int32
+
+val extract_int32_le_unsigned : string -> int -> int -> int -> int32
+
+val extract_int32_ne_unsigned : string -> int -> int -> int -> int32
+
+val extract_int32_ee_unsigned : endian -> string -> int -> int -> int -> int32
+
+val extract_int64_be_unsigned : string -> int -> int -> int -> int64
+
+val extract_int64_le_unsigned : string -> int -> int -> int -> int64
+
+val extract_int64_ne_unsigned : string -> int -> int -> int -> int64
+
+val extract_int64_ee_unsigned : endian -> string -> int -> int -> int -> int64
+
+external extract_fastpath_int16_be_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_be_unsigned" "noalloc"
+
+external extract_fastpath_int16_le_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_le_unsigned" "noalloc"
+
+external extract_fastpath_int16_ne_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_ne_unsigned" "noalloc"
+
+external extract_fastpath_int16_be_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_be_signed" "noalloc"
+
+external extract_fastpath_int16_le_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_le_signed" "noalloc"
+
+external extract_fastpath_int16_ne_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int16_ne_signed" "noalloc"
+
+(*
+external extract_fastpath_int24_be_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_be_unsigned" "noalloc"
+
+external extract_fastpath_int24_le_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_le_unsigned" "noalloc"
+
+external extract_fastpath_int24_ne_unsigned : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_ne_unsigned" "noalloc"
+
+external extract_fastpath_int24_be_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_be_signed" "noalloc"
+
+external extract_fastpath_int24_le_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_le_signed" "noalloc"
+
+external extract_fastpath_int24_ne_signed : string -> int -> int =
"ocaml_bitstring_extract_fastpath_int24_ne_signed" "noalloc"
+*)
+
+external extract_fastpath_int32_be_unsigned : string -> int -> int32 -> int32
= "ocaml_bitstring_extract_fastpath_int32_be_unsigned" "noalloc"
+
+external extract_fastpath_int32_le_unsigned : string -> int -> int32 -> int32
= "ocaml_bitstring_extract_fastpath_int32_le_unsigned" "noalloc"
+
+external extract_fastpath_int32_ne_unsigned : string -> int -> int32 -> int32
= "ocaml_bitstring_extract_fastpath_int32_ne_unsigned" "noalloc"
+
+external extract_fastpath_int32_be_signed : string -> int -> int32 -> int32 =
"ocaml_bitstring_extract_fastpath_int32_be_signed" "noalloc"
+
+external extract_fastpath_int32_le_signed : string -> int -> int32 -> int32 =
"ocaml_bitstring_extract_fastpath_int32_le_signed" "noalloc"
+
+external extract_fastpath_int32_ne_signed : string -> int -> int32 -> int32 =
"ocaml_bitstring_extract_fastpath_int32_ne_signed" "noalloc"
+
+(*
+external extract_fastpath_int40_be_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int40_be_unsigned" "noalloc"
+
+external extract_fastpath_int40_le_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int40_le_unsigned" "noalloc"
+
+external extract_fastpath_int40_ne_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int40_ne_unsigned" "noalloc"
+
+external extract_fastpath_int40_be_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int40_be_signed" "noalloc"
+
+external extract_fastpath_int40_le_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int40_le_signed" "noalloc"
+
+external extract_fastpath_int40_ne_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int40_ne_signed" "noalloc"
+
+external extract_fastpath_int48_be_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int48_be_unsigned" "noalloc"
+
+external extract_fastpath_int48_le_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int48_le_unsigned" "noalloc"
+
+external extract_fastpath_int48_ne_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int48_ne_unsigned" "noalloc"
+
+external extract_fastpath_int48_be_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int48_be_signed" "noalloc"
+
+external extract_fastpath_int48_le_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int48_le_signed" "noalloc"
+
+external extract_fastpath_int48_ne_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int48_ne_signed" "noalloc"
+
+external extract_fastpath_int56_be_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int56_be_unsigned" "noalloc"
+
+external extract_fastpath_int56_le_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int56_le_unsigned" "noalloc"
+
+external extract_fastpath_int56_ne_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int56_ne_unsigned" "noalloc"
+
+external extract_fastpath_int56_be_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int56_be_signed" "noalloc"
+
+external extract_fastpath_int56_le_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int56_le_signed" "noalloc"
+
+external extract_fastpath_int56_ne_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int56_ne_signed" "noalloc"
+*)
+
+external extract_fastpath_int64_be_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int64_be_unsigned" "noalloc"
+
+external extract_fastpath_int64_le_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int64_le_unsigned" "noalloc"
+
+external extract_fastpath_int64_ne_unsigned : string -> int -> int64 -> int64
= "ocaml_bitstring_extract_fastpath_int64_ne_unsigned" "noalloc"
+
+external extract_fastpath_int64_be_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int64_be_signed" "noalloc"
+
+external extract_fastpath_int64_le_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int64_le_signed" "noalloc"
+
+external extract_fastpath_int64_ne_signed : string -> int -> int64 -> int64 =
"ocaml_bitstring_extract_fastpath_int64_ne_signed" "noalloc"
+
+(* 'construct' functions are used in BITSTRING constructors. *)
+val construct_bit : Buffer.t -> bool -> int -> exn -> unit
+
+val construct_char_unsigned : Buffer.t -> int -> int -> exn -> unit
+
+val construct_int_be_unsigned : Buffer.t -> int -> int -> exn -> unit
+
+val construct_int_le_unsigned : Buffer.t -> int -> int -> exn -> unit
+
+val construct_int_ne_unsigned : Buffer.t -> int -> int -> exn -> unit
+
+val construct_int_ee_unsigned : endian -> Buffer.t -> int -> int -> exn -> unit
+
+val construct_int32_be_unsigned : Buffer.t -> int32 -> int -> exn -> unit
+
+val construct_int32_le_unsigned : Buffer.t -> int32 -> int -> exn -> unit
+
+val construct_int32_ne_unsigned : Buffer.t -> int32 -> int -> exn -> unit
+
+val construct_int32_ee_unsigned : endian -> Buffer.t -> int32 -> int -> exn ->
unit
+
+val construct_int64_be_unsigned : Buffer.t -> int64 -> int -> exn -> unit
+
+val construct_int64_le_unsigned : Buffer.t -> int64 -> int -> exn -> unit
+
+val construct_int64_ne_unsigned : Buffer.t -> int64 -> int -> exn -> unit
+
+val construct_int64_ee_unsigned : endian -> Buffer.t -> int64 -> int -> exn ->
unit
+
+val construct_string : Buffer.t -> string -> unit
+
+val construct_bitstring : Buffer.t -> bitstring -> unit
Index: src/utils/bitstring/bitstring_c.c
===================================================================
RCS file: src/utils/bitstring/bitstring_c.c
diff -N src/utils/bitstring/bitstring_c.c
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ src/utils/bitstring/bitstring_c.c 29 Aug 2010 20:17:57 -0000 1.1
@@ -0,0 +1,141 @@
+/* Bitstring library.
+ * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+ *
+ * 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 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in COPYING.LIB.
+ *
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *
+ * $Id: bitstring_c.c,v 1.1 2010/08/29 20:17:57 spiralvoice Exp $
+ */
+
+/* This file contains hand-coded, optimized C implementations of
+ * certain very frequently used functions.
+ */
+
+#include "../../../config/config.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdint.h>
+#if defined(HAVE_BYTESWAP_H)
+#include <byteswap.h>
+#else
+#include "byteswap.h"
+#endif
+
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+
+/* 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.
+ *
+ * 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
+ * (ii) endian: bigendian, littleendian, nativeendian
+ * (iii) signed and unsigned
+ *
+ * XXX Future work: Expand this to 24, 40, 48, 56 bits. This
+ * requires some extra work because sign-extension won't "just happen".
+ */
+
+#ifdef ARCH_BIG_ENDIAN
+#define swap_be(size,v)
+#define swap_le(size,v) v = bswap_##size (v)
+#define swap_ne(size,v)
+#else
+#define swap_be(size,v) v = bswap_##size (v)
+#define swap_le(size,v)
+#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);
\
+ }
+
+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; \
+ }
+
+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)
+
+/* Special care needs to be taken on ARCH_ALIGN_INT64 platforms
+ (hppa and sparc in Debian). */
+
+#ifdef ARCH_ALIGN_INT64
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#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
+
+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)
Index: src/utils/bitstring/bitstring_persistent.mlc4
===================================================================
RCS file: src/utils/bitstring/bitstring_persistent.mlc4
diff -N src/utils/bitstring/bitstring_persistent.mlc4
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ src/utils/bitstring/bitstring_persistent.mlc4 29 Aug 2010 20:17:57
-0000 1.1
@@ -0,0 +1,274 @@
+(* Bitstring persistent patterns.
+ * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+ *
+ * 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 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in COPYING.LIB.
+ *
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *
+ * $Id: bitstring_persistent.mlc4,v 1.1 2010/08/29 20:17:57 spiralvoice Exp $
+ *)
+
+open Printf
+
+open Camlp4.PreCast
+open Syntax
+open Ast
+
+type patt = Camlp4.PreCast.Syntax.Ast.patt
+type expr = Camlp4.PreCast.Syntax.Ast.expr
+type loc_t = Camlp4.PreCast.Syntax.Ast.Loc.t
+
+(* Field. In bitmatch (patterns) the type is [patt field]. In
+ * BITSTRING (constructor) the type is [expr field].
+ *)
+type 'a field = {
+ field : 'a; (* field ('a is either patt or expr) *)
+ flen : expr; (* length in bits, may be non-const *)
+ endian : endian_expr; (* endianness *)
+ signed : bool; (* true if signed, false if unsigned *)
+ t : field_type; (* type *)
+ _loc : Loc.t; (* location in source code *)
+ offset : expr option; (* offset expression *)
+ check : expr option; (* check expression [patterns only] *)
+ bind : expr option; (* bind expression [patterns only] *)
+ save_offset_to : patt option; (* save_offset_to [patterns
only] *)
+}
+and field_type = Int | String | Bitstring (* field type *)
+and endian_expr =
+ | ConstantEndian of Bitstring.endian (* a constant little/big/nativeendian *)
+ | EndianExpr of expr (* an endian expression *)
+
+type pattern = patt field list
+
+type constructor = expr field list
+
+type named = string * alt
+and alt =
+ | Pattern of pattern
+ | Constructor of constructor
+
+(* Work out if an expression is an integer constant.
+ *
+ * Returns [Some i] if so (where i is the integer value), else [None].
+ *
+ * Fairly simplistic algorithm: we can only detect simple constant
+ * expressions such as [k], [k+c], [k-c] etc.
+ *)
+let rec expr_is_constant = function
+ | <:expr< $int:i$ >> -> (* Literal integer constant. *)
+ Some (int_of_string i)
+ | <:expr< $a$ + $b$ >> -> (* Addition of constants. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a+b)
+ | _ -> None)
+ | <:expr< $a$ - $b$ >> -> (* Subtraction. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a-b)
+ | _ -> None)
+ | <:expr< $a$ * $b$ >> -> (* Multiplication. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a*b)
+ | _ -> None)
+ | <:expr< $a$ / $b$ >> -> (* Division. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a/b)
+ | _ -> None)
+ | <:expr< $a$ lsl $b$ >> -> (* Shift left. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a lsl b)
+ | _ -> None)
+ | <:expr< $a$ lsr $b$ >> -> (* Shift right. *)
+ (match expr_is_constant a, expr_is_constant b with
+ | Some a, Some b -> Some (a lsr b)
+ | _ -> None)
+ | _ -> None (* Anything else is not constant. *)
+
+let string_of_field_type = function
+ | Int -> "int"
+ | String -> "string"
+ | Bitstring -> "bitstring"
+
+let patt_printer = function
+ | <:patt< $lid:id$ >> -> id
+ | <:patt< _ >> -> "_"
+ | _ -> "[pattern]"
+
+let rec expr_printer = function
+ | <:expr< $lid:id$ >> -> id
+ | <:expr< $int:i$ >> -> i
+ | <:expr< $lid:op$ $a$ $b$ >> ->
+ sprintf "%s %s %s" op (expr_printer a) (expr_printer b)
+ | _ -> "[expr]"
+
+let _string_of_field { flen = flen;
+ endian = endian; signed = signed; t = t;
+ _loc = _loc;
+ offset = offset; check = check; bind = bind;
+ save_offset_to = save_offset_to } =
+ let flen = expr_printer flen in
+ let endian =
+ match endian with
+ | ConstantEndian endian -> Bitstring.string_of_endian endian
+ | EndianExpr expr -> sprintf "endian(%s)" (expr_printer expr) in
+ let signed = if signed then "signed" else "unsigned" in
+ let t = string_of_field_type t in
+
+ let offset =
+ match offset with
+ | None -> ""
+ | Some expr -> sprintf ", offset(%s)" (expr_printer expr) in
+
+ let check =
+ match check with
+ | None -> ""
+ | Some expr -> sprintf ", check(%s)" (expr_printer expr) in
+
+ let bind =
+ match bind with
+ | None -> ""
+ | Some expr -> sprintf ", bind(%s)" (expr_printer expr) in
+
+ let save_offset_to =
+ match save_offset_to with
+ | None -> ""
+ | Some patt ->
+ match patt with
+ | <:patt< $lid:id$ >> -> sprintf ", save_offset_to(%s)" id
+ | _ -> sprintf ", save_offset_to([patt])" in
+
+ let loc_fname = Loc.file_name _loc in
+ let loc_line = Loc.start_line _loc in
+ let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
+
+ sprintf "%s : %s, %s, %s%s%s%s%s (* %S:%d %d *)"
+ flen t endian signed offset check bind save_offset_to
+ loc_fname loc_line loc_char
+
+let rec string_of_pattern_field ({ field = patt } as field) =
+ sprintf "%s : %s" (patt_printer patt) (_string_of_field field)
+
+and string_of_constructor_field ({ field = expr } as field) =
+ sprintf "%s : %s" (expr_printer expr) (_string_of_field field)
+
+let string_of_pattern pattern =
+ "{ " ^
+ String.concat ";\n " (List.map string_of_pattern_field pattern) ^
+ " }\n"
+
+let string_of_constructor constructor =
+ "{ " ^
+ String.concat ";\n " (List.map string_of_constructor_field constructor) ^
+ " }\n"
+
+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_from_channel = Marshal.from_channel
+
+let named_from_string = Marshal.from_string
+
+let create_pattern_field _loc =
+ {
+ field = <:patt< _ >>;
+ flen = <:expr< 32 >>;
+ endian = ConstantEndian Bitstring.BigEndian;
+ signed = false;
+ t = Int;
+ _loc = _loc;
+ offset = None;
+ check = None;
+ bind = None;
+ save_offset_to = None;
+ }
+
+let set_lident_patt field id =
+ let _loc = field._loc in
+ { field with field = <:patt< $lid:id$ >> }
+let set_int_patt field i =
+ let _loc = field._loc in
+ { field with field = <:patt< $`int:i$ >> }
+let set_string_patt field str =
+ let _loc = field._loc in
+ { field with field = <:patt< $str:str$ >> }
+let set_unbound_patt field =
+ let _loc = field._loc in
+ { field with field = <:patt< _ >> }
+let set_patt field patt = { field with field = patt }
+let set_length_int field flen =
+ let _loc = field._loc in
+ { field with flen = <:expr< $`int:flen$ >> }
+let set_length field flen = { field with flen = flen }
+let set_endian field endian = { field with endian = ConstantEndian endian }
+let set_endian_expr field expr = { field with endian = EndianExpr expr }
+let set_signed field signed = { field with signed = signed }
+let set_type_int field = { field with t = Int }
+let set_type_string field = { field with t = String }
+let set_type_bitstring field = { field with t = Bitstring }
+let set_location field loc = { field with _loc = loc }
+let set_offset_int field i =
+ let _loc = field._loc in
+ { field with offset = Some <:expr< $`int:i$ >> }
+let set_offset field expr = { field with offset = Some expr }
+let set_no_offset field = { field with offset = None }
+let set_check field expr = { field with check = Some expr }
+let set_no_check field = { field with check = None }
+let set_bind field expr = { field with bind = Some expr }
+let set_no_bind field = { field with bind = None }
+let set_save_offset_to field patt = { field with save_offset_to = Some patt }
+let set_save_offset_to_lident field id =
+ let _loc = field._loc in
+ { field with save_offset_to = Some <:patt< $lid:id$ >> }
+let set_no_save_offset_to field = { field with save_offset_to = None }
+
+let create_constructor_field _loc =
+ {
+ field = <:expr< 0 >>;
+ flen = <:expr< 32 >>;
+ endian = ConstantEndian Bitstring.BigEndian;
+ signed = false;
+ t = Int;
+ _loc = _loc;
+ offset = None;
+ check = None;
+ bind = None;
+ save_offset_to = None;
+ }
+
+let set_lident_expr field id =
+ let _loc = field._loc in
+ { field with field = <:expr< $lid:id$ >> }
+let set_int_expr field i =
+ let _loc = field._loc in
+ { field with field = <:expr< $`int:i$ >> }
+let set_string_expr field str =
+ let _loc = field._loc in
+ { field with field = <:expr< $str:str$ >> }
+let set_expr field expr =
+ let _loc = field._loc in
+ { field with field = expr }
+
+let get_patt field = field.field
+let get_expr field = field.field
+let get_length field = field.flen
+let get_endian field = field.endian
+let get_signed field = field.signed
+let get_type field = field.t
+let get_location field = field._loc
+let get_offset field = field.offset
+let get_check field = field.check
+let get_bind field = field.bind
+let get_save_offset_to field = field.save_offset_to
Index: src/utils/bitstring/bitstring_persistent.mli
===================================================================
RCS file: src/utils/bitstring/bitstring_persistent.mli
diff -N src/utils/bitstring/bitstring_persistent.mli
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ src/utils/bitstring/bitstring_persistent.mli 29 Aug 2010 20:17:57
-0000 1.1
@@ -0,0 +1,541 @@
+(** Bitstring persistent patterns. *)
+(* Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+ *
+ * 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 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in COPYING.LIB.
+ *
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *
+ * $Id: bitstring_persistent.mli,v 1.1 2010/08/29 20:17:57 spiralvoice Exp $
+ *)
+
+(**
+ {b Warning:} This documentation is for ADVANCED USERS ONLY.
+ If you are not an advanced user, you are probably looking
+ for {{:Bitstring.html}the Bitstring documentation}.
+
+ {{:#reference}Jump straight to the reference section for
+ documentation on types and functions}.
+
+ {2 Introduction}
+
+ Bitstring allows you to name sets of fields and reuse them
+ elsewhere. For example if you frequently need to parse
+ Pascal-style strings in the form length byte + string, then you
+ could name the [{ strlen : 8 : int; str : strlen*8 : string }]
+ pattern and reuse it everywhere by name.
+
+ These are called {b persistent patterns}.
+
+ The basic usage is:
+
+{v
+(* Create a persistent pattern called 'pascal_string' which
+ * matches Pascal-style strings (length byte + string).
+ *)
+let bitmatch pascal_string =
+ \{ strlen : 8 : int;
+ str : strlen*8 : string }
+
+let is_pascal_string bits =
+ bitmatch bits with
+ | \{ :pascal_string } ->
+ printf "matches a Pascal string %s, len %d bytes\n"
+ str strlen
+v}
+
+ or:
+
+{v
+(* Load a persistent pattern from a file. *)
+open bitmatch "pascal.bmpp"
+
+let is_pascal_string bits =
+ bitmatch bits with
+ | \{ :pascal_string } ->
+ printf "matches a Pascal string %s, len %d bytes\n"
+ str strlen
+v}
+
+ {3 Important notes}
+
+ There are some important things you should know about
+ persistent patterns before you decide to use them:
+
+ 'Persistent' refers to the fact that they can be saved into binary
+ files. However these binary files use OCaml [Marshal] module and
+ depend (sometimes) on the version of OCaml used to generate them
+ and (sometimes) the version of bitstring used. So your build system
+ should rebuild these files from source when your code is rebuilt.
+
+ Persistent patterns are syntactic. They work in the same way
+ as cutting and pasting (or [#include]-ing) code. For example
+ if a persistent pattern binds a field named [len], then any
+ uses of [len] following in the surrounding pattern could
+ be affected.
+
+ Programs which generate and manipulate persistent patterns have to
+ link to camlp4. Since camlp4 in OCaml >= 3.10 is rather large, we
+ have placed this code into this separate submodule, so that
+ programs which just use bitstring don't need to pull in the whole of
+ camlp4. This restriction does not apply to code which only uses
+ persistent patterns but does not generate them. If the distinction
+ isn't clear, use [ocamlobjinfo] to look at the dependencies of your
+ [*.cmo] files.
+
+ Persistent patterns can be generated in several ways, but they
+ can only be {i used} by the [pa_bitstring] syntax extension.
+ This means they are purely compile-time constructs. You
+ cannot use them to make arbitrary patterns and run those
+ patterns (not unless your program runs [ocamlc] to make a [*.cmo]
+ file then dynamically links to the [*.cmo] file).
+
+ {2 Named patterns}
+
+ A named pattern is a way to name a pattern and use it later
+ in the same source file. To name a pattern, use:
+
+ [let bitmatch name = { fields ... } ;;]
+
+ and you can then use the name later on inside another pattern,
+ by prefixing the name with a colon.
+ For example:
+
+ [bitmatch bits with { :name } -> ...]
+
+ You can nest named patterns within named patterns to any depth.
+
+ Currently the use of named patterns is somewhat limited.
+ The restrictions are:
+
+ Named patterns can only be used within the same source file, and
+ the names occupy a completely separate namespace from anything
+ else in the source file.
+
+ The [let bitmatch] syntax only works at the top level. We may
+ add a [let bitmatch ... in] for inner levels later.
+
+ Because you cannot rename the bound identifiers in named
+ patterns, you can effectively only use them once in a
+ pattern. For example, [{ :name; :name }] is legal, but
+ any bindings in the first name would be overridden by
+ the second name.
+
+ There are no "named constructors" yet, but the machinery
+ is in place to do this, and we may add them later.
+
+ {2 Persistent patterns in files}
+
+ More useful than just naming patterns, you can load
+ persistent patterns from external files. The patterns
+ in these external files can come from a variety of sources:
+ for example, in the [cil-tools] subdirectory are some
+ {{:http://cil.sf.net/}Cil-based} tools for importing C
+ structures from header files. You can also generate
+ your own files or write your own tools, as described below.
+
+ To use the persistent pattern(s) from a file do:
+
+ [open bitmatch "filename.bmpp" ;;]
+
+ A list of zero or more {!named} patterns are read from the file
+ and each is bound to a name (as contained in the file),
+ and then the patterns can be used with the usual [:name]
+ syntax described above.
+
+ {3 Extension}
+
+ The standard extension is [.bmpp]. This is just a convention
+ and you can use any extension you want.
+
+ {3 Directory search order}
+
+ If the filename is an absolute or explicit path, then we try to
+ load it from that path and stop if it fails. See the [Filename]
+ module in the standard OCaml library for the definitions of
+ "absolute path" and "explicit path". Otherwise we use the
+ following directory search order:
+
+ - Relative to the current directory
+ - Relative to the OCaml library directory
+
+ {3 bitstring-objinfo}
+
+ The [bitstring-objinfo] command can be run on a file in order
+ to print out the patterns in the file.
+
+ {3 Constructors}
+
+ We haven't implemented persistent constructors yet, although
+ the machinery is in place to make this happen. Any constructors
+ found in the file are ignored.
+
+ {2 Creating your own persistent patterns}
+
+ If you want to write a tool to import bitstrings from an
+ exotic location or markup language, you will need
+ to use the functions found in the {{:#reference}reference section}.
+
+ I will describe using an example here of how you would
+ programmatically create a persistent pattern which
+ matches Pascal-style "length byte + data" strings.
+ Firstly note that there are two fields, so our pattern
+ will be a list of length 2 and type {!pattern}.
+
+ You will need to create a camlp4 location object ([Loc.t])
+ describing the source file. This source file is used
+ to generate useful error messages for the user, so
+ you may want to set it to be the name and location in
+ the file that your tool reads for input. By convention,
+ locations are bound to name [_loc]:
+
+ {v
+ let _loc = Loc.move_line 42 (Loc.mk "input.xml")
+ v}
+
+ Create a pattern field representing a length field which is 8 bits wide,
+ bound to the identifier [len]:
+
+ {v
+ let len_field = create_pattern_field _loc
+ let len_field = set_length_int len_field 8
+ let len_field = set_lident_patt len_field "len"
+ v}
+
+ Create a pattern field representing a string of [len*8] bits.
+ Note that the use of [<:expr< >>] quotation requires
+ you to preprocess your source with [camlp4of]
+ (see {{:http://brion.inria.fr/gallium/index.php/Reflective_OCaml}this
+ page on Reflective OCaml}).
+
+ {v
+ let str_field = create_pattern_field _loc
+ let str_field = set_length str_field <:expr< len*8 >>
+ let str_field = set_lident_patt str_field "str"
+ let str_field = set_type_string str_field
+ v}
+
+ Join the two fields together and name it:
+
+ {v
+ let pattern = [len_field; str_field]
+ let named_pattern = "pascal_string", Pattern pattern
+ v}
+
+ Save it to a file:
+
+ {v
+ let chan = open_out "output.bmpp" in
+ named_to_channel chan named_pattern;
+ close_out chan
+ v}
+
+ You can now use this pattern in another program like this:
+
+ {v
+ open bitmatch "output.bmpp" ;;
+ let parse_pascal_string bits =
+ bitmatch bits with
+ | \{ :pascal_string } -> str, len
+ | \{ _ } -> invalid_arg "not a Pascal string"
+ v}
+
+ You can write more than one named pattern to the output file, and
+ they will all be loaded at the same time by [open bitmatch ".."]
+ (obviously you should give each pattern a different name). To do
+ this, just call {!named_to_channel} as many times as needed.
+
+ {2:reference Reference}
+
+ {3 Types}
+*)
+
+open Camlp4
+
+type patt = Camlp4.PreCast.Syntax.Ast.patt
+type expr = Camlp4.PreCast.Syntax.Ast.expr
+type loc_t = Camlp4.PreCast.Syntax.Ast.Loc.t
+(** Just short names for the camlp4 types. *)
+
+type 'a field
+(** A field in a persistent pattern or persistent constructor. *)
+
+type pattern = patt field list
+(** A persistent pattern (used in [bitmatch] operator), is just a
+ list of pattern fields. *)
+
+type constructor = expr field list
+(** A persistent constructor (used in [BITSTRING] operator), is just a
+ list of constructor fields. *)
+
+type named = string * alt
+and alt =
+ | Pattern of pattern (** Pattern *)
+ | Constructor of constructor (** Constructor *)
+(** A named pattern or constructor.
+
+ The name is used when binding a pattern from a file, but
+ is otherwise ignored. *)
+
+(** {3 Printers} *)
+
+val string_of_pattern : pattern -> string
+val string_of_constructor : constructor -> string
+val string_of_pattern_field : patt field -> string
+val string_of_constructor_field : expr field -> string
+(** Convert patterns, constructors or individual fields
+ into printable strings for debugging purposes.
+
+ The strings look similar to the syntax used by bitmatch, but
+ some things cannot be printed fully, eg. length expressions. *)
+
+(** {3 Persistence} *)
+
+val named_to_channel : out_channel -> named -> unit
+(** Save a pattern/constructor to an output channel. *)
+
+val named_to_string : named -> string
+(** Serialize a pattern/constructor to a string. *)
+
+val named_to_buffer : string -> int -> int -> named -> int
+(** Serialize a pattern/constructor to part of a string, return the length. *)
+
+val named_from_channel : in_channel -> named
+(** Load a pattern/constructor from an output channel.
+
+ Note: This is not type safe. The pattern/constructor must
+ have been written out under the same version of OCaml and
+ the same version of bitstring. *)
+
+val named_from_string : string -> int -> named
+(** Load a pattern/constructor from a string at offset within the string.
+
+ Note: This is not type safe. The pattern/constructor must
+ have been written out under the same version of OCaml and
+ the same version of bitstring. *)
+
+(** {3 Create pattern fields}
+
+ These fields are used in pattern matches ([bitmatch]). *)
+
+val create_pattern_field : loc_t -> patt field
+(** Create a pattern field.
+
+ The pattern is unbound, the type is set to [int], bit length to [32],
+ endianness to [BigEndian], signedness to unsigned ([false]),
+ source code location to the [_loc] parameter, and no offset expression.
+
+ To create a complete field you need to call the [set_*]
+ functions. For example, to create [{ len : 8 : int }]
+ you would do:
+
+{v
+ let field = create_pattern_field _loc in
+ let field = set_lident_patt field "len" in
+ let field = set_length_int field 8 in
+v}
+*)
+
+val set_lident_patt : patt field -> string -> patt field
+(** Sets the pattern to the pattern binding an identifier
+ given in the string.
+
+ The effect is that the field [{ len : 8 : int }] could
+ be created by calling [set_lident_patt field "len"]. *)
+
+val set_int_patt : patt field -> int -> patt field
+(** Sets the pattern field to the pattern which matches an integer.
+
+ The effect is that the field [{ 2 : 8 : int }] could
+ be created by calling [set_int_patt field 2]. *)
+
+val set_string_patt : patt field -> string -> patt field
+(** Sets the pattern field to the pattern which matches a string.
+
+ The effect is that the field [{ "MAGIC" : 8*5 : string }] could
+ be created by calling [set_int_patt field "MAGIC"]. *)
+
+val set_unbound_patt : patt field -> patt field
+(** Sets the pattern field to the unbound pattern (usually written [_]).
+
+ The effect is that the field [{ _ : 8 : int }] could
+ be created by calling [set_unbound_patt field]. *)
+
+val set_patt : patt field -> patt -> patt field
+(** Sets the pattern field to an arbitrary OCaml pattern match. *)
+
+val set_length_int : 'a field -> int -> 'a field
+(** Sets the length in bits of a field to a constant integer.
+
+ The effect is that the field [{ len : 8 : string }] could
+ be created by calling [set_length field 8]. *)
+
+val set_length : 'a field -> expr -> 'a field
+(** Sets the length in bits of a field to an OCaml expression.
+
+ The effect is that the field [{ len : 2*i : string }] could
+ be created by calling [set_length field <:expr< 2*i >>]. *)
+
+val set_endian : 'a field -> Bitstring.endian -> 'a field
+(** Sets the endianness of a field to the constant endianness.
+
+ The effect is that the field [{ _ : 16 : bigendian }] could
+ be created by calling [set_endian field Bitstring.BigEndian]. *)
+
+val set_endian_expr : 'a field -> expr -> 'a field
+(** Sets the endianness of a field to an endianness expression.
+
+ The effect is that the field [{ _ : 16 : endian(e) }] could
+ be created by calling [set_endian_expr field e]. *)
+
+val set_signed : 'a field -> bool -> 'a field
+(** Sets the signedness of a field to a constant signedness.
+
+ The effect is that the field [{ _ : 16 : signed }] could
+ be created by calling [set_signed field true]. *)
+
+val set_type_int : 'a field -> 'a field
+(** Sets the type of a field to [int].
+
+ The effect is that the field [{ _ : 16 : int }] could
+ be created by calling [set_type_int field]. *)
+
+val set_type_string : 'a field -> 'a field
+(** Sets the type of a field to [string].
+
+ The effect is that the field [{ str : 16 : string }] could
+ be created by calling [set_type_string field]. *)
+
+val set_type_bitstring : 'a field -> 'a field
+(** Sets the type of a field to [bitstring].
+
+ The effect is that the field [{ _ : 768 : bitstring }] could
+ be created by calling [set_type_bitstring field]. *)
+
+val set_location : 'a field -> loc_t -> 'a field
+(** Sets the source code location of a field. This is used when
+ pa_bitstring displays error messages. *)
+
+val set_offset_int : 'a field -> int -> 'a field
+(** Set the offset expression for a field to the given number.
+
+ The effect is that the field [{ _ : 8 : offset(160) }] could
+ be created by calling [set_offset_int field 160]. *)
+
+val set_offset : 'a field -> expr -> 'a field
+(** Set the offset expression for a field to the given expression.
+
+ The effect is that the field [{ _ : 8 : offset(160) }] could
+ be created by calling [set_offset_int field <:expr< 160 >>]. *)
+
+val set_no_offset : 'a field -> 'a field
+(** Remove the offset expression from a field. The field will
+ follow the previous field, or if it is the first field will
+ be at offset zero. *)
+
+val set_check : 'a field -> expr -> 'a field
+(** Set the check expression for a field to the given expression. *)
+
+val set_no_check : 'a field -> 'a field
+(** Remove the check expression from a field. *)
+
+val set_bind : 'a field -> expr -> 'a field
+(** Set the bind-expression for a field to the given expression. *)
+
+val set_no_bind : 'a field -> 'a field
+(** Remove the bind-expression from a field. *)
+
+val set_save_offset_to : 'a field -> patt -> 'a field
+(** Set the save_offset_to pattern for a field to the given pattern. *)
+
+val set_save_offset_to_lident : 'a field -> string -> 'a field
+(** Set the save_offset_to pattern for a field to identifier. *)
+
+val set_no_save_offset_to : 'a field -> 'a field
+(** Remove the save_offset_to from a field. *)
+
+(** {3 Create constructor fields}
+
+ These fields are used in constructors ([BITSTRING]). *)
+
+val create_constructor_field : loc_t -> expr field
+(** Create a constructor field.
+
+ The defaults are the same as for {!create_pattern_field}
+ except that the expression is initialized to [0].
+*)
+
+val set_lident_expr : expr field -> string -> expr field
+(** Sets the expression in a constructor field to an expression
+ which uses the identifier.
+
+ The effect is that the field [{ len : 8 : int }] could
+ be created by calling [set_lident_expr field "len"]. *)
+
+val set_int_expr : expr field -> int -> expr field
+(** Sets the expression to the value of the integer.
+
+ The effect is that the field [{ 2 : 8 : int }] could
+ be created by calling [set_int_expr field 2]. *)
+
+val set_string_expr : expr field -> string -> expr field
+(** Sets the expression to the value of the string.
+
+ The effect is that the field [{ "MAGIC" : 8*5 : string }] could
+ be created by calling [set_int_expr field "MAGIC"]. *)
+
+val set_expr : expr field -> expr -> expr field
+(** Sets the expression field to an arbitrary OCaml expression. *)
+
+(** {3 Accessors} *)
+
+val get_patt : patt field -> patt
+(** Get the pattern from a pattern field. *)
+
+val get_expr : expr field -> expr
+(** Get the expression from an expression field. *)
+
+val get_length : 'a field -> expr
+(** Get the length in bits from a field. Note that what is returned
+ is an OCaml expression, since lengths can be non-constant. *)
+
+type endian_expr =
+ | ConstantEndian of Bitstring.endian
+ | EndianExpr of expr
+
+val get_endian : 'a field -> endian_expr
+(** Get the endianness of a field. This is an {!endian_expr} which
+ could be a constant or an OCaml expression. *)
+
+val get_signed : 'a field -> bool
+(** Get the signedness of a field. *)
+
+type field_type = Int | String | Bitstring
+
+val get_type : 'a field -> field_type
+(** Get the type of a field, [Int], [String] or [Bitstring]. *)
+
+val get_location : 'a field -> loc_t
+(** Get the source code location of a field. *)
+
+val get_offset : 'a field -> expr option
+(** Get the offset expression of a field, or [None] if there is none. *)
+
+val get_check : 'a field -> expr option
+(** Get the check expression of a field, or [None] if there is none. *)
+
+val get_bind : 'a field -> expr option
+(** Get the bind expression of a field, or [None] if there is none. *)
+
+val get_save_offset_to : 'a field -> patt option
+(** Get the save_offset_to pattern of a field, or [None] if there is none. *)
Index: src/utils/bitstring/byteswap.h
===================================================================
RCS file: src/utils/bitstring/byteswap.h
diff -N src/utils/bitstring/byteswap.h
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ src/utils/bitstring/byteswap.h 29 Aug 2010 20:17:57 -0000 1.1
@@ -0,0 +1,54 @@
+/* byteswap.h - Byte swapping
+ Copyright (C) 2005, 2007 Free Software Foundation, Inc.
+ Written by Oskar Liljeblad <address@hidden>, 2005.
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program 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 General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+*/
+
+/* NB:
+
+ This file is from Gnulib, and in accordance with the convention
+ there, the real license of this file comes from the module
+ definition. It is really LGPLv2+.
+
+ - RWMJ. 2008/08/23
+*/
+
+#ifndef _GL_BYTESWAP_H
+#define _GL_BYTESWAP_H
+
+/* Given an unsigned 16-bit argument X, return the value corresponding to
+ X with reversed byte order. */
+#define bswap_16(x) ((((x) & 0x00FF) << 8) | \
+ (((x) & 0xFF00) >> 8))
+
+/* Given an unsigned 32-bit argument X, return the value corresponding to
+ X with reversed byte order. */
+#define bswap_32(x) ((((x) & 0x000000FF) << 24) | \
+ (((x) & 0x0000FF00) << 8) | \
+ (((x) & 0x00FF0000) >> 8) | \
+ (((x) & 0xFF000000) >> 24))
+
+/* Given an unsigned 64-bit argument X, return the value corresponding to
+ X with reversed byte order. */
+#define bswap_64(x) ((((x) & 0x00000000000000FFULL) << 56) | \
+ (((x) & 0x000000000000FF00ULL) << 40) | \
+ (((x) & 0x0000000000FF0000ULL) << 24) | \
+ (((x) & 0x00000000FF000000ULL) << 8) | \
+ (((x) & 0x000000FF00000000ULL) >> 8) | \
+ (((x) & 0x0000FF0000000000ULL) >> 24) | \
+ (((x) & 0x00FF000000000000ULL) >> 40) | \
+ (((x) & 0xFF00000000000000ULL) >> 56))
+
+#endif /* _GL_BYTESWAP_H */
Index: src/utils/bitstring/pa_bitstring.mlt
===================================================================
RCS file: src/utils/bitstring/pa_bitstring.mlt
diff -N src/utils/bitstring/pa_bitstring.mlt
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ src/utils/bitstring/pa_bitstring.mlt 29 Aug 2010 20:17:57 -0000
1.1
@@ -0,0 +1,1193 @@
+(* Bitstring syntax extension.
+ * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+ *
+ * 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 of the License, or (at your option) any later version,
+ * with the OCaml linking exception described in COPYING.LIB.
+ *
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *
+ * $Id: pa_bitstring.mlt,v 1.1 2010/08/29 20:17:57 spiralvoice Exp $
+ *)
+
+open Printf
+
+open Camlp4.PreCast
+open Syntax
+open Ast
+
+open Bitstring
+module P = Bitstring_persistent
+
+(* If this is true then we emit some debugging code which can
+ * be useful to tell what is happening during matches. You
+ * also need to do 'Bitstring.debug := true' in your main program.
+ *
+ * If this is false then no extra debugging code is emitted.
+ *)
+let debug = false
+
+(* Hashtable storing named persistent patterns. *)
+let pattern_hash : (string, P.pattern) Hashtbl.t = Hashtbl.create 13
+
+let locfail _loc msg = Loc.raise _loc (Failure msg)
+
+(* Work out if an expression is an integer constant.
+ *
+ * Returns [Some i] if so (where i is the integer value), else [None].
+ *
+ * Fairly simplistic algorithm: we can only detect simple constant
+ * expressions such as [k], [k+c], [k-c] etc.
+ *)
+let rec expr_is_constant = function
+ | <:expr< $int:i$ >> -> (* Literal integer constant. *)
+ Some (int_of_string i)
+ | <:expr< $lid:op$ $a$ $b$ >> ->
+ (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.
+ *)
+ "land", (fun a b -> a land 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
+ (try Some ((List.assoc op ops) a b) with Not_found -> None)
+ | _ -> None)
+ | _ -> None
+
+(* Generate a fresh, unique symbol each time called. *)
+let gensym =
+ let i = ref 1000 in
+ fun name ->
+ incr i; let i = !i in
+ sprintf "__pabitstring_%s_%d" name i
+
+(* Used to keep track of which qualifiers we've seen in parse_field. *)
+type whatset_t = {
+ endian_set : bool; signed_set : bool; type_set : bool;
+ offset_set : bool; check_set : bool; bind_set : bool;
+ save_offset_to_set : bool;
+}
+let noneset = {
+ endian_set = false; signed_set = false; type_set = false;
+ offset_set = false; check_set = false; bind_set = false;
+ save_offset_to_set = false
+}
+
+(* Deal with the qualifiers which appear for a field of both types. *)
+let parse_field _loc field qs =
+ let fail = locfail _loc in
+
+ let whatset, field =
+ match qs with
+ | None -> noneset, field
+ | Some qs ->
+ let check already_set msg = if already_set then fail msg in
+ let apply_qualifier (whatset, field) =
+ 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
+ | "endian", None ->
+ 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
+ | "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"
+ | s, Some _ ->
+ 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
+ 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
+ ) 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
+ ) 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
+ ) else
+ 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
+ * signedness qualifiers are meaningless and must not be set.
+ *)
+ let () =
+ 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
+
+ (* Default endianness, signedness, type if not set already. *)
+ let field =
+ if whatset.endian_set then field else P.set_endian field BigEndian in
+ let field =
+ if whatset.signed_set then field else P.set_signed field false in
+ let field =
+ if whatset.type_set then field else P.set_type_int field in
+
+ field
+
+type functype = ExtractFunc | ConstructFunc
+
+(* Choose the right constructor function. *)
+let build_bitstring_call _loc functype length endian signed =
+ match functype, length, endian, signed with
+ (* XXX The meaning of signed/unsigned breaks down at
+ * 31, 32, 63 and 64 bits.
+ *)
+ | (ExtractFunc, Some 1, _, _) -> <:expr< Bitstring.extract_bit >>
+ | (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
+ 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
+ let t = match len with
+ | 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 ->
+ let endianness = match constant with
+ | BigEndian -> "be"
+ | LittleEndian -> "le"
+ | NativeEndian -> "ne" in
+ let call = sprintf "%s_%s_%s_%s" funcname t endianness sign in
+ <:expr< Bitstring.$lid:call$ >>
+ | P.EndianExpr expr ->
+ let call = sprintf "%s_%s_%s_%s" funcname t "ee" sign in
+ <:expr< Bitstring.$lid:call$ $expr$ >>
+
+(* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
+let output_constructor _loc fields =
+ (* This function makes code to raise a Bitstring.Construct_failure exception
+ * containing a message and the current _loc context.
+ * (Thanks to Bluestorm for suggesting this).
+ *)
+ let construct_failure _loc msg =
+ <: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$)
+ >>
+ in
+ let raise_construct_failure _loc msg =
+ <:expr< raise $construct_failure _loc msg$ >>
+ in
+
+ (* Bitstrings are created like the 'Buffer' module (in fact, using
+ * the Buffer module), by appending snippets to a growing buffer.
+ * This is reasonably efficient and avoids a lot of garbage.
+ *)
+ let buffer = gensym "buffer" in
+
+ (* General exception which is raised inside the constructor functions
+ * when an int expression is out of range at runtime.
+ *)
+ let exn = gensym "exn" in
+ let exn_used = ref false in
+
+ (* Convert each field to a simple bitstring-generating expression. *)
+ let fields = List.map (
+ fun field ->
+ let fexpr = P.get_expr 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
+
+ (* offset(), check(), bind(), save_offset_to() not supported in
+ * constructors.
+ *
+ * Implementation of forward-only offsets is fairly
+ * straightforward: we would need to just calculate the length of
+ * padding here and add it to what has been constructed. For
+ * general offsets, including going backwards, that would require
+ * a rethink in how we construct bitstrings.
+ *)
+ if P.get_offset field <> None then
+ 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";
+ if P.get_bind field <> None then
+ 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";
+
+ (* Is flen an integer constant? If so, what is it? This
+ * is very simple-minded and only detects simple constants.
+ *)
+ let flen_is_const = expr_is_constant flen in
+
+ 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
+
+ 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]"$
+ >>
+
+ (* 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"$
+ >>
+
+ (* 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
+ expr
+ ) fields in
+
+ (* Create the final bitstring. Start by creating an empty buffer
+ * and then evaluate each expression above in turn which will
+ * append some more to the bitstring buffer. Finally extract
+ * the bitstring.
+ *
+ * XXX We almost have enough information to be able to guess
+ * a good initial size for the buffer.
+ *)
+ let fields =
+ match fields with
+ | [] -> <:expr< [] >>
+ | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
+
+ let expr =
+ <:expr<
+ let $lid:buffer$ = Bitstring.Buffer.create () in
+ $fields$;
+ Bitstring.Buffer.contents $lid:buffer$
+ >> in
+
+ if !exn_used then
+ <:expr<
+ let $lid:exn$ = $construct_failure _loc "value out of range"$ in
+ $expr$
+ >>
+ else
+ expr
+
+(* Generate the code for a bitmatch statement. '_loc' is the
+ * location, 'bs' is the bitstring parameter, 'cases' are
+ * the list of cases to test against.
+ *)
+let output_bitmatch _loc bs cases =
+ (* These symbols are used through the generated code to record our
+ * current position within the bitstring:
+ *
+ * data - original bitstring data (string, never changes)
+ * off - current offset within data (int, increments as we move through
+ * the bitstring)
+ * len - current remaining length within data (int, decrements as
+ * we move through the bitstring)
+ *
+ * Also:
+ *
+ * original_off - saved offset at the start of the match (never changes)
+ * original_len - saved length at the start of the match (never changes)
+ * off_aligned - true if the original offset is byte-aligned (allows
+ * us to make some common optimizations)
+ *)
+ let data = gensym "data"
+ and off = gensym "off"
+ and len = gensym "len"
+ and original_off = gensym "original_off"
+ and original_len = gensym "original_len"
+ and off_aligned = gensym "off_aligned"
+
+ (* This is where the result will be stored (a reference). *)
+ and result = gensym "result" in
+
+ (* This generates the field extraction code for each
+ * field in a single case. There must be enough remaining data
+ * in the bitstring to satisfy the field.
+ *
+ * As we go through the fields, symbols 'data', 'off' and 'len'
+ * track our position and remaining length in the bitstring.
+ *
+ * The whole thing is a lot of nested 'if'/'match' statements.
+ * Code is generated from the inner-most (last) field outwards.
+ *)
+ 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 =
+ 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
+
+ (* The fast-path code when everything is aligned. *)
+ let fastpath =
+ <:expr<
+ let o =
+ ($lid:original_off$ lsr 3) + $`int:field_byte_offset$ in
+ Char.code (String.unsafe_get $lid:data$ o)
+ >> in
+
+ <:expr<
+ if $lid:len$ >= 8 then (
+ let v =
+ if $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$ | _ -> ()
+ )
+ >>
+
+ (* 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$
+ | _ -> ()
+ )
+ >>
+
+ (* 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$
+ | _ -> ()
+ )
+ >>
+
+ (* 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$
+ | _ -> ()
+ )
+ >>
+
+ (* 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$
+ )
+ >>
+
+ (* 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
+
+ (* 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
+ in
+
+ (* Convert each case in the match. *)
+ let cases = List.map (
+ 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
+ let inner =
+ match bind with
+ | Some name ->
+ <:expr<
+ let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
+ $inner$
+ >>
+ | None -> inner in
+ output_field_extraction inner (List.rev fields)
+ ) cases in
+
+ (* Join them into a single expression.
+ *
+ * Don't do it with a normal fold_right because that leaves
+ * 'raise Exit; ()' at the end which causes a compiler warning.
+ * Hence a bit of complexity here.
+ *
+ * Note that the number of cases is always >= 1 so List.hd is safe.
+ *)
+ let cases = List.rev cases in
+ let cases =
+ List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
+ (List.hd cases) (List.tl cases) in
+
+ (* The final code just wraps the list of cases in a
+ * try/with construct so that each case is tried in
+ * turn until one case matches (that case sets 'result'
+ * and raises 'Exit' to leave the whole statement).
+ * If result isn't set by the end then we will raise
+ * Match_failure with the location of the bitmatch
+ * statement in the original code.
+ *)
+ let loc_fname = Loc.file_name _loc in
+ let loc_line = string_of_int (Loc.start_line _loc) in
+ let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
+
+ <:expr<
+ (* Note we save the original offset/length at the start of the match
+ * in 'original_off'/'original_len' symbols. 'data' never changes.
+ * This code also ensures that if original_off/original_len/off_aligned
+ * aren't actually used, we don't get a warning.
+ *)
+ let ($lid:data$, $lid:original_off$, $lid:original_len$) = $bs$ in
+ let $lid:off$ = $lid:original_off$ and $lid:len$ = $lid:original_len$ in
+ let $lid:off_aligned$ = $lid:off$ land 7 = 0 in
+ ignore $lid:off_aligned$;
+ let $lid:result$ = ref None in
+ (try
+ $cases$
+ with Exit -> ());
+ match ! $lid:result$ with
+ | Some x -> x
+ | None -> raise (Match_failure ($str:loc_fname$,
+ $int:loc_line$, $int:loc_char$))
+ >>
+
+(* Add a named pattern. *)
+let add_named_pattern _loc name pattern =
+ Hashtbl.add pattern_hash name pattern
+
+(* Expand a named pattern from the pattern_hash. *)
+let expand_named_pattern _loc name =
+ try Hashtbl.find pattern_hash name
+ with Not_found ->
+ locfail _loc (sprintf "named pattern not found: %s" name)
+
+(* Add named patterns from a file. See the documentation on the
+ * directory search path in bitstring_persistent.mli
+let load_patterns_from_file _loc filename =
+ let chan =
+ if Filename.is_relative filename && Filename.is_implicit filename then (
+ (* 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
+ ) else (
+ try open_in filename
+ with exn -> Loc.raise _loc exn
+ ) in
+ let names = ref [] in
+ (try
+ let rec loop () =
+ let name = P.named_from_channel chan in
+ names := name :: !names
+ in
+ loop ()
+ with End_of_file -> ()
+ );
+ close_in chan;
+ let names = List.rev !names in
+ List.iter (
+ function
+ | name, P.Pattern 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
+ *)
+
+EXTEND Gram
+ GLOBAL: expr str_item;
+
+ (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
+ * followed by an optional expression (used in certain cases). Note
+ * that we are careful not to declare any explicit reserved words.
+ *)
+ qualifiers: [
+ [ LIST0
+ [ q = LIDENT;
+ e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
+ SEP "," ]
+ ];
+
+ (* Field used in the bitmatch operator (a pattern). This can actually
+ * return multiple fields, in the case where the 'field' is a named
+ * persitent pattern.
+ *)
+ 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. *)
+ | ":"; name = LIDENT ->
+ expand_named_pattern _loc name (* Named -> list of fields. *)
+ ]
+ ];
+
+ (* Case inside bitmatch operator. *)
+ patt_fields: [
+ [ "{";
+ fields = LIST0 patt_field SEP ";";
+ "}" ->
+ List.concat fields
+ ]
+ ];
+
+ patt_case: [
+ [ fields = patt_fields;
+ bind = OPT [ "as"; name = LIDENT -> name ];
+ whenclause = OPT [ "when"; e = expr -> e ]; "->";
+ code = expr ->
+ (fields, bind, whenclause, code)
+ ]
+ ];
+
+ (* Field used in the BITSTRING constructor (an expression). *)
+ 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
+ ]
+ ];
+
+ constr_fields: [
+ [ "{";
+ fields = LIST0 constr_field SEP ";";
+ "}" ->
+ fields
+ ]
+ ];
+
+ (* 'bitmatch' expressions. *)
+ expr: LEVEL ";" [
+ [ "bitmatch";
+ bs = expr; "with"; OPT "|";
+ cases = LIST1 patt_case SEP "|" ->
+ output_bitmatch _loc bs cases
+ ]
+
+ (* Constructor. *)
+ | [ "BITSTRING";
+ fields = constr_fields ->
+ output_constructor _loc fields
+ ]
+ ];
+
+ (* Named persistent patterns.
+ *
+ * NB: Currently only allowed at the top level. We can probably lift
+ * this restriction later if necessary. We only deal with patterns
+ * at the moment, not constructors, but the infrastructure to do
+ * constructors is in place.
+ *)
+ str_item: LEVEL "top" [
+ [ "let"; "bitmatch";
+ name = LIDENT; "="; fields = patt_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< >>
+ *)
+ ]
+ ];
+
+END
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Mldonkey-commits] mldonkey config/Makefile.in config/configure.in...,
mldonkey-commits <=