diff --git a/server/Makefile b/server/Makefile index e36d5b5..f9a5c61 100644 --- a/server/Makefile +++ b/server/Makefile @@ -2,28 +2,11 @@ APP=hop_server TEMPLATES=$(wildcard web/bootstrap/templates/*.xml) HTML=$(subst web/bootstrap/templates/,web/,$(subst .xml,.html,$(TEMPLATES))) -# Augment the path ocamlfind uses to discover installed packages. -OCAMLPATH=$(CURDIR)/thirdparty/_dist -export OCAMLPATH - -LWT_SRC_DIR=thirdparty/lwt-2.3.2 - all: \ - thirdparty/_dist \ message.ml amqp_spec.ml \ $(APP).native \ webpages -thirdparty/_dist: - mkdir -p $@ - (mkdir $@/lwt && \ - (cd $(LWT_SRC_DIR) && \ - ./configure && \ - make && \ - OCAMLFIND_LDCONF=ignore \ - OCAMLFIND_DESTDIR="$(CURDIR)/$@" \ - make install)) - webpages: $(HTML) web/bootstrap/css/bootstrap.css web/bootstrap/css/bootstrap.css: web/bootstrap/less/*.less @@ -46,22 +29,17 @@ clean: webclean rm -f message.ml rm -f amqp_spec.ml -thirdpartyclean: - rm -rf thirdparty/_dist - rm -rf $(LWT_SRC_DIR)/_build - rm -f $(LWT_SRC_DIR)/setup.data - rm -f $(LWT_SRC_DIR)/setup.log - rm -f $(LWT_SRC_DIR)/src/unix/lwt_config.h - rm -f $(LWT_SRC_DIR)/src/unix/lwt_config.ml - -veryclean: clean thirdpartyclean +veryclean: clean rm -f web/bootstrap/css/bootstrap.css -$(APP).native: $(wildcard *.ml) - ocamlbuild -use-ocamlfind -X thirdparty -X scratch $@ +$(APP).native: $(wildcard *.ml) lwt_installed + ocamlbuild -use-ocamlfind -X scratch $@ -$(APP).p.native: $(wildcard *.ml) - ocamlbuild -use-ocamlfind -X thirdparty -X scratch $@ +$(APP).p.native: $(wildcard *.ml) lwt_installed + ocamlbuild -use-ocamlfind -X scratch $@ + +lwt_installed: + opam install lwt run: all ./$(APP).native diff --git a/server/thirdparty/lwt-2.3.2/CHANGES b/server/thirdparty/lwt-2.3.2/CHANGES deleted file mode 100644 index 72a9c36..0000000 --- a/server/thirdparty/lwt-2.3.2/CHANGES +++ /dev/null @@ -1,198 +0,0 @@ -===== 2.3.2 (2011-11-04) ===== - - * Add location informations in logs: - ** allow loggers to get the current location through local storage - ** pass current location to logging functions - ** pass the current location with the syntax extension - * Add Lwt.on_termination - * Add Lwt_unix.reinstall_signal_handler - * Add Lwt_io.flush_all - * Add assert_lwt keyword to the syntax extension - * Add Lwt.wrap - * Add Lwt_glib.iter and Lwt_glib.wakeup - * ocaml 3.13 ready - * Allow to compile without libev support - * Fix bugs in Lwt_io - * Better handling of forks - * Fix many problems on Windows - -===== 2.3.1 (2011-07-13) ===== - - * Fix building of documentation when using the tarball - * Add Lwt_unix.fsync and Lwt_unix.fdatasync - * Fix the stubs for Lwt_unix.send_msg when fd-passing is not - available - * Add -lwt-sequence-strict option to the syntax extension - * Use a custom PRNG state for Lwt.choose and Lwt.pick - * Fix a display glitch when starting the toplevel - * Add Lwt_unix.fork which should now be used when one want to use - Lwt in the child process - * Better implementation of Lwt_unix.readlink and - Lwt_unix.gethostbyname, which fixes compilation on Hurd - * Add Lwt.wakeup_later and Lwt.wakeup_later_exn to be used when one - need to do lot of nested wakeup, which fixes a buffer overflow in - Lwt_mutex - * Fix Lwt_unix.abort and Lwt_unix.close (threads was never wakeup) - * Fix Lwt_throttle for correct timings - * Fix subtle use of cancel - -===== 2.3.0 (2011-04-12) ===== - - * Add an extensible system of engines to: - ** allow the user to replace libev by another event system, such - as select - ** allow easier integration of external libraries supporting - asynchronous operations - * Lots of improvements for windows: - ** use the ocaml select instead of libev by default on windows - ** make asynchronous operations on non-socket file descriptors - such as pipes to work - ** make glib integration to work - * Better use of engines in Lwt_unix: now events are cached to minimize - the amount of calls to epoll_ctl - * Use an eventfd when possible for notifications for faster delivery - * Add modules: - ** Lwt_sys: allow to test availability of extra features - ** Lwt_react: replace Lwt_event and Lwt_signal - * Allow to configure logging rules at runtime in Lwt_log - * Add match_lwt and while_lwt to the syntax extension - * Fixes: - ** syntax extension: handle "lwt ... = ... in ..." at toplevel - ** make the notification system fork-proof - ** fix an issue with stubs not raising correctly exceptions - -===== 2.2.1 (2011-01-26) ===== - - * Better interaction with Js_of_ocaml. - * Add functions {{{Lwt.register_pause_notifier}}} and {{{Lwt.paused_count}}}. - -===== 2.2.0 (2010-12-13) ===== - - * Bugfixes: - ** Fix a bug with cancellable threads causing {{{Canceled}}} - exceptions to be raised randomly - ** Fix a fd-leak in Lwt_io.open_connection - * {{{Lwt_unix}}} now use libev instead of select - * Add thread local storage support to {{{Lwt}}} - * Add backtrace support to {{{Lwt}}}. Now {{{Lwt}}} exceptions can - be recored by using the syntax extension with the {{{-lwt-debug}}} - command line switch. - * Allow blocking system calls to be executed in parallels - * Change the type of many functions of {{{Lwt_unix}}}, which now - return a {{{Lwt}}} thread - * Add functions {{{Lwt_unix.readable}}} and {{{Lwt_unix.writable}}} - * Add function {{{Lwt_io.is_busy}}} - * Add functions {{{Lwt_event.delay}}} and {{{Lwt_signal.delay}}} - * Add function {{{Lwt_term.render_update}}} - * Add function {{{Lwt_ssl.embed_socket}}} - * Add module {{{Lwt_bytes}}} defining operations on bigarrays - instead of strings - * Use bigarrays in Lwt_io instead of strings for the internal buffer. - Lwt_io.make now takes a function that uses a bigarray. - * Add module {{{Lwt_switch}}} - -===== 2.1.1 (2010-06-13) ===== - - * Many bugfixes, including: - ** buggy behaviour of cancellable threads - ** file descriptor leakage in {{{Lwt_unix.accept_n}}} - * Add {{{Lwt.nchoose}}} and {{{Lwt.npick}}} - * Use {{{set_close_on_exec}}} for fds created by {{{Lwt_log}}} - * Better implementation of lwtized react functions - -===== 2.1.0 (2010-04-19) ===== - - * Rename {{{Lwt.select}}} to {{{Lwt.pick}}} - * Removing module {{{Lwt_monitor}}} in favour of {{{Lwt_mutex}}} and - new module {{{Lwt_condition}}} - * More react helpers: - ** {{{Lwt_event.next}}} - ** {{{Lwt_event.limit}}} and {{{Lwt_signal.limit}}} - ** {{{Lwt_event.from}}} - * Adding function {{{Lwt_main.fast_yield}}} - * Adding unit tests - * Optimisation of {{{Lwt}}} - * Adding module {{{Lwt_log}}} for logging - * Adding a camlp4 filter for remmoving logging statement or inlining - tests - * Adding module {{{Lwt_daemon}}} - * Adding function {{{Lwt_unix.recv_msg}}} and {{{Lwt_unix.send_msg}}} - * Adding function {{{Lwt_unix.wait4}}} - * Adding function {{{Lwt_io.establish_server}}} - * Adding module {{{Lwt_list}}} - * Enhancement in {{{Lwt_process}}}, it now support redirections and - timeouts - * Allow to use {{{select}}} on arbitrary high file descriptors - * More commands and features in {{{Lwt_read_line}}}: - ** Handle "undo" command - ** New controlable read-lines instances - ** More edition commands - ** Completion as you type - ** Backward search - * Enhancement in {{{Lwt_term}}}: more drawing functions and allow to - put the terminal into drawing mode - * Optimisation of {{{Lwt_stream}}} - * Optimisation of {{{Lwt_io.write_char}}} and {{{Lwt_io.read_char}}} - * Bugfix of {{{Lwt_stream}}}: two parallel {{{Lwt_stream.get}}} - returned the same value - * Bugfix in {{{Lwt_unix.connect}}}: it returned immediatly on EINPROGRESS - * Bugfixes in {{{Lwt_glib}}}: file descriptors were not monitored correctly - -===== 2.0.0 (2009-10-15) ===== - - * Adding modules: - ** {{{Lwt_stream}}}: lwt-aware version of the {{{Stream}}} module - ** {{{Lwt_gc}}} for using {{{finalise}}} without - {{{Lwt_unix.run}}} - ** {{{Lwt_io}}}: a new implementation of buffered channels with - more features and better handling of concurrent access - ** {{{Lwt_text}}}: implementation of text channels - ** {{{Lwt_process}}}: helpers to spawn processes and communicate - with them - ** {{{Lwt_main}}} for abstracting the main loop and allowing - replacement by a custom main loop - ** {{{Lwt_glib}}} for integration into the glib main event loop - ** {{{Lwt_term}}} for interaction with the terminal - ** {{{Lwt_read_line}}} for interactive user input - ** {{{Lwt_monitor}}}, {{{Lwt_mvar}}}: combined locks for - synchronization with conditional variables for notification - ** {{{Lwt_throttle}}} for limiting rate of execution - (e.g. for authentication procedure) - ** {{{Lwt_sequence}}}: mutable sequence of elements - ** {{{Lwt_event}}}, {{{Lwt_signal}}}: helpers for reactive - programming with lwt - * Adding a syntax extension {{{pa_lwt}}}: - ** handles anonymous bind {{{a >> b}}} - ** adds syntactic sugar for catching errors (ticket #6) - ** adds syntactic sugar for parallel let-binding construction - ** adds syntactic sugar for for-like loops - * Top-level integration: - ** threads can runs while reading user input - ** line editing support - * New enhanced OCaml toplevel with some basic completion features - * Adding C stubs to reimplement {{{Unix.read}}} and {{{Unix.write}}} - with assumption of non-blocking behaviour - * Adding more functions/helpers in {{{Lwt}}} - * Fixing memory leaks in {{{Lwt.choose}}} - * Bugfix in {{{Lwt_chan.close_*}}} (ticket #66) - * Separate the type of threads (covariant) from the type of thread - wakeners (contravariant); the type of many functions related to - {{{Lwt.wait}}} has been changed - * Add cancelable threads - * Unix-dependent part is now put in its own archive and findlib - package. - -===== 1.1.0 (2008-06-25) ===== - - * Adding module {{{Lwt_pool}}} for creating pools (for example pools - of connections) - * Adding a few functions in {{{Lwt_chan}}} - * Fixing bugs in {{{Lwt_util.map_serial}}} and - {{{Lwt_util.iter_serial}}} - * Putting {{{Lwt_preemptive}}}, {{{Lwt_lib}}} and {{{Lwt_ssl}}} in - separate libraries and findlib subpackages so that lwt.cma depends - only on unix.cma. - -===== 1.0.0 (and before) ===== - - * See Ocsigen changelog diff --git a/server/thirdparty/lwt-2.3.2/CHANGES.darcs b/server/thirdparty/lwt-2.3.2/CHANGES.darcs deleted file mode 100644 index 6f05076..0000000 --- a/server/thirdparty/lwt-2.3.2/CHANGES.darcs +++ /dev/null @@ -1,2248 +0,0 @@ -Fri Nov 4 14:52:56 CET 2011 chambart@crans.org - tagged 2.3.2 - -Fri Nov 4 14:52:20 CET 2011 chambart@crans.org - * Update CHANGES and version - -Fri Oct 28 23:29:41 CEST 2011 Jeremie Dimino - * explain that one need to call Lwt_main.run in a Lwt program in the manual - -Mon Oct 10 17:22:32 CEST 2011 gregoire.henry@pps.jussieu.fr - * Doc: add menu.wiki - -Thu Sep 22 14:33:38 CEST 2011 Jeremie Dimino - * use a monospace font in the gtk example - -Thu Sep 22 14:28:18 CEST 2011 Jeremie Dimino - * add a gtk example - -Thu Sep 22 12:57:56 CEST 2011 Jeremie Dimino - * make the documentation of Lwt_glib more explicit - -Wed Sep 21 14:26:02 CEST 2011 Jeremie Dimino - * add Lwt_glib.wakeup - -Wed Sep 21 02:05:29 CEST 2011 Jeremie Dimino - * acquire the context in Lwt_glib.iter - -Wed Sep 21 01:04:31 CEST 2011 Jeremie Dimino - * fix compilation of lwt.glib with msvc - -Tue Sep 20 23:43:07 CEST 2011 Jeremie Dimino - * fix compilation of lwt.glib on windows - -Tue Sep 20 23:22:49 CEST 2011 Jeremie Dimino - * add Lwt_glib.iter - -Mon Sep 19 23:29:12 CEST 2011 Jeremie Dimino - * fix Lwt_unix.connect on Windows - -Mon Sep 19 23:26:13 CEST 2011 Jeremie Dimino - * fix the use of socket on Windows - - Testing whether a file descriptor is a socket with Unix.fstat does not - work on Windows: - - # let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0;; - val sock : Unix.file_descr = - # Unix.fstat sock;; - val Unix.stats = { Unix.st_kind = Unix.S_REG; ... - -Mon Sep 19 21:49:48 CEST 2011 Jeremie Dimino - * cleanup examples - -Mon Sep 19 19:27:42 CEST 2011 Jeremie Dimino - * do not use pthread on windows - -Mon Sep 19 16:12:18 CEST 2011 Jeremie Dimino - * fix compilation with msvc tools - - The Microsoft compiler does not allow to mix variable definition and - code. - -Mon Sep 19 15:48:11 CEST 2011 Jeremie Dimino - * handle compilers that prints things on stdout in discover.ml - -Thu Sep 15 15:28:05 CEST 2011 Jeremie Dimino - * add Lwt.wrap - -Thu Sep 15 14:23:35 CEST 2011 Jeremie Dimino - * make assert_lwt to work - -Thu Sep 15 14:14:48 CEST 2011 Jeremie Dimino - * add the assert_lwt keyword in pa_lwt - -Wed Sep 7 13:46:26 CEST 2011 Jeremie Dimino - * remove ev.h from glib stubs (not used) - -Wed Sep 7 13:29:17 CEST 2011 Jeremie Dimino - * allow to compile without libev support - -Mon Aug 22 21:49:31 CEST 2011 Jeremie Dimino - * add a note for compiling the toplevel - -Mon Aug 22 21:25:23 CEST 2011 Jeremie Dimino - * fix compilation of lwt.text with ocaml >= 3.13 - -Mon Aug 15 22:44:08 CEST 2011 Jeremie Dimino - * add type annotations in Lwt_io for ocaml 3.13 - -Mon Aug 15 17:16:42 CEST 2011 Jeremie Dimino - * reset the job system after a fork - -Mon Aug 15 16:10:28 CEST 2011 Jeremie Dimino - * cancel jobs after a fork - -Mon Aug 15 10:31:16 CEST 2011 Jeremie Dimino - * add Lwt_io.flush_all - -Mon Aug 15 10:31:00 CEST 2011 Jeremie Dimino - * add Lwt.on_termination - -Fri Aug 12 16:29:29 CEST 2011 Jeremie Dimino - * add Lwt_unix.reinstall_signal_handler - -Wed Aug 10 19:06:06 CEST 2011 Jeremie Dimino - * fix ticket #169 - -Thu Aug 4 11:03:48 CEST 2011 Jeremie Dimino - * enable location in logs - - - allow loggers to get the current location through local storage - - pass current location to logging functions - - pass the current location with the syntax extension - -Wed Aug 3 20:20:20 CEST 2011 Jeremie Dimino - * use a GADT for the type of channels with ocaml 3.13 - -Thu Jul 28 22:48:06 CEST 2011 Stephane Glondu - * Avoid unused-but-set-variable GCC warning - -Thu Jul 28 11:52:12 CEST 2011 chambart@crans.org - * fix data corruption in Lwt_io. - -Mon Jul 18 16:57:31 CEST 2011 Jeremie Dimino - * fix a race condition in Lwt_io - -Wed Jul 13 19:05:38 CEST 2011 chambart@crans.org - tagged 2.3.1 - -Wed Jul 13 19:03:50 CEST 2011 chambart@crans.org - * update licence file (add text of BSD license) - -Wed Jul 13 18:40:59 CEST 2011 chambart@crans.org - * version 2.3.1 - -Wed Jul 13 18:38:40 CEST 2011 chambart@crans.org - * update CHANGES - -Wed Jul 13 18:30:27 CEST 2011 michaell.laporte@gmail.com - * Add license in test/core files - -Wed Jul 13 11:36:31 CEST 2011 Jeremie Dimino - * typo in the doc - -Tue Jul 12 18:24:01 CEST 2011 Jeremie Dimino - * add a cancel test - -Tue Jul 12 18:21:57 CEST 2011 Jeremie Dimino - * make Lwt.get_cancel tail-recursive - -Tue Jul 12 16:39:02 CEST 2011 Jeremie Dimino - * implement union-find for cancel functions - -Tue Jul 12 13:41:25 CEST 2011 Jeremie Dimino - * fix a recursive call in Lwt.cancel_and_nth_ready - -Sat Jul 2 21:05:40 CEST 2011 Jeremie Dimino - * simplify setup.ml - -Sat Jul 2 12:43:45 CEST 2011 Jeremie Dimino - * keep setup.ml for the customization - -Thu Jun 30 16:43:24 CEST 2011 Jeremie Dimino - * update CHANGES - -Thu Jun 9 13:25:57 CEST 2011 chambart@crans.org - * rewrite Lwt_throttle - -Thu Jun 30 15:58:44 CEST 2011 Jeremie Dimino - * do not use Lwt_engine.fake_io anymore in Lwt_unix - -Thu Jun 30 15:54:02 CEST 2011 Jeremie Dimino - * fix Lwt_unix.abort - -Fri Jun 24 21:06:12 CEST 2011 Jeremie Dimino - * use more Lwt.wakeup_later - -Sat Jun 18 18:36:24 CEST 2011 Jeremie Dimino - * remove oasis files from the repository - -Sat Jun 18 16:36:31 CEST 2011 Jeremie Dimino - * change the implementation of Lwt.wakeup_later{,_exn} - -Sat Jun 18 16:17:56 CEST 2011 Jeremie Dimino - * add Lwt.wakeup_later{,_exn} and use it in Lwt_mutex - -Wed Jun 15 10:31:03 CEST 2011 Stephane Glondu - * Fix link order in library detection test - - The wrong link order was causing a build failure on Ubuntu, where the - linker is stricter. - -Fri Jun 10 19:08:01 CEST 2011 Jeremie Dimino - * fix some size_t problems - -Fri Jun 10 13:53:22 CEST 2011 Nicolas Dandrimont - * Use a dynamically-allocated buffer for readlink and gethostname - - This allows the use of readlink and gethostname on systems without a - size limit on their return values (e.g. Hurd). - -Tue May 31 20:18:09 CEST 2011 Jeremie Dimino - * use Lwt_unix.fork in Lwt_process and Lwt_daemon - -Tue May 31 20:13:15 CEST 2011 Jeremie Dimino - * do not run exit hooks in the parent process when daemonizing - -Mon May 30 16:48:16 CEST 2011 Jeremie Dimino - * add Lwt_unix.fork - -Mon May 30 14:04:11 CEST 2011 Jeremie Dimino - * use oasis 0.2.1 - -Mon May 30 14:02:49 CEST 2011 Jeremie Dimino - * handle EINTR in the notification system - -Fri May 27 09:45:37 CEST 2011 Jeremie Dimino - * fix compilation on hurd - -Tue May 17 18:24:03 CEST 2011 Jeremie Dimino - * flush after displaying the message in the toplevel - -Fri May 13 20:29:21 CEST 2011 Jeremie Dimino - * use a custom PRNG state for Lwt.choose and Lwt.pick - -Thu May 5 18:19:10 CEST 2011 raphael proust - * Added -lwt-sequence-strict option to syntax extension - -Wed May 4 10:38:57 CEST 2011 raphael proust - * typo in Lwt_log doc - -Thu May 5 16:54:51 CEST 2011 Jeremie Dimino - * typo in the stubs for Lwt_unix.send_msg - - n_fds was not initialized correctly. - -Mon Apr 25 20:12:42 CEST 2011 Jeremie Dimino - * allow to compile without fdatasync - -Fri Apr 22 13:54:52 CEST 2011 Jeremie Dimino - * add Lwt_unix.{fsync,fdatasync} - -Thu Apr 21 10:39:49 CEST 2011 Jeremie Dimino - * ensure that all events are cleared before closing a file descriptor - -Wed Apr 20 08:46:54 CEST 2011 Jeremie Dimino - * 'make clean' in manual/ remove manual-wiki.tex - -Mon Apr 18 21:38:26 CEST 2011 Jeremie Dimino - * do not remove manual-wiki.tex from the tarball - -Tue Apr 12 17:03:02 CEST 2011 chambart@crans.org - * Add link to download the pdf manual in the doc - -Tue Apr 12 16:34:19 CEST 2011 chambart@crans.org - * lift apiref-intro headers levels - -Tue Apr 12 15:53:39 CEST 2011 Jeremie Dimino - tagged 2.3.0 - -Tue Apr 12 15:53:23 CEST 2011 Jeremie Dimino - * version 2.3.0 - -Tue Apr 12 15:43:18 CEST 2011 Jeremie Dimino - * typo - -Tue Apr 12 15:37:43 CEST 2011 Jeremie Dimino - * update CHANGES - -Sun Apr 10 18:51:47 CEST 2011 Jeremie Dimino - * fix ocamldoc comment - -Sat Apr 9 14:36:35 CEST 2011 Jeremie Dimino - * add match_lwt and while_lwt to the manual - -Sat Apr 9 13:42:29 CEST 2011 Jeremie Dimino - * allow to add rules for logging levels in Lwt_log - -Thu Apr 7 18:12:59 CEST 2011 Jeremie Dimino - * handle the case when eventfd is present at compilation time but not supported by the system - -Thu Apr 7 17:32:50 CEST 2011 Jeremie Dimino - * register a printer for unix errors - -Wed Apr 6 18:08:31 CEST 2011 Jeremie Dimino - * include Lwt_io.{LE/BE} into Lwt_io according to the system byte order - -Sun Apr 3 00:37:37 CEST 2011 Jeremie Dimino - * add Lwt.nchoose_split - -Sat Apr 2 23:16:23 CEST 2011 Jeremie Dimino - * cleanup events when they are no more used in Lwt_unix - -Sat Apr 2 18:01:55 CEST 2011 Jeremie Dimino - * handle "lwt ... = ... in ..." at toplevel in the syntax extension - -Thu Mar 31 15:34:35 CEST 2011 Jeremie Dimino - * try to minimize the amount of calls to epoll_ctl by caching engine events - -Thu Mar 31 12:10:41 CEST 2011 Jeremie Dimino - * make the notification system fork-proof - -Tue Mar 29 15:54:53 CEST 2011 Jeremie Dimino - * add the >= 3.12 constraint in _oasis - -Tue Mar 29 11:37:57 CEST 2011 Jeremie Dimino - * fix the syntax extension for while_lwt and match_lwt - -Mon Mar 28 21:37:45 CEST 2011 Jeremie Dimino - * allow to omit the pattern in logging rules - - So we can write LWT_LOG=debug instead of LWT_LOG='* -> debug' - -Fri Mar 25 09:17:24 CET 2011 Jeremie Dimino - * build and install cmxs - -Tue Mar 22 16:00:57 CET 2011 Jeremie Dimino - * copy Unix types into Lwt_unix - - This is for better detection of changes in Unix types since bindings - depends on their representations. - -Tue Mar 22 08:47:37 CET 2011 Jeremie Dimino - * make the "push and GC" test to work in bytecode - -Mon Mar 21 13:34:35 CET 2011 Jeremie Dimino - * typo in the external for sendto - -Wed Mar 16 11:44:20 CET 2011 Jeremie Dimino - * add reporting functions - -Tue Mar 15 17:14:25 CET 2011 Jeremie Dimino - * replace Lwt_react.{E,S}.notify* by Lwt_react.{E,S}.keep - -Fri Mar 11 11:18:15 CET 2011 Jeremie Dimino - * add match_lwt and while_lwt to the syntax extension - -Fri Mar 11 10:55:43 CET 2011 Jeremie Dimino - * update the manual about lwt.react - -Fri Mar 11 10:49:28 CET 2011 Jeremie Dimino - * add lwt.syntax and lwt.syntax.log the the API documentation - -Fri Mar 11 10:45:41 CET 2011 Jeremie Dimino - * update apiref-intro for lwt.react - -Thu Mar 10 17:54:52 CET 2011 Jeremie Dimino - * reimplement Lwt_{event,signal} on top of Lwt_react - -Thu Mar 10 16:21:53 CET 2011 Jeremie Dimino - * add module Lwt_react - - - Reimplements React's Lwtised primitives in a simpler way. - - Changes the API of signals, now map_s and co returns a thread instead - of taking an initial value. The experience shows that it is more - suitable. - - Removes notify* functions and replaces them by always_notify* functions. - Id are useless, it is sufficient to use directly signals and events instead. - -Thu Mar 10 12:02:34 CET 2011 Jeremie Dimino - * add Lwt.on_{success,failure} - -Thu Mar 10 11:57:00 CET 2011 Jeremie Dimino - * fix local storage handling in Lwt.on_cancel - -Thu Mar 3 21:59:43 CET 2011 Jeremie Dimino - * remove "noalloc" from stubs that may raise exceptions - -Tue Feb 22 22:09:11 CET 2011 Jeremie Dimino - * fix the unix job for Lwt_bytes.{read,write} on windows - -Wed Feb 16 16:22:03 CET 2011 chambart@crans.org - * add getsockname getpeername to Lwt_ssl - -Fri Feb 11 14:25:30 CET 2011 chambart@crans.org - * Lwt_stream: avoid memory leak from create - in let push,stream = create () - push no longer keep a reference to data in the stream - - -Mon Feb 14 20:21:54 CET 2011 Jeremie Dimino - * remove all exit hooks when an execvp fails - -Mon Feb 14 11:52:31 CET 2011 Jeremie Dimino - * add manual build files to the boring file - -Mon Feb 14 11:44:16 CET 2011 Jeremie Dimino - * add a boring file - -Sun Feb 13 19:00:25 CET 2011 Jeremie Dimino - * put text stubs into src/text - -Sun Feb 13 00:35:53 CET 2011 Jeremie Dimino - * fix Lwt_unix.get_cpu - -Sun Feb 13 00:33:28 CET 2011 Jeremie Dimino - * allow to integrate lwt into glib instead of glib of lwt - - Because glib into lwt does not works under windows - -Sat Feb 12 23:17:39 CET 2011 Jeremie Dimino - * add Lwt_sys to apiref-intro - -Sat Feb 12 18:07:23 CET 2011 Jeremie Dimino - * use optcomp - -Sat Feb 12 16:01:47 CET 2011 Jeremie Dimino - * add module Lwt_sys - -Fri Feb 11 23:40:09 CET 2011 Jeremie Dimino - * typos - -Fri Feb 11 22:09:33 CET 2011 Jeremie Dimino - * add Lwt_unix.have - -Fri Feb 11 14:34:31 CET 2011 Jeremie Dimino - * use the code plugin in the manual and add colors - -Fri Feb 11 09:10:28 CET 2011 Jeremie Dimino - * typo - -Fri Feb 11 09:01:59 CET 2011 Jeremie Dimino - * remove obsolete doc about C stubs - -Fri Feb 11 08:56:32 CET 2011 Jeremie Dimino - * use code plugins in the manual - -Fri Feb 11 08:19:45 CET 2011 Jeremie Dimino - * use rubber for creating the pdf - -Fri Feb 11 00:51:02 CET 2011 Jeremie Dimino - * convert the doc to wikicreole - -Thu Feb 10 21:35:41 CET 2011 Jeremie Dimino - * ensure that glib main loop functions are called in the right order - -Thu Feb 10 17:55:16 CET 2011 Jeremie Dimino - * lwt.glib enhancement - -Thu Feb 10 14:49:46 CET 2011 Jeremie Dimino - * add -L/-I flags also for lwt.glib - -Thu Feb 10 14:33:08 CET 2011 Jeremie Dimino - * use a pair of socket for notifications on windows - -Thu Feb 10 14:14:54 CET 2011 Jeremie Dimino - * fix windows stubs - -Thu Feb 10 13:54:03 CET 2011 Jeremie Dimino - * better fd blocking detection on windows - -Thu Feb 10 12:52:35 CET 2011 Jeremie Dimino - * implement more stubs on windows - -Thu Feb 10 11:54:06 CET 2011 Jeremie Dimino - * use a byte plugin for compilling examples - - For better portability - -Thu Feb 10 11:50:36 CET 2011 Jeremie Dimino - * search for headers in a list of predefined directories - - It is for better integration with Windows and MacOS - -Thu Feb 10 10:10:05 CET 2011 Jeremie Dimino - * enhancement in the notification system - - - support unbounded number of simultaneous notifications - - send only one byte for simultaneous notifications - -Wed Feb 9 22:39:34 CET 2011 Jeremie Dimino - * use eventfd when available for notifications - -Tue Feb 8 17:24:52 CET 2011 Jeremie Dimino - * fix engines transfers - -Tue Feb 8 15:31:34 CET 2011 Jeremie Dimino - * typo - -Tue Feb 8 15:11:17 CET 2011 Jeremie Dimino - * stop all events before destroying an engine - -Tue Feb 8 15:05:27 CET 2011 Jeremie Dimino - * reimplement fd aborting - -Tue Feb 8 14:54:40 CET 2011 Jeremie Dimino - * implement engine copying - -Tue Feb 8 14:04:34 CET 2011 Jeremie Dimino - * fix the main loop - - I don't really know why it fixes tests... - -Mon Feb 7 23:28:07 CET 2011 Jeremie Dimino - * refactoring + use an engine based on select for windows - -Mon Feb 7 15:06:30 CET 2011 Jeremie Dimino - * fix examples - -Mon Feb 7 15:04:01 CET 2011 Jeremie Dimino - * reimplement lwt.glib with the new engine system - -Sun Feb 6 23:46:24 CET 2011 Jeremie Dimino - * allow to replace libev by another engine - -Wed Jan 26 14:19:37 CET 2011 chambart@crans.org - tagged 2.2.1 - -Wed Jan 26 14:17:37 CET 2011 chambart@crans.org - * update changelog and version number - -Mon Jan 24 21:55:14 CET 2011 Jeremie Dimino - * better way of copying/emptying the list of threads paused/yielded - -Mon Jan 24 16:29:08 CET 2011 Jeremie Dimino - * add a counter for paused threads and do not call wakeup_paused recursively - -Fri Jan 14 17:44:48 CET 2011 chambart@crans.org - * add a hook for Lwt.pause - -Fri Jan 14 17:33:36 CET 2011 chambart@crans.org - * circumvent an js_of_ocaml bug - -Tue Jan 4 14:19:50 CET 2011 Jeremie Dimino - * remove tests using finalisers - - Tests may fail because it is not ensured that finalisers will be - called. - -Fri Dec 17 16:58:14 CET 2010 Jeremie Dimino - * check for C libraries at configure time - -Thu Dec 16 17:46:19 CET 2010 Jeremie Dimino - * add libev to the README - -Mon Dec 13 15:37:20 CET 2010 Jeremie Dimino - tagged 2.2.0 - -Mon Dec 13 15:37:05 CET 2010 Jeremie Dimino - * version 2.2.0 - -Mon Dec 13 15:36:03 CET 2010 Jeremie Dimino - * add Lwt_bytes to apiref-intro - -Mon Dec 13 14:36:56 CET 2010 Jeremie Dimino - * update CHANGES - -Mon Dec 13 14:15:22 CET 2010 Jeremie Dimino - tagged 2.2 - -Mon Dec 13 14:15:02 CET 2010 Jeremie Dimino - * version 2.2 - -Sun Dec 12 18:49:31 CET 2010 balat at univ-paris-diderot.fr - * Adding wiki documentation - -Thu Dec 9 15:35:42 CET 2010 Jeremie Dimino - * install lwt_unix.h - -Wed Dec 8 17:25:21 CET 2010 Jeremie Dimino - * add Lwt.waiter_of_wakener - -Sat Dec 4 18:06:03 CET 2010 Jeremie Dimino - * remove Lwt.block and Lwt.no_cancel - -Sat Dec 4 11:58:40 CET 2010 Jeremie Dimino - * update CHANGES - -Sat Dec 4 11:38:25 CET 2010 Jeremie Dimino - * update the manual - -Sat Dec 4 10:42:14 CET 2010 Jeremie Dimino - * add Lwt.block and Lwt.no_cancel - -Thu Dec 2 17:44:26 CET 2010 Jeremie Dimino - * add Lwt_ssl.embed_socket - -Wed Dec 1 18:19:28 CET 2010 Jeremie Dimino - * fix a fd leak in Lwt_io.open_connection - -Sun Nov 28 18:24:47 CET 2010 Jeremie Dimino - * do not call pkg-config if not building lwt.glib - -Sat Nov 27 01:36:36 CET 2010 Jeremie Dimino - * update tests for local storage - -Fri Nov 26 21:24:31 CET 2010 Jeremie Dimino - * change the implementation of local storage - -Fri Nov 26 11:15:46 CET 2010 Jeremie Dimino - * discover available features at compile time - -Fri Nov 26 03:10:09 CET 2010 Jeremie Dimino - * fix compilation on opensolaris - -Thu Nov 25 17:11:20 CET 2010 Jeremie Dimino - * add more functions to Lwt_bytes - -Thu Nov 25 16:45:26 CET 2010 Jeremie Dimino - * do not wait if not needed in Lwt_bytes.wait_mincore - -Thu Nov 25 11:32:44 CET 2010 Jeremie Dimino - * put mmap stuff into Lwt_bytes - -Wed Nov 24 23:44:10 CET 2010 Jeremie Dimino - * add Lwt_bytes.{recvfrom,sendto} - -Wed Nov 24 20:52:13 CET 2010 Jeremie Dimino - * add Lwt_bytes.{recv,send}_msg - -Wed Nov 24 17:14:49 CET 2010 Jeremie Dimino - * replace strings by bigarrays in Lwt_io - -Tue Nov 23 21:24:24 CET 2010 Jeremie Dimino - * add Lwt_bytes to do IOs on bigarrays - -Wed Nov 24 07:52:06 CET 2010 Jeremie Dimino - * handle errors in lwt_unix_write_result - -Tue Nov 23 23:46:07 CET 2010 Jeremie Dimino - * fix compilation on FreeBSD - -Tue Nov 23 20:06:06 CET 2010 Jeremie Dimino - * do not create the notification if not needed in Lwt_unix.execute_job - -Tue Nov 23 16:11:06 CET 2010 Jeremie Dimino - * use a custom hashtbl for storing notifiers - -Tue Nov 23 15:32:44 CET 2010 Jeremie Dimino - * fix the stubs for stat - -Tue Nov 23 15:29:25 CET 2010 Jeremie Dimino - * fix compilation on windows - -Tue Nov 23 03:22:05 CET 2010 Jeremie Dimino - * use realtime signals instead of SIGUSR1 - -Tue Nov 23 02:38:45 CET 2010 Jeremie Dimino - * add functions to get/set the affinity - -Tue Nov 23 02:05:29 CET 2010 Jeremie Dimino - * do not include (not used) - -Mon Nov 22 23:30:36 CET 2010 Jeremie Dimino - * fix a memory leak in Lwt_unix.set_notification - - Use Hashtbl.replace instead of Hashtbl.add - -Mon Nov 22 23:22:30 CET 2010 Jeremie Dimino - * remove global roots when the watcher is stopped in libev stubs - -Mon Nov 22 22:42:18 CET 2010 Jeremie Dimino - * fix a typo in lwt_unix_send_notification_stub - -Mon Nov 22 21:08:00 CET 2010 Jeremie Dimino - * do not wait if not needed in Lwt_unix.execute_job - -Mon Nov 22 14:39:04 CET 2010 Jeremie Dimino - * delete the mutex associated to a job when it terminates - -Sun Nov 21 19:27:11 CET 2010 Jeremie Dimino - * fix cancellation of blocking calls - -Sun Nov 21 18:18:37 CET 2010 Jeremie Dimino - * add functions to control the pool of threads - -Sun Nov 21 16:37:23 CET 2010 Jeremie Dimino - * add Lwt_unix.readdir_n and Lwt_unix.files_of_directory - -Sun Nov 21 13:54:25 CET 2010 Jeremie Dimino - * use a hash table for storing notifications - -Sun Nov 21 12:26:49 CET 2010 Jeremie Dimino - * fix examples - -Sun Nov 21 11:58:05 CET 2010 Jeremie Dimino - * fix a bug in stubs for the switch async method - -Sat Nov 20 17:29:20 CET 2010 Jeremie Dimino - * set the [set_flags] field in [Lwt_unix.set_blocking] - -Sat Nov 20 13:37:13 CET 2010 Jeremie Dimino - * guess the blocking mode when not specified - -Fri Nov 19 22:54:36 CET 2010 Jeremie Dimino - * implement the switch async method - -Thu Nov 18 21:54:06 CET 2010 Jeremie Dimino - * add mmap oasis files - -Thu Nov 18 16:46:11 CET 2010 Jeremie Dimino - * create the sub-library lwt.mmap - -Thu Nov 18 10:51:38 CET 2010 Jeremie Dimino - * handle exceptions raised during the execution of libev_loop - - In particular handle SIGINT in the toplevel. - -Thu Nov 18 10:25:03 CET 2010 Jeremie Dimino - * reimplement Lwt_unix.abort with libev - -Thu Nov 18 04:09:12 CET 2010 Jeremie Dimino - * implement lwtized unix functions - -Wed Nov 17 21:04:54 CET 2010 Jeremie Dimino - * add prototype of all lwtised unix functions - -Wed Nov 17 17:54:11 CET 2010 Jeremie Dimino - * expose Lwt_unix.{readable,writable} - -Wed Nov 17 17:36:31 CET 2010 Jeremie Dimino - * add Lwt_io.is_busy - -Wed Nov 17 16:38:31 CET 2010 Jeremie Dimino - * add constants for the switch async method - -Wed Nov 17 15:45:49 CET 2010 Jeremie Dimino - * execute synchronous job in a blocking section - -Wed Nov 17 13:19:30 CET 2010 Jeremie Dimino - * add Lwt.with_value - -Wed Nov 17 08:35:13 CET 2010 Jeremie Dimino - * implement async version of Lwt_unix.close - -Wed Nov 17 01:15:25 CET 2010 Jeremie Dimino - * fix lwt_unix_send_notification - -Wed Nov 17 00:11:10 CET 2010 Jeremie Dimino - * add a mechanisms for running blocking system calls in parallels - -Wed Nov 10 15:37:17 CET 2010 Jeremie Dimino - * put Lwt_mmap into public modules - -Mon Nov 8 17:25:26 CET 2010 Jeremie Dimino - * put code examples into boxes in the manual - -Sun Nov 7 21:51:53 CET 2010 Jeremie Dimino - * make glib stubs to work on windows - -Fri Nov 5 18:11:45 CET 2010 Jeremie Dimino - * add a macro to acquire the runtime system lock from libev callbacks - -Tue Nov 2 23:12:07 CET 2010 Jeremie Dimino - * add doc for threads local storage - -Tue Nov 2 22:38:39 CET 2010 chambart@crans.org - * tests for Lwt_mmap - -Tue Nov 2 22:35:07 CET 2010 chambart@crans.org - * Lwt_mmap bugfixes - -Tue Nov 2 16:20:33 CET 2010 Jeremie Dimino - * add files generated by 'oasis setup' - - So users can compile the development version without installing oasis. - -Mon Nov 1 17:58:35 CET 2010 Jeremie Dimino - * fix a bug in read_notification - -Mon Nov 1 17:30:46 CET 2010 Jeremie Dimino - * fix a bug in send_notification - -Fri Oct 29 21:51:48 CEST 2010 Jeremie Dimino - * fix several wrong recursive calls in Lwt_list - -Fri Oct 29 18:36:13 CEST 2010 Jeremie Dimino - * use Lwt.task instead of Lwt.wait in Lwt_condition and Lwt_pool - -Fri Oct 29 17:50:50 CEST 2010 Jeremie Dimino - * better completion on modules contents - - Now completion works with modules defined in the toplevel. - -Thu Oct 28 12:37:42 CEST 2010 Jeremie Dimino - * handle Lwt_unix.yield without libev - -Wed Oct 27 22:55:49 CEST 2010 Jeremie Dimino - * fix the name of the stubs for glib in _tags - -Tue Oct 26 10:28:00 CEST 2010 Jeremie Dimino - * remove child watchers from libev stubs (not used) - -Tue Oct 26 01:28:50 CEST 2010 Jeremie Dimino - * fix compilation on windows - -Tue Oct 26 01:07:29 CEST 2010 Jeremie Dimino - * add support for windows threads - -Tue Oct 26 00:41:48 CEST 2010 Jeremie Dimino - * use libev instead of select - -Sat Oct 23 01:57:44 CEST 2010 Jeremie Dimino - * add oasis files to the repository - -Sat Oct 23 01:19:23 CEST 2010 Jeremie Dimino - * fix a typo in predist - -Sat Oct 23 01:00:47 CEST 2010 Jeremie Dimino - * update oasis stuff to oasis 0.2 - -Mon Oct 18 17:34:51 CEST 2010 Jeremie Dimino - * update the manual - -Tue Oct 12 18:35:28 CEST 2010 Jeremie Dimino - * add the inputenc package for the manual - -Fri Oct 8 17:31:53 CEST 2010 Jeremie Dimino - * add a "milliseconds" variable to Lwt_log - -Tue Oct 5 00:38:05 CEST 2010 Jeremie Dimino - * rename Makefile to make-dist.sh - -Tue Oct 5 00:29:12 CEST 2010 Jeremie Dimino - * remove colors in the manual - -Fri Sep 24 11:57:08 CEST 2010 Jeremie Dimino - * add Lwt_term.render_update - -Fri Sep 10 15:27:41 CEST 2010 Jeremie Dimino - * update the manual - -Fri Sep 10 10:37:22 CEST 2010 Stephane Glondu - * lwt_read_line: more usual behaviour for ^D - -Sun Jun 13 11:30:34 CEST 2010 Stephane Glondu - * Fix wiki syntax typo in CHANGES - -Wed Sep 8 07:41:49 CEST 2010 Jeremie Dimino - * Convert the manual to melt - -Sun Sep 5 22:17:19 CEST 2010 Jeremie Dimino - * add tests to _oasis - -Sun Sep 5 20:15:10 CEST 2010 Jeremie Dimino - * switch to OASIS - -Sun Sep 5 16:59:36 CEST 2010 Jeremie Dimino - * add an _oasis file (not yet usable) - -Sun Sep 5 10:29:35 CEST 2010 Jeremie Dimino - * add Lwt_switch to apiref-intro - -Sat Sep 4 11:46:34 CEST 2010 Jeremie Dimino - * add lwt_unix.h - -Sat Sep 4 11:46:12 CEST 2010 Jeremie Dimino - * use raise_lwt instead of fail - -Sat Sep 4 11:16:22 CEST 2010 Jeremie Dimino - * add backtrace support - -Wed Sep 1 15:24:50 CEST 2010 Jeremie Dimino - * factorize pipes internally used by lwt into a single one - -Tue Aug 31 15:59:25 CEST 2010 Jeremie Dimino - * merge optimisations for Lwt.pick and Lwt.choose - -Tue Aug 31 11:56:26 CEST 2010 chambart@crans.org - * Lwt_mmap reuse already mmaped file - -Tue Aug 31 10:49:04 CEST 2010 chambart@crans.org - * make Lwt_mmap sleeps sometimes to launch fewer threads - -Mon Aug 30 18:00:04 CEST 2010 chambart@crans.org - * allow Lwt_mmap functions to read more than one page per syscall - -Mon Aug 30 14:50:30 CEST 2010 chambart@crans.org - * optimisation of Lwt.pick - - Usualy there is only one thread ready to pick. - In this case we don't call Random.int since it is quite expensive, - even with 1 as parameter. - - -Tue Aug 31 13:13:29 CEST 2010 Jeremie Dimino - * fix local storage bugs + add tests - -Mon Aug 30 11:47:35 CEST 2010 Jeremie Dimino - * typo - - Pattern not recognized by ocaml 3.11 - -Sun Aug 29 11:34:39 CEST 2010 Jeremie Dimino - * add LWt_switch.add_hook_or_exec - -Sun Aug 29 10:55:58 CEST 2010 Jeremie Dimino - * modify Lwt_switch.add_hook and add Lwt_switch.check - -Fri Aug 27 14:28:02 CEST 2010 chambart@crans.org - * use Lwt_mmap when possible in Lwt_io - -Thu Aug 26 18:02:00 CEST 2010 chambart@crans.org - * really non blocking disk input using mmap/mincore - -Thu Aug 26 10:08:24 CEST 2010 Jeremie Dimino - * add module Lwt_switch - -Wed Aug 25 13:26:33 CEST 2010 Jeremie Dimino - * fixes to really make it works with ocaml 3.11 - -Wed Aug 25 12:48:45 CEST 2010 Jeremie Dimino - * no ocaml 3.12 features for now - -Tue Aug 24 22:34:39 CEST 2010 Jeremie Dimino - * make Lwt.join to wait for all threads to terminate, even if one fails - -Tue Aug 24 22:12:12 CEST 2010 Jeremie Dimino - * add thread local storage - -Mon Jul 5 09:15:20 CEST 2010 Jeremie Dimino - * fixes signal handling - -Fri Jul 2 11:06:52 CEST 2010 Jeremie Dimino - * make signal handling thread-safe - -Thu Jun 24 13:10:54 CEST 2010 Jeremie Dimino - * replace Lwt.select by Lwt.pick in Lwt_unix's doc - -Sun Jun 20 19:24:15 CEST 2010 Jeremie Dimino - * Do not share the reference to the cancel function in threads created with Lwt.wait - -Fri Jun 18 19:03:52 CEST 2010 Jeremie Dimino - * fix a race condition in Lwt_{event,signal}.delay - -Thu Jun 17 09:55:22 CEST 2010 Jeremie Dimino - * added Lwt_{signal,event}.delay - -Sun Jun 13 10:49:33 CEST 2010 Stephane Glondu - tagged 2.1.1 - -Sun Jun 13 10:48:02 CEST 2010 Stephane Glondu - * Prepare release 2.1.1 - -Sat Jun 12 09:00:21 CEST 2010 Jeremie Dimino - * better implementation of lwtized react functions - - Now, given [e' = operation_{s,p} f e ...], if the function [f] returns - immediatly, [e'] behaves has [operation f e], and if not it is updated - in a disjoint update cycle. - -Fri Jun 4 17:09:36 CEST 2010 Stephane Glondu - * Update CHANGES - -Sat May 29 23:05:34 CEST 2010 Jeremie Dimino - * use set_close_on_exec for fds created by Lwt_log - -Fri May 28 08:54:10 CEST 2010 Jeremie Dimino - * minor fix in Lwt.map - - It was possible that [res] was connected two times, thus raising an - exception. - -Tue May 25 12:34:31 CEST 2010 Jeremie Dimino - * change the welcome message of the toplevel - -Tue May 25 01:45:05 CEST 2010 Jeremie Dimino - * fix a fd leak in Lwt_unix.accept_n - - Now, if an error happen after connections have been accepted, they are - returned with the error. - -Fri May 21 16:48:50 CEST 2010 Jeremie Dimino - * add a patch to support the lwt syntax extension in the tuareg mode - -Mon May 10 18:51:19 CEST 2010 Jeremie Dimino - * fix a bug in Lwt.cancel - - Prevent threads from cancelling themselves recursively - -Fri May 7 10:32:26 CEST 2010 Jeremie Dimino - * make Lwt_main.call_hooks tail recursive - -Thu May 6 18:46:36 CEST 2010 Jeremie Dimino - * fix updating of the cancel function - -Thu May 6 11:15:25 CEST 2010 Jeremie Dimino - * add Lwt.nchoose and Lwt.npick - -Tue May 4 17:57:22 CEST 2010 Jeremie Dimino - * never fail when cancelling a thread - -Tue May 4 15:36:33 CEST 2010 Jeremie Dimino - * call Lwt.wakeup_paused before polling the thread in Lwt_main.run - - Otherwise, if the thread terminates in wakeup_paused, the scheduler - may wait indefinitly for nothing. - -Mon Apr 19 20:47:32 CEST 2010 Stephane Glondu - tagged 2.1.0 - -Mon Apr 19 20:47:19 CEST 2010 Stephane Glondu - * Prepare release 2.1.0 - -Sun Apr 18 08:39:18 CEST 2010 Jeremie Dimino - * do not expunge everything - -Sat Apr 17 15:30:24 CEST 2010 Jeremie Dimino - * expunge the toplevel - -Thu Apr 15 23:31:43 CEST 2010 Jeremie Dimino - * fix the logging example - -Wed Apr 14 22:19:27 CEST 2010 Stephane Glondu - * apiref-intro: increment all header levels by 1 - - ...to match the current way of handling doc on the website. - -Wed Apr 14 14:59:02 CEST 2010 Stephane Glondu - * Add possibility to override ocamldoc - -Mon Apr 12 10:01:16 CEST 2010 jerome.vouillon@pps.jussieu.fr - * Made Lwt_util.iter tail recursive + fixed bug in Lwt_util.run_in_region - -Thu Apr 1 02:04:42 CEST 2010 Jeremie Dimino - * add hacks for windows in Lwt_unix - -Mon Mar 29 14:38:10 CEST 2010 Jeremie Dimino - * add missing dependency lwt.react --> lwt - -Sun Mar 28 15:14:10 CEST 2010 Jeremie Dimino - * fix compilation of simple_top - - Remove the wrong dependency to ocaml-text - -Sun Mar 28 01:30:59 CET 2010 Jeremie Dimino - * install dlls on windows - -Sat Mar 27 15:54:13 CET 2010 Jeremie Dimino - * fix compilation under mingw32 - -Thu Mar 25 18:04:21 CET 2010 Jeremie Dimino - * css: fix copying to the documentation directory - -Thu Mar 25 11:24:36 CET 2010 Jeremie Dimino - * add/fix documentation - -Thu Mar 25 08:00:32 CET 2010 Jeremie Dimino - * css: fix color of keyword symbols - -Thu Mar 25 00:34:30 CET 2010 Jeremie Dimino - * css: highlight definitions - -Wed Mar 24 22:35:43 CET 2010 Stephane Glondu - * Minor typos in doc - -Wed Mar 24 20:38:11 CET 2010 Jeremie Dimino - * fix doc css - -Wed Mar 24 15:59:54 CET 2010 Jeremie Dimino - * a bit more doc for Lwt - -Wed Mar 24 15:59:40 CET 2010 Jeremie Dimino - * fix doc of Lwt_stream - -Wed Mar 24 11:38:06 CET 2010 Jeremie Dimino - * add category descriptions - -Wed Mar 24 11:11:14 CET 2010 Jeremie Dimino - * add a custom css - -Tue Mar 23 00:26:53 CET 2010 Jeremie Dimino - * add Lwt_signal.{bind,return} - -Mon Mar 22 20:36:48 CET 2010 Stephane Glondu - * Better titles for modules in apiref index - -Mon Mar 22 20:05:53 CET 2010 Stephane Glondu - * Categorize ocamldoc-generated API reference - -Mon Mar 22 19:27:31 CET 2010 Jeremie Dimino - * add the backlog argument to Lwt_io.establish_server - -Sun Mar 21 22:17:12 CET 2010 Stephane Glondu - * Minor fixes with doc generation - -Sun Mar 21 19:59:33 CET 2010 Stephane Glondu - * Remove Lwt_monitor - -Sun Mar 21 19:46:45 CET 2010 Jeremie Dimino - * rename lwt_core.cma to lwt.cma - - Otherwise it breaks to much things. - -Sun Mar 21 18:14:19 CET 2010 Jeremie Dimino - * add Lwt_io.system_byte_order - -Sun Mar 21 17:59:34 CET 2010 Jeremie Dimino - * logging: allow to dispatch logs according to their sections - -Sun Mar 21 01:01:14 CET 2010 Stephane Glondu - * Changelog trivia - -Sun Mar 21 00:35:56 CET 2010 Stephane Glondu - * Add module Lwt_condition - - This module promotes Lwt_monitor's conditions. Lwt_monitor now - duplicates mutexes and condition, and will most likely be removed - soon. - - -Sun Mar 21 00:35:32 CET 2010 Stephane Glondu - * Formatting changelog - -Sat Mar 20 08:48:45 CET 2010 Jeremie Dimino - * more signal helpers - -Fri Mar 19 19:13:04 CET 2010 Jeremie Dimino - * rename Lwt.select to Lwt.pick - -Wed Mar 17 08:56:07 CET 2010 Jeremie Dimino - * more event functions - -Tue Mar 16 20:54:24 CET 2010 Jeremie Dimino - * fix doc generation - -Tue Mar 16 20:31:18 CET 2010 Jeremie Dimino - * replace Lwt_main.fast_yield by Lwt.pause - -Tue Mar 16 18:28:50 CET 2010 Jeremie Dimino - * typo - -Tue Mar 16 18:24:52 CET 2010 Jeremie Dimino - * add the possibility to finalise an event/signal - -Tue Mar 16 17:07:07 CET 2010 Jeremie Dimino - * more readable ouput of tests - -Tue Mar 16 15:04:31 CET 2010 Jeremie Dimino - * add mapping functions for events and signals - -Tue Mar 16 13:42:35 CET 2010 Jeremie Dimino - * allow to cancel a [get] on a stream created with Lwt_stream.create or Lwt_event.to_stream - -Mon Mar 15 21:39:12 CET 2010 Jeremie Dimino - * replace Lwt_stream.push_stream by Lwt_stream.create - -Wed Mar 10 09:56:15 CET 2010 chambart@crans.org - * add Lwt_term.clear_line - -Sun Mar 14 22:04:07 CET 2010 Jeremie Dimino - * Various manual fixes - - Thanks to Xavier Lagorce for the tips. - -Sun Mar 14 12:01:57 CET 2010 Jeremie Dimino - * fix: inverse arguments of Unix.kill in Lwt_process - -Sat Mar 13 10:27:53 CET 2010 Jeremie Dimino - * fix tests - -Sat Mar 13 09:10:45 CET 2010 Jeremie Dimino - * add wrappers for all unix functions using file descriptors - -Fri Mar 12 21:36:08 CET 2010 Jeremie Dimino - * add wrappers for Unix.send, Unix.sendto, Unix.recv and Unix.recvfrom - -Fri Mar 12 19:40:16 CET 2010 Jeremie Dimino - * add more unix functions - -Fri Mar 12 18:10:49 CET 2010 Jeremie Dimino - * split sources into sub-directories - -Fri Mar 12 16:43:28 CET 2010 Jeremie Dimino - * put react stuff into a new sub-library named "lwt.react" - -Fri Mar 12 10:57:14 CET 2010 Jeremie Dimino - * Add a note in the manual telling it is not yet finished - -Thu Mar 11 18:53:26 CET 2010 Jeremie Dimino - * update CHANGES - -Thu Mar 11 16:58:06 CET 2010 Jeremie Dimino - * Optimisations in the Lwt module - -Thu Mar 11 00:24:56 CET 2010 Jeremie Dimino - * Better representation of removable waiters - - We do not keep a reference to the waiter function, so it can be - garbage collected before the tree is cleaned-up. - -Sat Mar 6 01:50:47 CET 2010 Jeremie Dimino - * fix connection order in Lwt.connect - -Wed Mar 3 22:26:26 CET 2010 Jeremie Dimino - * finish the first section of the manual - -Wed Mar 3 15:18:37 CET 2010 Jeremie Dimino - * add Lwt_main.at_exit - -Tue Mar 2 10:18:01 CET 2010 chambart@crans.org - * more tests of module Lwt - -Tue Mar 2 10:17:18 CET 2010 chambart@crans.org - * typos in comments - -Tue Mar 2 00:45:02 CET 2010 Jeremie Dimino - * reorganise sections of the manual - -Fri Feb 26 02:49:48 CET 2010 Jeremie Dimino - * better performances of the Lwt module - - Instead of using doubly linked lists, we use a tree and garbage - collect disabled waiters when their number reach a limit. - -Thu Feb 25 17:30:01 CET 2010 Jeremie Dimino - * add Lwt_stream.last_new - -Wed Feb 24 14:20:59 CET 2010 Jeremie Dimino - * remove the fifo hack from Lwt_io.open_file - -Wed Feb 24 11:40:13 CET 2010 Jeremie Dimino - * allow to cancel a server created with Lwt_io.establish_server - -Sun Feb 21 14:12:19 CET 2010 Jeremie Dimino - * rename Lwt_term.{save,restore}_stato to Lwt_term.{enter,leave}_drawing_mode - -Sat Feb 20 18:38:42 CET 2010 Jeremie Dimino - * add Lwt_main.fast_yield - -Fri Feb 19 11:28:11 CET 2010 Jeremie Dimino - * simplify the syntax extension for logs - - Now the lwt.syntax.log syntax extension is not required. Adding it is - just a matter of performance. - -Thu Feb 18 20:04:46 CET 2010 Jeremie Dimino - * allow to wait for log completion - -Thu Feb 18 12:53:45 CET 2010 Jeremie Dimino - * fix Lwt_{event,signal}.limit - -Thu Feb 18 08:39:52 CET 2010 Jeremie Dimino - * add Lwt_{event,signal}.limit - -Thu Feb 18 00:52:12 CET 2010 Jeremie Dimino - * Bugfix for cloned streams - -Wed Feb 17 19:34:29 CET 2010 chambart@crans.org - * add more tests for Lwt_stream.clone ( and expose a bug ) - -Wed Feb 17 18:27:01 CET 2010 chambart@crans.org - * add Lwt_stream.filter_map test - -Wed Feb 17 18:24:25 CET 2010 chambart@crans.org - * add Lwt_stream.filter test - -Wed Feb 17 18:15:28 CET 2010 chambart@crans.org - * remove old test from Makefile - -Wed Feb 17 10:11:15 CET 2010 Jeremie Dimino - * add Lwt.protected - -Tue Feb 16 16:26:05 CET 2010 Jeremie Dimino - * Add support for redirections in Lwt_process - -Tue Feb 16 15:09:15 CET 2010 Jeremie Dimino - * doc typos - -Tue Feb 16 13:56:06 CET 2010 Jeremie Dimino - * Add Lwt_daemon - -Fri Feb 12 14:01:05 CET 2010 Jeremie Dimino - * Add Lwt_io.of_string - -Fri Feb 12 13:05:29 CET 2010 Jeremie Dimino - * Do not wrap Unix_error into Sys_error - - Unix_error are more precise that Sys_error. - -Wed Feb 10 18:10:31 CET 2010 Jeremie Dimino - * caching of completion - -Wed Feb 10 17:27:47 CET 2010 Jeremie Dimino - * move Lwt_ocaml_completion and Toplevel to src/private - -Wed Feb 10 10:17:15 CET 2010 Jeremie Dimino - * make Lwt_io.pipe raise Sys_error - -Mon Feb 8 17:47:11 CET 2010 Jeremie Dimino - * automatic closing of anonymous channels - -Fri Feb 5 15:39:01 CET 2010 Jeremie Dimino - * add Lwt_term.{save,restore}_state - -Fri Feb 5 15:11:51 CET 2010 Jeremie Dimino - * better printing in Lwt_read_line - - Do not add spaces to erase text. - -Fri Feb 5 11:08:03 CET 2010 Jeremie Dimino - * close fds used for signals on exec - -Wed Feb 3 07:29:51 CET 2010 Jeremie Dimino - * add control of the internal buffer size in Lwt_io - -Wed Feb 3 07:06:50 CET 2010 Jeremie Dimino - * typo in lwt_unix_stubs.c - -Tue Feb 2 15:17:39 CET 2010 Jeremie Dimino - * fix Lwt_read_line.complete - - The suffix was ignored - -Mon Feb 1 22:08:03 CET 2010 Jeremie Dimino - * drawing helpers - -Sun Jan 31 20:30:39 CET 2010 Jeremie Dimino - * add Lwt_mutex.{is_locked,is_empty} - -Sun Jan 31 13:38:41 CET 2010 Jeremie Dimino - * add the log level "notice" - -Fri Jan 29 20:56:26 CET 2010 Jeremie Dimino - * fix Lwt_stream.get_while - -Fri Jan 29 19:56:42 CET 2010 Jeremie Dimino - * corrrectly count the number of failure in tests - -Thu Jan 28 18:55:42 CET 2010 Jeremie Dimino - * allow std* to be closed - -Thu Jan 28 18:33:44 CET 2010 Jeremie Dimino - * simpler creation of Lwt_io.std* - -Thu Jan 28 18:20:13 CET 2010 Jeremie Dimino - * do not closes channels on exit - -Sat Jan 23 22:19:20 CET 2010 Jeremie Dimino - * more doc - -Sat Jan 23 17:07:02 CET 2010 Jeremie Dimino - * doc: finish the doc of the core library - -Sat Jan 23 16:43:25 CET 2010 Jeremie Dimino - * doc: intro + core concepts - -Sat Jan 23 13:56:13 CET 2010 Jeremie Dimino - * doc for the syntax extension - -Sat Jan 23 12:22:02 CET 2010 Jeremie Dimino - * user manual skeleton - -Thu Jan 21 18:49:26 CET 2010 Jeremie Dimino - * fix Undo when the cache of previous states is too big - -Wed Jan 20 22:13:02 CET 2010 Jeremie Dimino - * add Undo command to read-line - -Mon Jan 18 16:04:03 CET 2010 Jeremie Dimino - * tests for Lwt_io - -Mon Jan 18 15:45:42 CET 2010 Jeremie Dimino - * allow auto-flushing in atomics - -Mon Jan 18 14:58:24 CET 2010 Jeremie Dimino - * Lwt_io: do not yield in the auto-flusher if the channel is busy - -Sun Jan 17 17:25:10 CET 2010 Jeremie Dimino - * add -I src/stubs for building toplevel.top - -Sun Jan 17 13:57:34 CET 2010 Jeremie Dimino - * fix backward search in read_line - -Sun Jan 17 01:12:47 CET 2010 Jeremie Dimino - * more completion in the toplevel - -Sat Jan 16 20:17:37 CET 2010 Jeremie Dimino - * enhancement of history loading/saving - - When saving the history, it is merged with the on disk history. - -Sat Jan 16 18:52:15 CET 2010 Jeremie Dimino - * udpate CHANGES - -Sat Jan 16 18:09:52 CET 2010 Jeremie Dimino - * handle {Backward,Forward}_delete_word - -Sat Jan 16 18:00:36 CET 2010 Jeremie Dimino - * use Key_control for all control keys - -Thu Jan 14 13:32:54 CET 2010 Jeremie Dimino - * uses unix file-descriptors instead of lwt ones for {recv,send}_msg - - Passed file descriptors may fails to be put in non-blocking mode, so - we let the user do the convertion if he wants to. - -Thu Jan 14 10:29:35 CET 2010 Jeremie Dimino - * move stubs into a subdirectory - -Thu Jan 14 01:39:51 CET 2010 Jeremie Dimino - * add Lwt_unix.get_credentials - -Thu Jan 14 01:39:28 CET 2010 Jeremie Dimino - * add Lwt_unix.{recv,send}_msg - -Wed Jan 13 14:57:15 CET 2010 Jeremie Dimino - * fix backward-search in read-line - -Tue Jan 12 22:39:45 CET 2010 Jeremie Dimino - * enable {forward/backward}-word in selection mode - -Tue Jan 12 19:48:04 CET 2010 Jeremie Dimino - * add Lwt_read_line.Command.Backward_kill_line - -Tue Jan 12 19:46:05 CET 2010 Jeremie Dimino - * add Lwt_read_line.Command.of_string - -Tue Jan 12 09:49:15 CET 2010 Jeremie Dimino - * deprecates module Lwt_util - -Tue Jan 12 09:46:40 CET 2010 Jeremie Dimino - * add module Lwt_list - -Mon Jan 11 22:11:32 CET 2010 Jeremie Dimino - * merge - -Mon Jan 11 08:13:51 CET 2010 chambart@crans.org - * add quite complete test for Lwt and partial test for Lwt_util - -Mon Jan 11 21:52:43 CET 2010 Jeremie Dimino - * start of unit tests - -Sat Jan 9 10:29:38 CET 2010 Jeremie Dimino - * optimisation on cancellable threads - - Use directly the list of threads to cancel with the [Temp] - constructor. - -Sat Jan 9 10:56:25 CET 2010 Jeremie Dimino - * do not launch a new thread for completion in `real_time mode - -Sat Jan 9 00:00:35 CET 2010 Jeremie Dimino - * read-line animation - -Fri Jan 8 19:07:55 CET 2010 Jeremie Dimino - * read-line fixes - -Fri Jan 8 08:56:26 CET 2010 Jeremie Dimino - * launch the auto-flusher in the optimized write_char - -Thu Jan 7 23:35:33 CET 2010 Jeremie Dimino - * fix Lwt_stream.of_event - -Thu Jan 7 18:53:08 CET 2010 Jeremie Dimino - * rewrite all read-line functions - -Thu Jan 7 16:07:34 CET 2010 Jeremie Dimino - * Lwt_stream enhancement - -Wed Jan 6 17:11:51 CET 2010 Jeremie Dimino - * handle prompt visibility in Lwt_read_line - -Wed Jan 6 14:49:53 CET 2010 Jeremie Dimino - * rewrite of the read-line engine - -Wed Jan 6 14:19:13 CET 2010 Jeremie Dimino - * include signal.h in lwt_unix_stubs.c (for SIGWINCH) - -Wed Jan 6 11:34:43 CET 2010 Jeremie Dimino - * optimize character reading/writing in Lwt_io - - Bypass the locking/unlocking phase if we can. - -Tue Jan 5 14:43:31 CET 2010 Jeremie Dimino - * change the interface of Lwt_directory - -Mon Jan 4 18:24:09 CET 2010 Jeremie Dimino - * fix Lwt_event.from - -Mon Jan 4 11:53:57 CET 2010 Jeremie Dimino - * add Lwt_event.from - -Sun Jan 3 21:58:36 CET 2010 Jeremie Dimino - * add Lwt_read_line.Terminal.erase - -Sat Jan 2 15:46:36 CET 2010 Jeremie Dimino - * fix building of documentation - -Tue Dec 29 23:39:57 CET 2009 Jeremie Dimino - * added Lwt_event.next - -Tue Dec 29 23:16:34 CET 2009 Jeremie Dimino - * typo in _tags: use_C_glic instead of use_C_glib - -Wed Dec 23 20:03:25 CET 2009 Jeremie Dimino - * bypass the FD_SETSIZE limitation of the libc - -Wed Dec 23 19:39:20 CET 2009 Jeremie Dimino - * fix examples/logging.ml - -Tue Dec 22 10:15:02 CET 2009 Jeremie Dimino - * better implementation of Lwt_unix.daemonize - -Mon Dec 21 23:18:37 CET 2009 Jeremie Dimino - * simplify the Lwt_log module - -Sat Dec 19 13:12:27 CET 2009 Jeremie Dimino - * add Lwt_io.establish_server - -Thu Dec 17 18:40:17 CET 2009 Jeremie Dimino - * exit with code 0 in Lwt_unix.daemoniaz - -Wed Dec 16 17:13:22 CET 2009 Jeremie Dimino - * force cooperation for file descriptors that do not support non-blocking I/Os - -Wed Dec 16 17:03:32 CET 2009 Jeremie Dimino - * Lwt_io.of_fd takes now a optionnal close function - - It allow to handle the case where we want that closing the channel - keep the file descriptor open. Now we can do: - - Lwt_io.of_fd ~close:Lwt.return ~mode:... - - -Wed Dec 16 17:02:14 CET 2009 Jeremie Dimino - * add module Lwt_directory - -Wed Dec 16 17:00:32 CET 2009 Jeremie Dimino - * add Lwt_unix.auto_yield - - Its goal is to force cooperation when it is not possible to have - non-blocking I/O. - -Wed Nov 25 19:26:30 CET 2009 Jeremie Dimino - * fix the example of use of "... >> ..." - -Sat Nov 21 23:19:50 CET 2009 Jeremie Dimino - * replace some ">... >> ..." by "lwt _ = ... in ..." - - It is much readable with the second construction than with the first - one. - -Sat Nov 21 00:13:49 CET 2009 Jeremie Dimino - * fix a fd leak in Lwt_io.open_connection - -Tue Nov 17 18:50:15 CET 2009 Jeremie Dimino - * removes the use of signalfd - - It is too much complicated to detect when it is really available and - working, and is linux-specific. We use now the classical hack which - consist on writing to a pipe when a signal come. - -Mon Nov 16 14:37:38 CET 2009 Jeremie Dimino - * add functions to navigate in the completion bar - -Mon Nov 16 11:24:55 CET 2009 Jeremie Dimino - * put completions into a table - - This remove ambiguity when a commpletion contains spaces. - -Mon Nov 16 10:11:11 CET 2009 Jeremie Dimino - * export helpers for drawing engine state on the terminal - -Mon Nov 16 09:26:50 CET 2009 Jeremie Dimino - * add comments in examples - -Mon Nov 16 10:37:45 CET 2009 chambart@crans.org - * stream functions (mapping and peeking) - -Mon Nov 16 10:06:13 CET 2009 chambart@crans.org - * pushable streams - -Sun Nov 15 21:41:20 CET 2009 Jeremie Dimino - * add two examples - -Sun Nov 15 21:10:23 CET 2009 Jeremie Dimino - * Refactoring of Lwt_read_lnie - - More code sharing between the read-line functions.. - -Sun Nov 15 12:21:29 CET 2009 Jeremie Dimino - * use sets instead of list for completion - -Fri Nov 13 21:35:02 CET 2009 Jeremie Dimino - * fix completion printing - -Fri Nov 13 18:59:37 CET 2009 Jeremie Dimino - * fix completion printing - -Fri Nov 13 18:06:49 CET 2009 Jeremie Dimino - * allow the prompt in read-line to be a signal - - This can be used to recompute the prompt when the terminal sizes - change. - -Fri Nov 13 17:39:42 CET 2009 Jeremie Dimino - * implement reverse search in read-line - -Fri Nov 13 09:34:09 CET 2009 Jeremie Dimino - * reset attributes before printing the prompt - -Fri Nov 13 08:40:25 CET 2009 Jeremie Dimino - * better completion on directives - -Thu Nov 12 22:27:26 CET 2009 Jeremie Dimino - * write naviguation inside completion - -Thu Nov 12 17:54:40 CET 2009 Jeremie Dimino - * rewrite Lwt_read_line.read_keyword - -Thu Nov 12 16:33:50 CET 2009 Jeremie Dimino - * rewrite of Lwt_read_line.read_line with reactive programming - -Thu Nov 12 09:24:12 CET 2009 Jeremie Dimino - * plop - -Wed Nov 11 21:18:27 CET 2009 Jeremie Dimino - * allow moves in the completion bar - -Wed Nov 11 17:51:39 CET 2009 Jeremie Dimino - * new completion type - -Tue Nov 10 14:21:40 CET 2009 Jeremie Dimino - * style - - Replace some "a >> b" by "lwt () = a in b" - -Tue Nov 10 08:44:37 CET 2009 Jeremie Dimino - * typo - -Tue Nov 10 08:24:48 CET 2009 Jeremie Dimino - * drop debugging messages by default - -Tue Nov 10 08:21:00 CET 2009 Jeremie Dimino - * logging enhancement - -Tue Nov 10 08:39:07 CET 2009 Jeremie Dimino - * fix generated code when debugging messages are disabled - -Tue Nov 10 08:01:12 CET 2009 Jeremie Dimino - * fix order of arguments in pa_log - -Mon Nov 9 20:36:05 CET 2009 Jeremie Dimino - * logging enhancement - -Mon Nov 9 20:27:31 CET 2009 Jeremie Dimino - * put daemonize in Lwt_unix - - Lwt_util is in the "lwt" package, so it should not depends on Unix. - -Sun Nov 8 08:01:34 CET 2009 Jeremie Dimino - * typo in myocamlbuild.ml - - The "dep" function expect a list of tags, not filenames - -Sat Nov 7 10:28:44 CET 2009 Jeremie Dimino - * add module name in logged messages - -Sat Nov 7 09:04:43 CET 2009 Jeremie Dimino - * added pa_log for logging messages - -Sat Nov 7 06:22:05 CET 2009 Jeremie Dimino - * typo - - lwt_clear_all_fs -> lwt_close_all_fds - -Fri Nov 6 23:33:18 CET 2009 Jeremie Dimino - * Adding function Lwt_util.daemonize - -Fri Nov 6 23:29:25 CET 2009 Jeremie Dimino - * Adding module Lwt_log - -Sun Nov 1 12:22:05 CET 2009 Jeremie Dimino - * adding module Lwt_log - - Lwt_log allows to log messages through syslog in cooperative way. - -Sun Oct 25 06:02:40 CET 2009 Jeremie Dimino - * enhancement in Lwt_process - - - add timeouts - - add more functions to the default process class - -Sun Oct 25 05:15:07 CET 2009 Jeremie Dimino - * replaces run_and_read in myocamlbuild.ml - -Sun Oct 25 05:03:44 CET 2009 Jeremie Dimino - * add Lwt_unix.wait4 - - Thanks to Mauricio Fernandez for the patch. - -Tue Oct 20 12:38:11 CEST 2009 Jeremie Dimino - * bugfix in Lwt_unix.connect - - Raises [Retry] on EINPROGRESS error. - -Sun Oct 18 07:28:09 CEST 2009 Jeremie Dimino - * update changes - -Fri Oct 16 09:40:25 CEST 2009 Jeremie Dimino - * bugfixes in lwt.glib - - - POLLIN, POLLOUT and POLLERR were not initialised correctly - - returned events were not set correctly (a Val_int was missing) - - the result of the poll function was incorrect - -Fri Oct 16 09:40:15 CEST 2009 Jeremie Dimino - * fix the "all" target in examples' Makefile - -Thu Oct 15 23:02:57 CEST 2009 Stephane Glondu - tagged 2.0.0 - -Thu Oct 15 23:02:21 CEST 2009 Stephane Glondu - * Prepare release 2.0.0 - -Mon Oct 12 12:13:20 CEST 2009 Jeremie Dimino - * Allow the "lwt x1 = e1 and x2 = e2 ..." construction at the toplevel - - Translate "lwt x1 = e1" to "let x1 = Lwt_main.run e1" and so. Very - usefull in the toplevel. - -Sat Oct 10 20:00:16 CEST 2009 Jeremie Dimino - * add events and signals utilities - -Sat Oct 3 16:01:13 CEST 2009 Jeremie Dimino - * more read-line functions - -Sat Oct 3 16:38:05 CEST 2009 Jeremie Dimino - * fix: close also stderr in Lwt_process.process_full#close - -Sat Oct 3 04:45:59 CEST 2009 Jeremie Dimino - * add lwt.unix to examples' myocamlbuild.ml - -Fri Oct 2 23:49:16 CEST 2009 Stephane Glondu - * Documentation for Lwt_throttle - -Fri Oct 2 23:39:43 CEST 2009 Stephane Glondu - * Generate documentation for lwt_unix - -Tue Sep 29 15:36:34 CEST 2009 Stephane Glondu - * Fix dependencies in META.in - -Sat Sep 26 01:13:20 CEST 2009 Stephane Glondu - tagged 2.0.0+rc1 - -Fri Sep 25 22:20:24 CEST 2009 Stephane Glondu - * Prepare release candidate - -Fri Sep 25 22:18:40 CEST 2009 Stephane Glondu - * Update CHANGES - -Fri Sep 25 20:21:53 CEST 2009 Jeremie Dimino - * remove lwt->unix dependency from META.in - -Fri Sep 25 11:45:14 CEST 2009 Jeremie Dimino - * remove lwt.withoutunix and add lwt.unix - - Remove unix dependencies from the main lwt and put them into a - subpackage lwt.unix. - -Wed Sep 23 18:44:58 CEST 2009 Jeremie Dimino - * use CAML* macro in C bindings - -Wed Sep 23 11:05:48 CEST 2009 Stephane Glondu - * Update CHANGES and README - -Fri Sep 11 22:19:49 CEST 2009 Jeremie Dimino - * include missing header in lwt_unix_stubs.c - -Sun Aug 30 19:31:51 CEST 2009 Stephane Glondu - * Fix META.in so that lwt exists on bytecode architectures - -Thu Aug 20 16:47:14 CEST 2009 Stephane Glondu - * Fix build on bytecode architectures - -Wed Aug 5 17:55:18 CEST 2009 balat at pps.jussieu.fr - * Adding missing mllib - -Tue Aug 4 19:32:20 CEST 2009 balat at pps.jussieu.fr - * Creating a cma without unix - plus small typos corrected - -Fri Jul 24 15:58:06 CEST 2009 Jeremie Dimino - * better catching of errors for the creation of the signal file descriptor - -Tue Jul 21 14:00:40 CEST 2009 Jeremie Dimino - * fix linking of the enhanced toplevel - -Mon Jul 20 12:13:57 CEST 2009 Jeremie Dimino - * fix the for_lwt syntax extension - -Sat Jul 18 18:45:48 CEST 2009 Jeremie Dimino - * do not fail if signalfd fails - -Thu Jul 9 14:47:30 CEST 2009 Jeremie Dimino - * do not allocate resources for sigchld handling lazilly - -Tue Jul 7 22:50:27 CEST 2009 Jeremie Dimino - * new toplevel with completion on identifiers + completion on directories and files - -Tue Jul 7 19:13:38 CEST 2009 Jeremie Dimino - * completion on findlib packages - -Tue Jul 7 19:13:17 CEST 2009 Jeremie Dimino - * syntax extension for 'for' blocks with lwt - -Tue Jul 7 19:12:38 CEST 2009 Jeremie Dimino - * readline display fixes and enhancement - -Mon Jun 15 02:19:27 CEST 2009 Jeremie Dimino - * changes the build system - - Put all rules into the ocamlbuild plugin and test for the presence of signalfd. - -Wed Jun 10 15:11:30 CEST 2009 vouillon at pps.jussieu.fr - * Separate the type of threads (covariant) from the type of thread wakeners (contravariant) - -Sun Jun 7 00:54:24 CEST 2009 Jeremie Dimino - * typos - -Sun Jun 7 00:34:28 CEST 2009 Jeremie Dimino - * handle signals with react - -Thu Jun 4 02:50:19 CEST 2009 Jeremie Dimino - * fix in Lwt_preemptive and Lwt_sequence - -Mon Jun 1 19:53:42 CEST 2009 Jeremie Dimino - * typo - -Mon Jun 1 16:57:48 CEST 2009 Jeremie Dimino - * Better reimplementation of Lwt_dlist and use it wherever cancellable tasks are possible - -Mon Jun 1 16:51:25 CEST 2009 Jeremie Dimino - * allow to switch between blocking and nonblocking mode for a file descriptor - -Thu May 28 09:40:21 CEST 2009 Jeremie Dimino - * allow file descriptors to be used in blocking mode - -Wed May 27 18:38:11 CEST 2009 balat at pps.jussieu.fr - * Lwt_pool: fixing race condition in create_member - -Wed May 27 16:16:37 CEST 2009 vouillon at pps.jussieu.fr - * Fixed MVar implementation: writers were never awaken - -Wed May 27 15:07:03 CEST 2009 vouillon at pps.jussieu.fr - * Put standard file descriptors in non-blocking mode only if really required - -Wed May 27 10:19:23 CEST 2009 Jeremie Dimino - * handling of FIFOs in Lwt_io - -Wed May 27 10:19:09 CEST 2009 Jeremie Dimino - * small fix in [try_lwt] syntax extension - -Tue May 26 16:58:02 CEST 2009 vouillon at pps.jussieu.fr - * Fixed binary int endianness in lwt_chan.ml - -Mon May 25 14:43:41 CEST 2009 Jeremie Dimino - * generalizes hexdump - -Mon May 25 13:28:56 CEST 2009 Jeremie Dimino - * bugfix in Lwt_unix.sleep - - Thanks to Pierre Chambart for the report - -Mon May 25 11:20:37 CEST 2009 Jeremie Dimino - * documentation for Lwt_unix - -Mon May 25 10:20:54 CEST 2009 Jeremie Dimino - * Lwt_io maps all Unix_error into Sys_error like the standard library - -Mon May 25 01:24:42 CEST 2009 Jeremie Dimino - * rename private modules to avoid name clashes with other libraries - -Mon May 25 01:10:49 CEST 2009 Jeremie Dimino - * implement the normal semantic for mailbox variables - -Mon May 25 00:52:01 CEST 2009 Jeremie Dimino - * put conditions into Lwt_monitor and fix some bugs - - Lwt_condition is not useful on its own - -Mon May 25 00:39:31 CEST 2009 Jeremie Dimino - * remove Lwt_queue - - Not well tested nor really useful - -Mon May 25 00:36:44 CEST 2009 Jeremie Dimino - * cancelable threads - -Sun May 24 18:49:25 CEST 2009 Jeremie Dimino - * do not use stubs on non-unix system - -Fri May 22 21:19:18 CEST 2009 Jeremie Dimino - * do not add duplicated lines in history - -Wed May 20 22:23:51 CEST 2009 Jeremie Dimino - * save/load history in the toplevel - -Wed May 20 22:16:43 CEST 2009 Jeremie Dimino - * added toplevel integration for when ocaml-text is missing - -Tue May 19 17:01:30 CEST 2009 Stephane Glondu - * Fix compilation when ocamlopt is missing - -Tue May 19 15:29:51 CEST 2009 Jeremie Dimino - * update CHANGES - -Tue May 19 15:27:49 CEST 2009 Jeremie Dimino - * add license wherever missing - -Tue May 19 15:21:22 CEST 2009 Jeremie Dimino - * Lwt_preemptive: refactoring + simplify its use - -Tue May 19 00:26:22 CEST 2009 Jeremie Dimino - * better mutexes - - Do not wakeup everybody on unlock, only the first waiter. - -Mon May 18 21:21:20 CEST 2009 Jeremie Dimino - * fix a bug in Lwt_io.read_all - -Mon May 18 20:47:49 CEST 2009 Jeremie Dimino - * Lwt_io.hexdump - -Mon May 18 17:13:57 CEST 2009 Jeremie Dimino - * remove Lwt_term.write_sequence - - Useless since the last flush bugfix. - -Mon May 18 16:55:18 CEST 2009 Jeremie Dimino - * fix a bug in Lwt_io.perform_io - - on partial flush, remaining data where not shifted. - -Mon May 18 16:29:57 CEST 2009 Jeremie Dimino - * makes *.open_* raise Sys_error instead of Unix_error - -Mon May 18 14:24:39 CEST 2009 Jeremie Dimino - * fix a bug in *.read_line - - empty lines were not returned correctly. - -Mon May 18 14:01:28 CEST 2009 Jeremie Dimino - * fix _tags - - put pkg_text only for modules needing it. - -Mon May 18 13:56:02 CEST 2009 Jeremie Dimino - * New sub-package lwt.text - - put all ocaml-text dependent modules into a separate package. - -Sun May 17 23:31:00 CEST 2009 Jeremie Dimino - * typo - -Sun May 17 22:46:13 CEST 2009 Jeremie Dimino - * split byte channels and text channels - -Sun May 17 17:15:04 CEST 2009 Jeremie Dimino - * move Pqueue into src/private - -Thu May 14 01:04:11 CEST 2009 Jeremie Dimino - * do not fail whan standard(s) in/output(s) are closed - -Wed May 13 19:19:21 CEST 2009 Jeremie Dimino - * prevent Lwt_preemptive.dispatch from failing when the pipe is closed - -Wed May 13 15:24:05 CEST 2009 Stephane Glondu - * Convert README to UTF-8 and add Warren Harris to authors - -Wed May 13 15:19:20 CEST 2009 Stephane Glondu - * Add exists_if to META file to allow partial installation - -Wed May 13 15:18:39 CEST 2009 Stephane Glondu - * Fix ocamldoc comments in Metaweb's files - -Wed May 13 14:55:09 CEST 2009 Stephane Glondu - * CHANGES formatting - -Tue May 12 23:27:28 CEST 2009 Jeremie Dimino - * add META to byte and native targets - -Tue May 12 22:13:56 CEST 2009 Jeremie Dimino - * add Lwt_mutex.with_mutex - - Thanks to Warren Harris for the patch - -Tue May 12 22:05:07 CEST 2009 Jeremie Dimino - * documentation for Lwt_{condition,mvar,monitor} - - Thanks to Warren Harris for the patch - -Tue May 12 10:28:11 CEST 2009 Jeremie Dimino - * added Warren Harris synchronisation modules' - -Tue May 12 09:34:33 CEST 2009 Jeremie Dimino - * better terminal rendering - -Tue May 12 07:52:11 CEST 2009 Jeremie Dimino - * Apply Warren Harris patch to handle pool member creation failure - -Tue May 12 00:30:41 CEST 2009 Jeremie Dimino - * use iconv transliteration features - -Mon May 11 17:53:06 CEST 2009 Jeremie Dimino - * fix Lwt_term.render - - workaround - -Mon May 11 14:37:46 CEST 2009 Jeremie Dimino - * remove Lwt_io.force_flush - -Mon May 11 13:57:49 CEST 2009 Jeremie Dimino - * fix documentation generation - - (temporary) workaround... - -Mon May 11 13:14:43 CEST 2009 Jeremie Dimino - * add light colors - -Mon May 11 02:15:52 CEST 2009 Jeremie Dimino - * inplementation of lwt_unix_term_size for windows - -Sun May 10 20:55:18 CEST 2009 Jeremie Dimino - * new example parallelize - -Sun May 10 20:52:48 CEST 2009 Jeremie Dimino - * build process enhancement - - * the makefile check for installed libraries - and activate the compilation of sub-packages - according to the result - * examples are compiled using ocamlbuild - -Thu May 7 23:51:28 CEST 2009 Jeremie Dimino - * more documentation - -Thu May 7 21:45:26 CEST 2009 Jeremie Dimino - * fixes in Lwt_unix.accept_n - -Thu May 7 11:21:52 CEST 2009 kerneis@pps.jussieu.fr - * Lwt_unix: accept_n - -Wed May 6 15:28:51 CEST 2009 Jeremie Dimino - * More suitable type for the completion function - - Now it can be aborted. - -Wed May 6 00:33:01 CEST 2009 Jeremie Dimino - * naming convention, small bug fixes and documentation - -Tue May 5 18:50:04 CEST 2009 Jeremie Dimino - * More functions in [Lwt_process] - -Tue May 5 17:52:27 CEST 2009 Jeremie Dimino - * Allow reuse of the readline engine - - Split the implementation into several reusable modules, so if at some - point somebody wants to implement a widget library using Lwt, it can - reuse them. - -Tue May 5 01:56:20 CEST 2009 Jeremie Dimino - * More on read-line - - * support of copy-pasting text - * added variant of read_line (read_password, read_yes_no, ...) - -Mon May 4 13:31:00 CEST 2009 Jeremie Dimino - * package encoding --> package text - -Mon May 4 13:01:54 CEST 2009 Jeremie Dimino - * use [Text.to_ascii] as default fallback function - -Mon May 4 12:27:09 CEST 2009 Jeremie Dimino - * various enhancement - - * better behaviour of *print* functions - * rename Lwt_term.get_key to Lwt_term.read_key since - it is a ``text'' function - * Lwt_read_line.read_line defaults to Lwt_io.read_line - when input is not a tty - * added sample init file utils/ocamlinit - -Mon May 4 09:52:25 CEST 2009 Jeremie Dimino - * better names for printing functions - -Mon May 4 08:55:25 CEST 2009 Jeremie Dimino - * update CHANGES - -Mon May 4 08:43:59 CEST 2009 Jeremie Dimino - * more helpers - -Sun May 3 19:54:47 CEST 2009 Jeremie Dimino - * deal with character encodings at the channel level - -Sun May 3 21:37:10 CEST 2009 balat at pps.jussieu.fr - * (small patch) changing CHANGES format for inclusion in ocsigen.org's wiki - -Sun May 3 10:47:03 CEST 2009 Jeremie Dimino - * new module Lwt_printf - -Sun May 3 10:45:42 CEST 2009 Jeremie Dimino - * readline and line editing support for the toplevel - -Fri May 1 11:49:41 CEST 2009 Jeremie Dimino - * Change the behaviour of ">>" - - Make it behaves as normal operators, otherwise strange things can - happen. - -Thu Apr 30 20:53:33 CEST 2009 Jeremie Dimino - * new module Lwt_stream - -Thu Apr 30 15:47:52 CEST 2009 Jeremie Dimino - * Syntax extension improvement - - It is now easy to migrates to the lwt world! - - a; b --> a >> b - let x = m in e --> lwt x = m in e - try x with ... --> try_lwt x with ... - -Thu Apr 30 14:07:19 CEST 2009 Jeremie Dimino - * integration with the toplevel - -Thu Apr 30 13:35:11 CEST 2009 Jeremie Dimino - * Better implementation of [join] - - When one thread fails, it fails without waiting for the - termination of other threads. - -Wed Apr 29 17:27:34 CEST 2009 Jeremie Dimino - * glib integration - -Tue Apr 28 22:43:42 CEST 2009 Jeremie Dimino - * forein event-loop integration - -Sun Apr 19 23:32:50 CEST 2009 Jeremie Dimino - * use the ``try_lwt'' construction - -Sun Apr 19 20:46:21 CEST 2009 Jeremie Dimino - * allow ``try_lwt'' without ``with'' or ``finally'' - - This just catch normal exception. - -Fri Apr 17 11:32:26 CEST 2009 Jeremie Dimino - * update CHANGES - -Fri Apr 17 11:15:42 CEST 2009 Jeremie Dimino - * -custom is deprecated - -Fri Apr 17 05:11:43 CEST 2009 Jeremie Dimino - * add a syntax extension - -Thu Apr 16 01:06:09 CEST 2009 Jeremie Dimino - * stubs for [read] and [write] - - Simplified and optimised version using the fact that reading/writing - never block. - -Wed Apr 15 23:46:16 CEST 2009 Jeremie Dimino - * add Lwt_process module - -Wed Apr 15 22:55:18 CEST 2009 Jeremie Dimino - * add Lwt_io module - - Lwt_io is a new implementation of buffered channels which replaces - Lwt_chan. The latter is kept for compatibility and not simply replaced - to avoid name clashes: both modules define an [input] and an [output] - field but semantics are different. - -Wed Apr 15 16:06:27 CEST 2009 Jeremie Dimino - * add Lwt_gc and Lwt_exit_hook modules - -Tue Apr 14 20:44:31 CEST 2009 Jeremie Dimino - * add the pa_monad syntax extension - -Tue Apr 14 16:13:29 CEST 2009 Jeremie Dimino - * build process enhancement - - - generate everything with ocamlbuild - - call ocamlbuild only one time in the Makefile - - generate lwt.odocl to avoid duplication of the list of modules - -Mon Apr 13 16:48:51 CEST 2009 Jeremie Dimino - * allow the user to check the state of a thread - -Mon Apr 13 16:42:22 CEST 2009 Jeremie Dimino - * [Lwt.choose] do not leak memory anymore - - When a choose terminates, it removes all unneeded waiters. - -Sun Apr 12 13:24:53 CEST 2009 Jeremie Dimino - * better representation of threads - - [waiters = CNil] iff [state = Sleep]. - -Sat Jan 10 20:14:44 CET 2009 Stephane Glondu - * Add Lwt_throttle module - -Fri Dec 19 16:43:07 CET 2008 balat at pps.jussieu.fr - * Changing the default number of preemptive threads queued - -Wed Dec 3 02:27:19 CET 2008 Jeremie Dimino - * Better implementation of Lwt_chan.output_char - -Tue Jul 15 14:41:39 CEST 2008 Stephane Glondu - * Precisions in source headers - -Wed Jul 9 13:02:00 CEST 2008 Stephane Glondu - * Bugfix in Lwt_chan.close_* (ticket #66) - -Wed Jun 25 17:23:11 CEST 2008 Stephane Glondu - tagged 1.1.0 - -Wed Jun 25 17:23:02 CEST 2008 Stephane Glondu - * Prepare release - -Wed Jun 25 17:20:29 CEST 2008 Stephane Glondu - * changelog.darcs -> CHANGES.darcs - -Sun Jun 22 18:08:37 CEST 2008 Stephane Glondu - * Splitting out Lwt_preemptive and Lwt_ssl - They are put into separate archives and findlib packages so that lwt - depends only on unix (suggestion from Jerome Vouillon). As a side - effect, creation of lwt_extra, which contains only Lwt_lib for now, - because it uses Lwt_preemptive. - -Fri Jun 20 20:11:32 CEST 2008 Stephane Glondu - * Add CHANGES - CHANGES is in Wikicreole syntax and is used to display the changelog - on ocsigen.org. Ship darcs changelog in changelog.darcs. - -Sun Jun 8 22:13:23 CEST 2008 Stephane Glondu - * Exporting open_in_gen and open_out_gen from Lwt_chan - Request from Serge Leblanc - -Mon May 26 11:57:34 CEST 2008 Stephane Glondu - * Add description to META.in - -Sun May 25 13:17:45 CEST 2008 Stephane Glondu - * Move source files to src/ directory - -Sun May 25 13:08:36 CEST 2008 Stephane Glondu - * Set up build system - -Sun May 25 13:03:49 CEST 2008 Stephane Glondu - * Fix relay example - -Sun May 25 12:52:03 CEST 2008 Stephane Glondu - * README, COPYING, LICENSE - -Sun May 25 01:21:45 CEST 2008 Stephane Glondu - * Source file headers - -Sat May 24 20:07:48 CEST 2008 Stephane Glondu - * Initial import from Ocsigen repository diff --git a/server/thirdparty/lwt-2.3.2/COPYING b/server/thirdparty/lwt-2.3.2/COPYING deleted file mode 100644 index 97f4496..0000000 --- a/server/thirdparty/lwt-2.3.2/COPYING +++ /dev/null @@ -1,552 +0,0 @@ -This program is released under the LGPL version 2.1 (see the text below) with -the additional exemption that compiling, linking, and/or using OpenSSL is -allowed. - -As a special exception to the GNU Library General Public License, you -may also link, statically or dynamically, a "work that uses the Library" -with a publicly distributed version of the Library to produce an -executable file containing portions of the Library, and distribute -that executable file under terms of your choice, without any of the -additional requirements listed in clause 6 of the GNU Library General -Public License. By "a publicly distributed version of the Library", -we mean either the unmodified Library, or a -modified version of the Library that is distributed under the -conditions defined in clause 3 of the GNU Library General Public -License. This exception does not however invalidate any other reasons -why the executable file might be covered by the GNU Library General -Public License. - -Some parts, when stated (as licenced under BSD3) are licenced under -3-clauses or Modified BSD License. - - - GNU LESSER GENERAL PUBLIC LICENSE - Version 2.1, February 1999 - - Copyright (C) 1991, 1999 Free Software Foundation, Inc. - 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -[This is the first released version of the Lesser GPL. It also counts - as the successor of the GNU Library Public License, version 2, hence - the version number 2.1.] - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. - - This license, the Lesser General Public License, applies to some -specially designated software packages--typically libraries--of the -Free Software Foundation and other authors who decide to use it. You -can use it too, but we suggest you first think carefully about whether -this license or the ordinary General Public License is the better -strategy to use in any particular case, based on the explanations below. - - When we speak of free software, we are referring to freedom of use, -not price. Our General Public Licenses are designed to make sure that -you have the freedom to distribute copies of free software (and charge -for this service if you wish); that you receive source code or can get -it if you want it; that you can change the software and use pieces of -it in new free programs; and that you are informed that you can do -these things. - - To protect your rights, we need to make restrictions that forbid -distributors to deny you these rights or to ask you to surrender these -rights. These restrictions translate to certain responsibilities for -you if you distribute copies of the library or if you modify it. - - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link other code with the library, you must provide -complete object files to the recipients, so that they can relink them -with the library after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. - - We protect your rights with a two-step method: (1) we copyright the -library, and (2) we offer you this license, which gives you legal -permission to copy, distribute and/or modify the library. - - To protect each distributor, we want to make it very clear that -there is no warranty for the free library. Also, if the library is -modified by someone else and passed on, the recipients should know -that what they have is not the original version, so that the original -author's reputation will not be affected by problems that might be -introduced by others. - - Finally, software patents pose a constant threat to the existence of -any free program. We wish to make sure that a company cannot -effectively restrict the users of a free program by obtaining a -restrictive license from a patent holder. Therefore, we insist that -any patent license obtained for a version of the library must be -consistent with the full freedom of use specified in this license. - - Most GNU software, including some libraries, is covered by the -ordinary GNU General Public License. This license, the GNU Lesser -General Public License, applies to certain designated libraries, and -is quite different from the ordinary General Public License. We use -this license for certain libraries in order to permit linking those -libraries into non-free programs. - - When a program is linked with a library, whether statically or using -a shared library, the combination of the two is legally speaking a -combined work, a derivative of the original library. The ordinary -General Public License therefore permits such linking only if the -entire combination fits its criteria of freedom. The Lesser General -Public License permits more lax criteria for linking other code with -the library. - - We call this license the "Lesser" General Public License because it -does Less to protect the user's freedom than the ordinary General -Public License. It also provides other free software developers Less -of an advantage over competing non-free programs. These disadvantages -are the reason we use the ordinary General Public License for many -libraries. However, the Lesser license provides advantages in certain -special circumstances. - - For example, on rare occasions, there may be a special need to -encourage the widest possible use of a certain library, so that it becomes -a de-facto standard. To achieve this, non-free programs must be -allowed to use the library. A more frequent case is that a free -library does the same job as widely used non-free libraries. In this -case, there is little to gain by limiting the free library to free -software only, so we use the Lesser General Public License. - - In other cases, permission to use a particular library in non-free -programs enables a greater number of people to use a large body of -free software. For example, permission to use the GNU C Library in -non-free programs enables many more people to use the whole GNU -operating system, as well as its variant, the GNU/Linux operating -system. - - Although the Lesser General Public License is Less protective of the -users' freedom, it does ensure that the user of a program that is -linked with the Library has the freedom and the wherewithal to run -that program using a modified version of the Library. - - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, whereas the latter must -be combined with the library in order to run. - - GNU LESSER GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any software library or other -program which contains a notice placed by the copyright holder or -other authorized party saying it may be distributed under the terms of -this Lesser General Public License (also called "this License"). -Each licensee is addressed as "you". - - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control compilation -and installation of the library. - - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the -Library. - - You may charge a fee for the physical act of transferring a copy, -and you may at your option offer warranty protection in exchange for a -fee. - - 2. You may modify your copy or copies of the Library or any portion -of it, thus forming a work based on the Library, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) The modified work must itself be a software library. - - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you accompany -it with the complete corresponding machine-readable source code, which -must be distributed under the terms of Sections 1 and 2 above on a -medium customarily used for software interchange. - - If distribution of object code is made by offering access to copy -from a designated place, then offering equivalent access to copy the -source code from the same place satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also combine or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (1) uses at run time a - copy of the library already present on the user's computer system, - rather than copying library functions into the executable, and (2) - will operate properly with a modified version of the library, if - the user installs one, as long as the modified version is - interface-compatible with the version that the work was made with. - - c) Accompany the work with a written offer, valid for at - least three years, to give the same user the materials - specified in Subsection 6a, above, for a charge no more - than the cost of performing this distribution. - - d) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - e) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the materials to be distributed need not include anything that is -normally distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library is void, and will automatically terminate your -rights under this License. However, parties who have received copies, -or rights, from you under this License will not have their licenses -terminated so long as such parties remain in full compliance. - - 9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties with -this License. - - 11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - -If any portion of this section is held invalid or unenforceable under any -particular circumstance, the balance of the section is intended to apply, -and the section as a whole is intended to apply in other circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License may add -an explicit geographical distribution limitation excluding those countries, -so that distribution is permitted only in or among countries not thus -excluded. In such case, this License incorporates the limitation as if -written in the body of this License. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Lesser General Public License from time to time. -Such new versions will be similar in spirit to the present version, -but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - NO WARRANTY - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY -KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Libraries - - If you develop a new library, and you want it to be of the greatest -possible use to the public, we recommend making it free software that -everyone can redistribute and change. You can do so by permitting -redistribution under these terms (or, alternatively, under the terms of the -ordinary General Public License). - - To apply these terms, attach the following notices to the library. It is -safest to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least the -"copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - -Also add information on how to contact you by electronic and paper mail. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the library, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James Random Hacker. - - , 1 April 1990 - Ty Coon, President of Vice - -That's all there is to it! - - -====== BSD3 or Modified BSD License ====== - -Copyright (c) , -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - * Neither the name of the nor the - names of its contributors may be used to endorse or promote products - derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY -DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND -ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/server/thirdparty/lwt-2.3.2/LICENSE b/server/thirdparty/lwt-2.3.2/LICENSE deleted file mode 100644 index 0e5e324..0000000 --- a/server/thirdparty/lwt-2.3.2/LICENSE +++ /dev/null @@ -1,4 +0,0 @@ -The Ocsigen application core, and other portions of the official Ocsigen -distribution not explicitly licensed otherwise, are licensed under -the GNU LESSER GENERAL PUBLIC LICENSE with openssl linking exception --- see the 'COPYING' file in this directory for details. diff --git a/server/thirdparty/lwt-2.3.2/Makefile b/server/thirdparty/lwt-2.3.2/Makefile deleted file mode 100644 index 68f2e0e..0000000 --- a/server/thirdparty/lwt-2.3.2/Makefile +++ /dev/null @@ -1,38 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb) - -SETUP = ocaml setup.ml - -build: setup.data - $(SETUP) -build $(BUILDFLAGS) - -doc: setup.data build - $(SETUP) -doc $(DOCFLAGS) - -test: setup.data build - $(SETUP) -test $(TESTFLAGS) - -all: - $(SETUP) -all $(ALLFLAGS) - -install: setup.data - $(SETUP) -install $(INSTALLFLAGS) - -uninstall: setup.data - $(SETUP) -uninstall $(UNINSTALLFLAGS) - -reinstall: setup.data - $(SETUP) -reinstall $(REINSTALLFLAGS) - -clean: - $(SETUP) -clean $(CLEANFLAGS) - -distclean: - $(SETUP) -distclean $(DISTCLEANFLAGS) - -setup.data: - $(SETUP) -configure $(CONFIGUREFLAGS) - -.PHONY: build doc test all install uninstall reinstall clean distclean configure - -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/README b/server/thirdparty/lwt-2.3.2/README deleted file mode 100644 index 7b64477..0000000 --- a/server/thirdparty/lwt-2.3.2/README +++ /dev/null @@ -1,74 +0,0 @@ -Lwt: lightweight thread library for Objective Caml - --------------------------------------------------------------------------- - -This library is part of the Ocsigen project. See: - - http://ocsigen.org/lwt - --------------------------------------------------------------------------- - -Requirements: - - * ocaml with ocamlbuild (>= 3.11.0) - * findlib - * react (from http://erratique.ch/software/react) - * [optionnal] libev (from http://software.schmorp.de/pkg/libev.html) - * [optionnal] ocaml-text (needed for the enhanced toplevel) - * [optionnal] ocamlssl (>= 0.4.0) (ocamlssl needs openssl) (>= 0.4.1 for MacOS) - * [optionnal] glib-2.0 developpement files and pkg-config - -If ocaml/findlib/ocamlssl... are not installed on your computer, you -can use GODI to install them automatically. See: - - http://godi.camlcity.org/godi/index.html - -They might also be available through your distribution. - --------------------------------------------------------------------------- - -Instructions: - - * run "ocaml setup.ml -configure" to configure sources - You can add '--enable-' to enable compilation of - the sub-library . The flag '--enable-all' will - enable everything. - In order to compile without libev support you must add - '--disable-libev'. - * run "ocaml setup.ml -build" to compile - * run "ocaml setup.ml -install" as root to install compiled libraries - * run "ocaml setup.ml -uninstall" as root to uninstall them - -HTML documentation is generated in _build/lwt.docdir/, but is not -installed by default. - -If you get the development version you need to obtain oasis -(http://oasis.forge.ocamlcore.org/). - -If you want to build the toplevel you have to install compiler -libraries, under debian it is the package -ocaml-compiler-libs. Otherwise you can add a symlink like that: - - $ ln -s $(ocamlc -where)/compiler-libs - -Note that the utop project replaces the Lwt toplevel: - - https://forge.ocamlcore.org/projects/utop/ - --------------------------------------------------------------------------- - -Authors: - - * Jérôme Vouillon - * Vincent Balat - * Nataliya Guts - * Pierre Clairambault - * Stéphane Glondu - * Jérémie Dimino - * Warren Harris (Metaweb Technologies, Inc.) - * Pierre Chambart - * Mauricio Fernandez - -See each source file for copyright information, and COPYING for license. - --------------------------------------------------------------------------- diff --git a/server/thirdparty/lwt-2.3.2/_oasis b/server/thirdparty/lwt-2.3.2/_oasis deleted file mode 100644 index 04c026a..0000000 --- a/server/thirdparty/lwt-2.3.2/_oasis +++ /dev/null @@ -1,383 +0,0 @@ -# +-------------------------------------------------------------------+ -# | Package parameters | -# +-------------------------------------------------------------------+ - -OASISFormat: 0.1 -OCamlVersion: >= 3.12 -Name: lwt -Version: 2.3.2 -LicenseFile: COPYING -License: LGPL-2.1 with OCaml linking exception -Authors: - Jérôme Vouillon, - Vincent Balat, - Nataliya Guts, - Pierre Clairambault, - Stéphane Glondu, - Jérémie Dimino, - Warren Harris, - Pierre Chambart, - Mauricio Fernandez -Homepage: http://ocsigen.org/lwt/ -BuildTools: ocamlbuild -Plugins: DevFiles (0.2), META (0.2) -PostConfCommand: ocaml discover.ml -ocamlc $ocamlc -ext-obj $ext_obj -exec-name $default_executable_name -use-libev $libev -os-type $os_type -PostDistCleanCommand: $rm src/unix/lwt_config.h src/unix/lwt_config.ml - -Synopsis: Lightweight thread library for Objective Caml -Description: - Lwt is a library of cooperative threads implemented in monadic - style. With respect to preemptive threads, cooperative threads are - not using a scheduler to distribute processor time between - threads. Instead of this, each thread must tell the others that he - wants to let them work. - -# +-------------------------------------------------------------------+ -# | Flags | -# +-------------------------------------------------------------------+ - -Flag all - Description: build and install everything - Default: false - -Flag unix - Description: Unix support - Default: true - -Flag react - Description: React helpers - Default: false - -Flag glib - Description: Glib integration - Default: false - -Flag ssl - Description: SSL support - Default: false - -Flag text - Description: Text mode utilities - Default: false - -Flag preemptive - Description: Preemptive threads support - Default: true - -Flag extra - Description: Asynchronous unix functions - Default: true - -Flag toplevel - Description: Enhanced toplevel - Default: false - -Flag libev - Description: Compile with libev support - Default$: !os_type(Win32) - -# +-------------------------------------------------------------------+ -# | Libraries | -# +-------------------------------------------------------------------+ - -Library "optcomp" - Install: false - Path: syntax - Modules: Pa_optcomp - BuildDepends: camlp4.lib, camlp4.quotations.o - -Library "lwt" - Path: src/core - Modules: - Lwt_condition, - Lwt_list, - Lwt, - Lwt_mutex, - Lwt_mvar, - Lwt_pool, - Lwt_sequence, - Lwt_stream, - Lwt_switch, - Lwt_util, - Lwt_pqueue - XMETADescription: Lightweight thread library for OCaml (core library) - -Library "lwt-unix" - Build$: flag(unix) || flag(all) - Install$: flag(unix) || flag(all) - FindlibName: unix - FindlibParent: lwt - Path: src/unix - Modules: - Lwt_chan, - Lwt_daemon, - Lwt_gc, - Lwt_io, - Lwt_log, - Lwt_main, - Lwt_process, - Lwt_throttle, - Lwt_timeout, - Lwt_unix, - Lwt_sys, - Lwt_engine, - Lwt_bytes - InternalModules: - Lwt_log_rules - BuildDepends: lwt, unix, bigarray - XMETADescription: Unix support for lwt - CSources: - lwt_config.h, - lwt_unix.h, - lwt_unix_stubs.c, - lwt_libev_stubs.c - if os_type(Win32) - CCLib+: ws2_32.lib - else - CCLib+: -lpthread - if flag(libev) - CCLib+: -lev - -Library "lwt-simple-top" - Build$: flag(unix) || flag(all) - Install$: flag(unix) || flag(all) - FindlibName: simple-top - FindlibParent: lwt - Path: src/simple_top - InternalModules: Lwt_simple_top - BuildDepends: lwt, lwt.unix - XMETADescription: Unix support for lwt - -Library "lwt-react" - Build$: flag(react) || flag(all) - Install$: flag(react) || flag(all) - FindlibName: react - FindlibParent: lwt - Path: src/react - Modules: Lwt_event, Lwt_signal, Lwt_react - BuildDepends: lwt, react - XMETADescription: Reactive programming helpers - -Library "lwt-preemptive" - Build$: flag(preemptive) || flag(all) - Install$: flag(preemptive) || flag(all) - FindlibName: preemptive - FindlibParent: lwt - Path: src/preemptive - Modules: Lwt_preemptive - BuildDepends: lwt, lwt.unix, threads - XMETADescription: Preemptive threads support for Lwt - -Library "lwt-extra" - Build$: flag(extra) || flag(all) - Install$: flag(extra) || flag(all) - FindlibName: extra - FindlibParent: lwt - Path: src/extra - Modules: Lwt_lib - BuildDepends: lwt, lwt.preemptive - XMETADescription: Unix functions for Lwt using Lwt_preemptive - -Library "lwt-glib" - Build$: flag(glib) || flag(all) - Install$: flag(glib) || flag(all) - FindlibName: glib - FindlibParent: lwt - Path: src/glib - Modules: Lwt_glib - CSources: lwt_glib_stubs.c - BuildDepends: lwt, lwt.unix - XMETADescription: Glib integration - -Library "lwt-ssl" - Build$: flag(ssl) || flag(all) - Install$: flag(ssl) || flag(all) - FindlibName: ssl - FindlibParent: lwt - Path: src/ssl - Modules: Lwt_ssl - BuildDepends: ssl, lwt.unix - XMETADescription: SSL support for Lwt - -Library "lwt-text" - Build$: flag(text) || flag(all) - Install$: flag(text) || flag(all) - FindlibName: text - FindlibParent: lwt - Path: src/text - Modules: Lwt_text, Lwt_term, Lwt_read_line - BuildDepends: lwt, lwt.unix, lwt.react, text, text.bigarray - XMETADescription: Text mode utilities - CSources: lwt_text_stubs.c - -Library "lwt-top" - Build$: flag(text) || flag(all) - Install$: flag(text) || flag(all) - FindlibName: top - FindlibParent: lwt - Path: src/top - Modules: Lwt_top - InternalModules: Lwt_ocaml_completion - BuildDepends: lwt, lwt.text, findlib - XMETADescription: Line-editing in the toplevel - -Library "lwt-syntax" - FindlibName: syntax - FindlibParent: lwt - Path: syntax - Modules: Pa_lwt - BuildDepends: camlp4.lib, camlp4.quotations.o, camlp4.extend - XMETAType: syntax - XMETADescription: Syntactic sugars for Lwt - XMETARequires: camlp4, lwt.syntax.options - -Library "lwt-syntax-options" - FindlibName: options - FindlibParent: lwt-syntax - Path: syntax - InternalModules: Pa_lwt_options - BuildDepends: camlp4.lib - XMETAType: syntax - XMETADescription: Options for syntax extensions - XMETARequires: camlp4 - -Library "lwt-syntax-log" - FindlibName: log - FindlibParent: lwt-syntax - Path: syntax - Modules: Pa_lwt_log - BuildDepends: camlp4.lib, camlp4.quotations.o - XMETAType: syntax - XMETADescription: Syntactic sugars for logging - XMETARequires: camlp4, lwt.syntax.options - -# +-------------------------------------------------------------------+ -# | Toplevel | -# +-------------------------------------------------------------------+ - -Executable "lwt-toplevel" - Build$: flag(toplevel) || flag(all) - Install$: flag(toplevel) || flag(all) - Path: src/top - CompiledObject: byte - MainIs: lwt_toplevel.ml - BuildDepends: lwt, lwt.top, lwt.text, lwt.react, text, findlib, unix - -# +-------------------------------------------------------------------+ -# | Doc | -# +-------------------------------------------------------------------+ - -Document "lwt-manual" - Title: Lwt user manual - Type: custom (0.2) - Install: true - XCustom: make -C manual manual.pdf - DataFiles: manual/manual.pdf - InstallDir: $pdfdir - -Document "lwt-api" - Title: API reference for Lwt - Type: ocamlbuild (0.2) - Install: true - InstallDir: $htmldir/api - DataFiles: utils/style.css - BuildTools: ocamldoc - XOCamlbuildPath: ./ - XOCamlbuildLibraries: - lwt, - lwt.extra, - lwt.glib, - lwt.preemptive, - lwt.react, - lwt.ssl, - lwt.text, - lwt.top, - lwt.unix, - lwt.syntax, - lwt.syntax.log - -# +-------------------------------------------------------------------+ -# | Examples | -# +-------------------------------------------------------------------+ - -Executable logging - Path: examples/unix - Build$: flag(unix) - Install: false - MainIs: logging.ml - BuildDepends: lwt.unix, lwt.syntax - CompiledObject: best - -Executable relay - Path: examples/unix - Build$: flag(unix) - Install: false - MainIs: relay.ml - BuildDepends: lwt.unix, lwt.syntax - CompiledObject: best - -Executable parallelize - Path: examples/unix - Build$: flag(unix) - Install: false - MainIs: parallelize.ml - BuildDepends: lwt.unix, lwt.syntax - CompiledObject: best - -# +-------------------------------------------------------------------+ -# | Tests | -# +-------------------------------------------------------------------+ - -Library test - Path: tests - Modules: Test - Install: false - Build$: flag(unix) || flag(all) - -Executable test_core - Path: tests/core - Build$: flag(unix) || flag(all) - Install: false - CompiledObject: best - MainIs: main.ml - BuildDepends: test, lwt, unix, lwt.unix - -Executable test_unix - Path: tests/unix - Build$: flag(unix) || flag(all) - Install: false - CompiledObject: best - MainIs: main.ml - BuildDepends: test, lwt, unix, lwt.unix - -Executable test_react - Path: tests/react - Build$: (flag(unix) && flag(react)) || flag(all) - Install: false - CompiledObject: best - MainIs: main.ml - BuildDepends: test, lwt, unix, lwt.unix, react, lwt.react - -Test core - Command: $test_core - TestTools: test_core - Run$: flag(unix) || flag(all) - -Test unix - Command: $test_unix - TestTools: test_unix - Run$: flag(unix) || flag(all) - -Test react - Command: $test_react - TestTools: test_react - Run$: (flag(unix) && flag(react)) || flag(all) - -# +-------------------------------------------------------------------+ -# | Misc | -# +-------------------------------------------------------------------+ - -SourceRepository head - Type: darcs - Location: http://ocsigen.org/darcs/lwt - Browser: http://ocsigen.org/darcsweb/?r=lwt;a=summary diff --git a/server/thirdparty/lwt-2.3.2/_tags b/server/thirdparty/lwt-2.3.2/_tags deleted file mode 100644 index 81f7f8e..0000000 --- a/server/thirdparty/lwt-2.3.2/_tags +++ /dev/null @@ -1,223 +0,0 @@ -# -*- conf -*- - -<**/*.ml>: syntax_camlp4o, pkg_camlp4 -<**/*.ml>: pa_lwt_options, pa_lwt, pa_lwt_log, pa_optcomp -: -pa_lwt_options, -pa_lwt, -pa_lwt_log, -pa_optcomp - -: use_compiler_libs, pkg_text, pkg_text.bigarray, pkg_findlib, pkg_react, pkg_unix, pkg_bigarray - -: use_stubs - -"src/unix/lwt_io.mli": syntax_camlp4o, pkg_camlp4, pa_optcomp - -# GLib bindings: -: use_C_glib -: use_C_glib -: use_C_glib - -# OASIS_START -# DO NOT EDIT (digest: 1e926c0b1533824658bafa01bc7a4af4) -# Library lwt -"src/core": include -"src/core/lwt.cmxs": use_lwt -# Library lwt-unix -"src/unix": include -"src/unix/lwt-unix.cmxs": use_lwt-unix -: oasis_library_lwt_unix_cclib -"src/unix/liblwt-unix.lib": oasis_library_lwt_unix_cclib -"src/unix/dlllwt-unix.dll": oasis_library_lwt_unix_cclib -"src/unix/liblwt-unix.a": oasis_library_lwt_unix_cclib -"src/unix/dlllwt-unix.so": oasis_library_lwt_unix_cclib -: use_liblwt-unix -: use_lwt -: pkg_unix -: pkg_bigarray -"src/unix/lwt_unix_stubs.c": use_lwt -"src/unix/lwt_unix_stubs.c": pkg_unix -"src/unix/lwt_unix_stubs.c": pkg_bigarray -"src/unix/lwt_libev_stubs.c": use_lwt -"src/unix/lwt_libev_stubs.c": pkg_unix -"src/unix/lwt_libev_stubs.c": pkg_bigarray -# Library lwt-react -"src/react": include -"src/react/lwt-react.cmxs": use_lwt-react -: use_lwt -: pkg_react -# Library test -"tests": include -"tests/test.cmxs": use_test -# Library lwt-text -"src/text": include -"src/text/lwt-text.cmxs": use_lwt-text -: use_liblwt-text -: use_lwt-react -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_text.bigarray -: pkg_text -: pkg_react -: pkg_bigarray -"src/text/lwt_text_stubs.c": use_lwt-react -"src/text/lwt_text_stubs.c": use_lwt-unix -"src/text/lwt_text_stubs.c": use_lwt -"src/text/lwt_text_stubs.c": pkg_unix -"src/text/lwt_text_stubs.c": pkg_text.bigarray -"src/text/lwt_text_stubs.c": pkg_text -"src/text/lwt_text_stubs.c": pkg_react -"src/text/lwt_text_stubs.c": pkg_bigarray -# Executable test_unix -: use_test -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_bigarray -: use_test -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_bigarray -# Library lwt-syntax -"syntax/lwt-syntax.cmxs": use_lwt-syntax -: pkg_camlp4.extend -# Executable test_react -: use_test -: use_lwt-react -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_react -: pkg_bigarray -: use_test -: use_lwt-react -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_react -: pkg_bigarray -# Executable test_core -: use_test -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_bigarray -: use_test -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_bigarray -# Library lwt-top -"src/top": include -"src/top/lwt-top.cmxs": use_lwt-top -# Library lwt-preemptive -"src/preemptive": include -"src/preemptive/lwt-preemptive.cmxs": use_lwt-preemptive -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_threads -: pkg_bigarray -# Library lwt-simple-top -"src/simple_top": include -"src/simple_top/lwt-simple-top.cmxs": use_lwt-simple-top -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_bigarray -# Library lwt-glib -"src/glib": include -"src/glib/lwt-glib.cmxs": use_lwt-glib -: use_liblwt-glib -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_bigarray -"src/glib/lwt_glib_stubs.c": use_lwt-unix -"src/glib/lwt_glib_stubs.c": use_lwt -"src/glib/lwt_glib_stubs.c": pkg_unix -"src/glib/lwt_glib_stubs.c": pkg_bigarray -# Executable relay -: use_lwt-syntax -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_camlp4.quotations.o -: pkg_camlp4.lib -: pkg_camlp4.extend -: pkg_bigarray -# Executable logging -: use_lwt-syntax -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_camlp4.quotations.o -: pkg_camlp4.lib -: pkg_camlp4.extend -: pkg_bigarray -# Library lwt-syntax-log -"syntax/lwt-syntax-log.cmxs": use_lwt-syntax-log -# Executable lwt-toplevel -"src/top/lwt_toplevel.byte": use_lwt-top -"src/top/lwt_toplevel.byte": use_lwt-text -"src/top/lwt_toplevel.byte": use_lwt-react -"src/top/lwt_toplevel.byte": use_lwt-unix -"src/top/lwt_toplevel.byte": use_lwt -"src/top/lwt_toplevel.byte": pkg_unix -"src/top/lwt_toplevel.byte": pkg_text.bigarray -"src/top/lwt_toplevel.byte": pkg_text -"src/top/lwt_toplevel.byte": pkg_react -"src/top/lwt_toplevel.byte": pkg_findlib -"src/top/lwt_toplevel.byte": pkg_bigarray -: use_lwt-top -: use_lwt-text -: use_lwt-react -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_text.bigarray -: pkg_text -: pkg_react -: pkg_findlib -: pkg_bigarray -# Executable parallelize -: use_lwt-syntax -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_camlp4.quotations.o -: pkg_camlp4.lib -: pkg_camlp4.extend -: pkg_bigarray -: use_lwt-syntax -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_camlp4.quotations.o -: pkg_camlp4.lib -: pkg_camlp4.extend -: pkg_bigarray -# Library lwt-extra -"src/extra": include -"src/extra/lwt-extra.cmxs": use_lwt-extra -: use_lwt-preemptive -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_threads -: pkg_bigarray -# Library optcomp -"syntax/optcomp.cmxs": use_optcomp -: pkg_camlp4.quotations.o -# Library lwt-syntax-options -"syntax": include -"syntax/lwt-syntax-options.cmxs": use_lwt-syntax-options -: pkg_camlp4.lib -# Library lwt-ssl -"src/ssl": include -"src/ssl/lwt-ssl.cmxs": use_lwt-ssl -: use_lwt-unix -: use_lwt -: pkg_unix -: pkg_ssl -: pkg_bigarray -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/apiref-intro b/server/thirdparty/lwt-2.3.2/apiref-intro deleted file mode 100644 index 820378d..0000000 --- a/server/thirdparty/lwt-2.3.2/apiref-intro +++ /dev/null @@ -1,109 +0,0 @@ -{1 Lwt - API Reference} - -{2 Core library} - -The {e core} library ({e lwt} package) contains the {!Lwt} module, which defines -cooperative threads with all the primitives to manipulate them. It -also provides several general purpose modules, which do not depend on -any external package. - -{!modules: -Lwt -Lwt_condition -Lwt_list -Lwt_mutex -Lwt_mvar -Lwt_pool -Lwt_sequence -Lwt_pqueue -Lwt_stream -Lwt_switch -} - -{2 Unix bindings} - -The {e lwt.unix} package provides: -- the {!Lwt_unix} module, which wrap system calls into cooperative ones -- the {!Lwt_io} module, which defines cooperative byte channel, in - replacement of ones of the standard library -- module helpers for logging, spawning processes, ... - -{!modules: -Lwt_daemon -Lwt_gc -Lwt_io -Lwt_log -Lwt_main -Lwt_engine -Lwt_process -Lwt_throttle -Lwt_timeout -Lwt_unix -Lwt_bytes -Lwt_sys -} - -This package depends on the {e core} library and the {e unix} package. - -{2 Reactive programming helpers} - -The {e lwt.react} package provides helpers for functionnal reactive -programming with Lwt. It is based on the {e react} package. The -{!Lwt_react} module is a replacement for the [React] module. It -contains: - -- all the functions of the [React] module -- Lwt specific primitives -- cooperative versions of {e react} functions - -{!modules: -Lwt_react -} - -This package depends on the {e core} library and the {e react} package. - -{2 Syntax extensions} - -Lwt is shipped with two syntax extensions. The first one, contained in -the {e lwt.syntax} package, aims to make coding with Lwt easier, and -to make code more readable. The second, contained in the package {e -lwt.syntax.log}, is a camlp4 filter which decreases the performance -penalty when using logging by inlining level tests. - -{!modules: -Pa_lwt -Pa_lwt_log -} - -{2 Terminal manipulation} - -The package {e lwt.text} provides: -- terminal manipulation through the module {!Lwt_term} -- text channels which behaves as byte channels but are aware of the - text encoding -- a cooperative, fully customizable read-line facility - -{!modules: -Lwt_read_line -Lwt_term -Lwt_text -} - -This package depends on the {e core} library, and the {e lwt.react}, -{e lwt.unix}, {e text} packages. - -{2 Miscellaneous} - -The following modules are wrapper for integration of non-Lwt -functions/packages into Lwt. - -{!modules: -Lwt_glib -Lwt_lib -Lwt_preemptive -Lwt_ssl -} - -{2 Index} - -{!indexlist} diff --git a/server/thirdparty/lwt-2.3.2/configure b/server/thirdparty/lwt-2.3.2/configure deleted file mode 100755 index 6719c7c..0000000 --- a/server/thirdparty/lwt-2.3.2/configure +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh - -# OASIS_START -# DO NOT EDIT (digest: ed33e59fe00e48bc31edf413bbc8b8d6) -set -e - -ocaml setup.ml -configure $* -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/discover.ml b/server/thirdparty/lwt-2.3.2/discover.ml deleted file mode 100644 index e5edf40..0000000 --- a/server/thirdparty/lwt-2.3.2/discover.ml +++ /dev/null @@ -1,294 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Program discover - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(* Discover available features *) - -(* Keep that in sync with the list in myocamlbuild.ml *) -let search_paths = [ - "/usr"; - "/usr/local"; - "/opt"; - "/opt/local"; - "/sw"; - "/mingw"; -] - -open Printf - -(* +-----------------------------------------------------------------+ - | Test codes | - +-----------------------------------------------------------------+ *) - -let caml_code = " -external test : unit -> unit = \"lwt_test\" -let () = test () -" - -let pthread_code = " -#include -#include - -CAMLprim value lwt_test() -{ - pthread_create(0, 0, 0, 0); - return Val_unit; -} -" - -let libev_code = " -#include -#include - -CAMLprim value lwt_test() -{ - ev_default_loop(0); - return Val_unit; -} -" - -let fd_passing_code = " -#include -#include -#include - -CAMLprim value lwt_test() -{ - struct msghdr msg; - msg.msg_controllen = 0; - msg.msg_control = 0; - return Val_unit; -} -" - -let getcpu_code = " -#include -#define _GNU_SOURCE -#include - -CAMLprim value lwt_test() -{ - sched_getcpu(); - return Val_unit; -} -" - -let affinity_code = " -#include -#define _GNU_SOURCE -#include - -CAMLprim value lwt_test() -{ - sched_getaffinity(0, 0, 0); - return Val_unit; -} -" - -let eventfd_code = " -#include -#include - -CAMLprim value lwt_test() -{ - eventfd(0, 0); - return Val_unit; -} -" - -let get_credentials_code = " -#include -#include -#include - -CAMLprim value lwt_test() -{ - getsockopt(0, SOL_SOCKET, SO_PEERCRED, 0, 0); - return Val_unit; -} -" - -let fdatasync_code = " -#include -#include - -CAMLprim value lwt_test() -{ - fdatasync(0); - return Val_unit; -} -" - -(* +-----------------------------------------------------------------+ - | Compilation | - +-----------------------------------------------------------------+ *) - -let ocamlc = ref "ocamlc" -let ext_obj = ref ".o" -let exec_name = ref "a.out" -let use_libev = ref true -let os_type = ref "Unix" - -let log_file = ref "" -let caml_file = ref "" - -(* Search for a header file in standard directories. *) -let search_header header = - let rec loop = function - | [] -> - None - | dir :: dirs -> - if Sys.file_exists (dir ^ "/include/" ^ header) then - Some dir - else - loop dirs - in - loop search_paths - -let c_args = - let flags path = Printf.sprintf "-ccopt -I%s/include -cclib -L%s/lib" path path in - match search_header "ev.h", search_header "pthread.h" with - | None, None -> "" - | Some path, None | None, Some path -> flags path - | Some path1, Some path2 when path1 = path2 -> flags path1 - | Some path1, Some path2 -> flags path1 ^ " " ^ flags path2 - -let compile args stub_file = - ksprintf - Sys.command - "%s -custom %s %s %s %s > %s 2>&1" - !ocamlc - c_args - (Filename.quote stub_file) - args - (Filename.quote !caml_file) - (Filename.quote !log_file) - = 0 - -let safe_remove file_name = - try - Sys.remove file_name - with exn -> - () - -let test_code args stub_code = - let stub_file, oc = Filename.open_temp_file "lwt_stub" ".c" in - let cleanup () = - safe_remove stub_file; - safe_remove (Filename.chop_extension (Filename.basename stub_file) ^ !ext_obj) - in - try - output_string oc stub_code; - flush oc; - close_out oc; - let result = compile args stub_file in - cleanup (); - result - with exn -> - (try close_out oc with _ -> ()); - cleanup (); - raise exn - -let config = open_out "src/unix/lwt_config.h" -let config_ml = open_out "src/unix/lwt_config.ml" - -let test_feature ?(do_check = true) name macro ?(args="") code = - if do_check then begin - printf "testing for %s:%!" name; - if test_code args code then begin - fprintf config "#define %s\n" macro; - fprintf config_ml "#let %s = true\n" macro; - printf " %s available\n%!" (String.make (34 - String.length name) '.'); - true - end else begin - fprintf config "//#define %s\n" macro; - fprintf config_ml "#let %s = false\n" macro; - printf " %s unavailable\n%!" (String.make (34 - String.length name) '.'); - false - end - end else begin - printf "not checking for %s\n%!" name; - fprintf config "//#define %s\n" macro; - fprintf config_ml "#let %s = false\n" macro; - true - end - -(* +-----------------------------------------------------------------+ - | Entry point | - +-----------------------------------------------------------------+ *) - -let () = - let args = [ - "-ocamlc", Arg.Set_string ocamlc, " ocamlc"; - "-ext-obj", Arg.Set_string ext_obj, " C object files extension"; - "-exec-name", Arg.Set_string exec_name, " name of the executable produced by ocamlc"; - "-use-libev", Arg.Symbol (["true"; "false"], - function - | "true" -> use_libev := true - | "false" -> use_libev := false - | _ -> assert false), " whether to check for libev"; - "-os-type", Arg.Set_string os_type, " type of the target os"; - ] in - Arg.parse args ignore "check for external C libraries and available features\noptions are:"; - - (* Put the caml code into a temporary file. *) - let file, oc = Filename.open_temp_file "lwt_caml" ".ml" in - caml_file := file; - output_string oc caml_code; - close_out oc; - - log_file := Filename.temp_file "lwt_output" ".log"; - - (* Cleanup things on exit. *) - at_exit (fun () -> - (try close_out config with _ -> ()); - (try close_out config_ml with _ -> ()); - safe_remove !log_file; - safe_remove !exec_name; - safe_remove !caml_file; - safe_remove (Filename.chop_extension !caml_file ^ ".cmi"); - safe_remove (Filename.chop_extension !caml_file ^ ".cmo")); - - let missing = [] in - let missing = if test_feature ~do_check:!use_libev "libev" "HAVE_LIBEV" ~args:"-cclib -lev" libev_code then missing else "libev" :: missing in - let missing = if test_feature ~do_check:(!os_type <> "Win32") "pthread" "HAVE_PTHREAD" ~args:"-cclib -lpthread" pthread_code then missing else "pthread" :: missing in - - if missing <> [] then begin - printf " - The following recquired C libraries are missing: %s. -Please install them and retry. If they are installed in a non-standard location, set the environment variables C_INCLUDE_PATH and LIBRARY_PATH accordingly and retry. - -For example, if they are installed in /opt/local, you can type: - -export C_INCLUDE_PATH=/opt/local/include -export LIBRARY_PATH=/opt/local/lib - -To compile without libev support, use ./configure --disable-libev ... -" (String.concat ", " missing); - exit 1 - end; - - ignore (test_feature "eventfd" "HAVE_EVENTFD" eventfd_code); - ignore (test_feature "fd passing" "HAVE_FD_PASSING" fd_passing_code); - ignore (test_feature "sched_getcpu" "HAVE_GETCPU" getcpu_code); - ignore (test_feature "affinity getting/setting" "HAVE_AFFINITY" affinity_code); - ignore (test_feature "credentials getting" "HAVE_GET_CREDENTIALS" get_credentials_code); - ignore (test_feature "fdatasync" "HAVE_FDATASYNC" fdatasync_code) diff --git a/server/thirdparty/lwt-2.3.2/examples/gtk/Makefile b/server/thirdparty/lwt-2.3.2/examples/gtk/Makefile deleted file mode 100644 index 58a20a4..0000000 --- a/server/thirdparty/lwt-2.3.2/examples/gtk/Makefile +++ /dev/null @@ -1,2 +0,0 @@ -all: - ocamlbuild -use-ocamlfind -classic-display -tag 'syntax(camlp4o)' -package lwt.unix,lwt.glib,lwt.syntax,lablgtk2 connect.byte diff --git a/server/thirdparty/lwt-2.3.2/examples/gtk/connect.ml b/server/thirdparty/lwt-2.3.2/examples/gtk/connect.ml deleted file mode 100644 index 463321a..0000000 --- a/server/thirdparty/lwt-2.3.2/examples/gtk/connect.ml +++ /dev/null @@ -1,218 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Program Connect - * Copyright (C) 2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(* A simple graphical telnet. *) - -open Lwt - -(* +-----------------------------------------------------------------+ - | Utils | - +-----------------------------------------------------------------+ *) - -let show_error fmt = - Printf.ksprintf - (fun message -> - let dialog = GWindow.message_dialog ~message_type:`ERROR ~buttons:GWindow.Buttons.ok ~message () in - ignore (dialog#connect#response (function - | `DELETE_EVENT -> () - | `OK -> dialog#destroy ())); - dialog#show ()) - fmt - -(* +-----------------------------------------------------------------+ - | Connection | - +-----------------------------------------------------------------+ *) - -(* Either [None] if we are not connected, either [Some (ic, oc, - thread)] if we are connected. In this last case [thread] is the - thread reading data from the connection. *) -let connection = ref None - -(* Read continously data from [ic] and write them to [view]. *) -let read ic (view : GText.view) = - let rec loop () = - match_lwt Lwt_io.read_line_opt ic with - | Some line -> - view#buffer#insert ~iter:view#buffer#end_iter ~tag_names:["recv"] (line ^ "\n"); - loop () - | None -> - view#buffer#insert ~iter:view#buffer#end_iter "end of connection\n"; - Lwt_io.close ic - in - try_lwt - loop () - with Unix.Unix_error (error, _, _) -> - show_error "reading error: %s" (Unix.error_message error); - return () - -(* Function called when the user active the [connect] menu - item. [view] is the text view used to display data received from - the connection. *) -let connect (view : GText.view) = - (* Create a popup for asking the address and port to connect to. *) - let dialog = GWindow.dialog ~title:"connection" () in - dialog#add_button_stock `OK `OK; - dialog#add_button_stock `CANCEL `CANCEL; - let hbox = GPack.hbox ~packing:dialog#vbox#add () in - ignore (GMisc.label ~packing:hbox#add ~text:"host: " ()); - let host = GEdit.entry ~packing:hbox#add ~text:"127.0.0.1" () in - ignore (GMisc.label ~packing:hbox#add ~text:" port: " ()); - let port = GEdit.spin_button ~digits:0 ~numeric:true ~packing:hbox#add () in - port#adjustment#set_bounds ~lower:0. ~upper:(float max_int) ~step_incr:1. (); - - (* Thread waiting for the popup to be closed. *) - let waiter, wakener = wait () in - - (* Wakeup the thread when the popup is closed. *) - ignore (dialog#connect#response (wakeup wakener)); - - dialog#show (); - - ignore ( - match_lwt waiter with - | `DELETE_EVENT -> - return () - | `CANCEL -> - dialog#destroy (); - return () - | `OK -> - let host = host#text and port = int_of_float port#value in - dialog#destroy (); - try_lwt - (* Resolve the address. *) - lwt entry = Lwt_unix.gethostbyname host in - if Array.length entry.Unix.h_addr_list = 0 then begin - show_error "no address found for host %S" host; - return () - end else begin - lwt ic, oc = Lwt_io.open_connection (Unix.ADDR_INET (entry.Unix.h_addr_list.(0), port)) in - (* Close the previous connection. *) - lwt () = - match !connection with - | None -> - return () - | Some (ic, oc, thread) -> - cancel thread; - try_lwt - Lwt_io.close ic <&> Lwt_io.close oc - with Unix.Unix_error (error, _, _) -> - show_error "cannot close the connection: %s" (Unix.error_message error); - return () - in - (* Clear the buffer. *) - view#buffer#delete view#buffer#start_iter view#buffer#end_iter; - connection := Some (ic, oc, read ic view); - return () - end - with - | Unix.Unix_error (error, _, _) -> - show_error "cannot establish the connection: %s" (Unix.error_message error); - return () - | Not_found -> - show_error "host %S not found" host; - return () - ) - -(* Send some data. *) -let write (view : GText.view) (entry : GEdit.entry) = - let text = entry#text in - entry#set_text ""; - match !connection with - | Some (ic, oc, thread) -> - view#buffer#insert ~iter:view#buffer#end_iter ~tag_names:["send"] (text ^ "\n"); - ignore ( - try_lwt - Lwt_io.write_line oc text - with Unix.Unix_error (error, _, _) -> - show_error "cannot send line: %s" (Unix.error_message error); - return () - ) - | None -> - show_error "not connected" - -(* +-----------------------------------------------------------------+ - | Entry point | - +-----------------------------------------------------------------+ *) - -lwt () = - (* Initializes GTK. *) - ignore (GMain.init ~setlocale:false ()); - - (* Integrate Lwt with Glib. *) - Lwt_glib.install (); - - (* Create the UI. *) - let window = GWindow.window ~title:"simple graphical telnet in OCaml with Lwt" ~allow_shrink:true ~width:640 ~height:480 () in - let vbox = GPack.vbox ~packing:window#add () in - - (* Create the menu. *) - let menu = GMenu.menu_bar ~packing:(vbox#pack ~expand:false) () in - let menu_file = GMenu.menu ~packing:(GMenu.menu_item ~label:"File" ~packing:menu#add ())#set_submenu () in - let menu_connect = GMenu.image_menu_item ~label:"Connect" ~packing:menu_file#add ~stock:`CONNECT () in - ignore (GMenu.separator_item ~packing:menu_file#add ()); - let menu_quit = GMenu.image_menu_item ~label:"Quit" ~packing:menu_file#add ~stock:`QUIT () in - - (* The text view displaying inputs and outputs. *) - let view = - GText.view - ~editable:false - ~packing:(GBin.scrolled_window - ~hpolicy:`AUTOMATIC - ~vpolicy:`AUTOMATIC - ~packing:(GBin.frame - ~label:"log" - ~packing:vbox#add - ())#add - ())#add - () - in - - ignore (view#buffer#create_tag ~name:"send" [`FOREGROUND "blue"]); - ignore (view#buffer#create_tag ~name:"recv" [`FOREGROUND "#007f00"]); - - let hbox = GPack.hbox ~packing:(GBin.frame ~label:"input" ~packing:(vbox#pack ~expand:false) ())#add () in - - (* The entry for user input. *) - let entry = GEdit.entry ~packing:hbox#add () in - let send = GButton.button ~label:"send" ~packing:(hbox#pack ~expand:false) () in - - (* Try to use a monospace font. *) - (try - view#misc#modify_font_by_name "Monospace"; - entry#misc#modify_font_by_name "Monospace" - with _ -> - ()); - - (* Thread waiting for the main window to be closed. *) - let waiter, wakener = wait () in - - (* Setup callbacks. *) - ignore (window#connect#destroy (wakeup wakener)); - ignore (menu_quit#connect#activate (wakeup wakener)); - ignore (menu_connect#connect#activate (fun () -> connect view)); - ignore (entry#connect#activate (fun () -> write view entry)); - ignore (send#connect#clicked (fun () -> write view entry)); - - window#show (); - - (* Wait for the main window to be closed. *) - waiter diff --git a/server/thirdparty/lwt-2.3.2/examples/unix/logging.ml b/server/thirdparty/lwt-2.3.2/examples/unix/logging.ml deleted file mode 100644 index e0209fe..0000000 --- a/server/thirdparty/lwt-2.3.2/examples/unix/logging.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Program Logging - * Copyright (C) 2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(* This example illustrate the use of the Lwt_log module from - lwt.unix. *) - -(* The logging section for this module: *) -let section = Lwt_log.Section.make "test" - -lwt () = - (* Enable all logging levels superior from [Info] to [Fatal]: *) - Lwt_log.Section.set_level section Lwt_log.Info; - - (* A message with the default logger: *) - lwt () = Lwt_log.log ~section ~level:Lwt_log.Info "this message will appear only on stderr" in - - (* Same as begore, but using [Lwt_log.info]: *) - lwt () = Lwt_log.info ~section "this one too" in - - (* A message to a custom logger, logging simultaneously to [stderr] - and to the system logger daemon: *) - let logger = - Lwt_log.broadcast - [Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr (); - Lwt_log.syslog ~facility:`User ()] - in - lwt () = Lwt_log.info ~section ~logger "this message will appear on stderr and in '/var/log/user.log'" in - - (* Logging of exceptions: *) - Printexc.record_backtrace true; - let f () : unit = raise Exit in - let g () = f () in - let h () = g () in - lwt () = - try - h (); - Lwt.return () - with exn -> - Lwt_log.error ~section ~exn "h failed with" - in - - let logger = Lwt_log.channel ~template:"$(name): $(section): $(loc-file): $(loc-line): $(loc-column): $(message)" ~close_mode:`Keep ~channel:Lwt_io.stderr () in - Lwt_log.info ~section ~logger "this message will appear with a location" diff --git a/server/thirdparty/lwt-2.3.2/examples/unix/parallelize.ml b/server/thirdparty/lwt-2.3.2/examples/unix/parallelize.ml deleted file mode 100644 index bd72c82..0000000 --- a/server/thirdparty/lwt-2.3.2/examples/unix/parallelize.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Program Parallelize - * Copyright (C) 2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(* Reads commands from standard input and launch them in parallel, - using as many processes as the number of CPUs. *) - -open Lwt - -(* Reads one command, launch it and waits for when it termination, - then start again: *) -let rec launch () = - match_lwt Lwt_io.read_line_opt Lwt_io.stdin with - | None -> - return () - | Some line -> - lwt exit_status = Lwt_process.exec (Lwt_process.shell line) in - launch () - -(* Creates the initial threads, where is the number of - CPUs: *) -let rec create_threads = function - | 0 -> - return () - | n -> - launch () <&> create_threads (n - 1) - -(* Counts the number of CPUs using "/proc/cpuinfo": *) -let cpus_count () = - Lwt_stream.fold (fun _ n -> succ n) - (Lwt_stream.filter - (fun line -> - try - Scanf.sscanf line "processor :" true - with _ -> - false) - (Lwt_io.lines_of_file "/proc/cpuinfo")) 0 - -lwt () = cpus_count () >>= create_threads diff --git a/server/thirdparty/lwt-2.3.2/examples/unix/relay.ml b/server/thirdparty/lwt-2.3.2/examples/unix/relay.ml deleted file mode 100644 index 3ffa0a2..0000000 --- a/server/thirdparty/lwt-2.3.2/examples/unix/relay.ml +++ /dev/null @@ -1,156 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Program Relay - * Copyright (C) 2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(* Relay data from an address to another. *) - -open Lwt - -(* +-----------------------------------------------------------------+ - | Relaying | - +-----------------------------------------------------------------+ *) - -(* Write exactly [len] bytes from [buf] at [ofs]. *) -let rec write_exactly fd buf ofs len = - lwt n = Lwt_bytes.write fd buf ofs len in - if n = len then - (* Everything has been written, do nothing. *) - return () - else - (* Write remaining data. *) - write_exactly fd buf (ofs + n) (len - n) - -(* Copy continously data from [in_fd] to [out_fd]. *) -let relay in_fd out_fd = - (* Queue of data received but not yet written. *) - let queue = Queue.create () in - - (* Condition used to signal the writer that some data are - available. *) - let cond = Lwt_condition.create () in - - (* Boolean which tells whether the input socket has been closed. *) - let end_of_input = ref false in - - (* Write continously data received to [out_fd]. *) - let rec loop_write () = - if Queue.is_empty queue then - if !end_of_input then - (* End of input reached, exit. *) - return () - else - (* There is no data pending, wait for some. *) - lwt () = Lwt_condition.wait cond in - loop_write () - else - let (buf, len) = Queue.take queue in - lwt () = write_exactly out_fd buf 0 len in - loop_write () - in - - (* Start the writer. *) - let writer = loop_write () in - - (* Read continously from [in_fd]. *) - let rec loop_read () = - let buf = Lwt_bytes.create 8192 in - match_lwt Lwt_bytes.read in_fd buf 0 8192 with - | 0 -> - (* If we read nothing, this means that the connection has - been closed. *) - (* Mark the end of input has reached. *) - end_of_input := true; - (* Singal the writer in case it is waiting for data. *) - Lwt_condition.signal cond (); - (* Wait for it to terminate. *) - writer - | n -> - (* Otherwise, send data to the writer. *) - Queue.add (buf, n) queue; - (* Singal the writer in case it is waiting for data. *) - Lwt_condition.signal cond (); - loop_read () - in - - (* Wait for either the reader to terminate or the writer to fail. *) - pick [writer; loop_read ()] - -(* +-----------------------------------------------------------------+ - | Entry point | - +-----------------------------------------------------------------+ *) - -let usage () = - prerr_endline "usage: relay : :"; - exit 2 - -(* Convert a string of the form ":" to an internet address - object. *) -let addr_of_string str = - (* Split the host and the port. *) - let idx = try String.index str ':' with Not_found -> usage () in - let host = String.sub str 0 idx and port = String.sub str (idx + 1) (String.length str - idx - 1) in - (* Parse the port. *) - let port = try int_of_string port with Failure _ -> usage () in - (* Request the address of the host. *) - lwt entry = Lwt_unix.gethostbyname host in - if Array.length entry.Unix.h_addr_list = 0 then begin - Printf.eprintf "no address found for host %S\n" host; - exit 1 - end; - return (Unix.ADDR_INET (entry.Unix.h_addr_list.(0), port)) - -lwt () = - if Array.length Sys.argv <> 3 then usage (); - - try_lwt - (* Resolve addresses. *) - lwt src_addr = addr_of_string Sys.argv.(1) and dst_addr = addr_of_string Sys.argv.(2) in - - (* Initialize the listening address. *) - let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - Lwt_unix.setsockopt sock Unix.SO_REUSEADDR true; - Lwt_unix.bind sock src_addr; - Lwt_unix.listen sock 1024; - - ignore (Lwt_log.notice "waiting for connection"); - - (* Wait for a connection. *) - lwt fd1, _ = Lwt_unix.accept sock in - - ignore (Lwt_log.notice "connection received, start relayling"); - - (* Closes the no-more used listening socket. *) - lwt () = Lwt_unix.close sock in - - (* Connect to the destination port. *) - let fd2 = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - lwt () = Lwt_unix.connect fd2 dst_addr in - - (* Start relaying. *) - lwt () = pick [relay fd1 fd2; relay fd2 fd1] in - - ignore (Lwt_log.notice "done relayling"); - - return () - - with exn -> - ignore (Lwt_log.error ~exn "something went wrong"); - exit 1 diff --git a/server/thirdparty/lwt-2.3.2/lwt-api.odocl b/server/thirdparty/lwt-2.3.2/lwt-api.odocl deleted file mode 100644 index 67e416c..0000000 --- a/server/thirdparty/lwt-2.3.2/lwt-api.odocl +++ /dev/null @@ -1,40 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 11d6fd54a0a3f207d6602a7b1da2317e) -src/core/Lwt_condition -src/core/Lwt_list -src/core/Lwt -src/core/Lwt_mutex -src/core/Lwt_mvar -src/core/Lwt_pool -src/core/Lwt_sequence -src/core/Lwt_stream -src/core/Lwt_switch -src/core/Lwt_util -src/core/Lwt_pqueue -src/extra/Lwt_lib -src/glib/Lwt_glib -src/preemptive/Lwt_preemptive -src/react/Lwt_event -src/react/Lwt_signal -src/react/Lwt_react -src/ssl/Lwt_ssl -src/text/Lwt_text -src/text/Lwt_term -src/text/Lwt_read_line -src/top/Lwt_top -src/unix/Lwt_chan -src/unix/Lwt_daemon -src/unix/Lwt_gc -src/unix/Lwt_io -src/unix/Lwt_log -src/unix/Lwt_main -src/unix/Lwt_process -src/unix/Lwt_throttle -src/unix/Lwt_timeout -src/unix/Lwt_unix -src/unix/Lwt_sys -src/unix/Lwt_engine -src/unix/Lwt_bytes -syntax/Pa_lwt -syntax/Pa_lwt_log -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/manual/Makefile b/server/thirdparty/lwt-2.3.2/manual/Makefile deleted file mode 100644 index 09d009a..0000000 --- a/server/thirdparty/lwt-2.3.2/manual/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -# Makefile -# -------- -# Copyright : (c) 2010, Jeremie Dimino -# Licence : BSD3 -# -# This file is a part of lwt. - -all: manual.pdf - -manual-wiki.tex: manual.wiki - latex_of_wiki < manual.wiki > manual-wiki.tex - -manual.pdf: manual.tex manual-wiki.tex - rubber --pdf manual.tex - -clean-aux: - rm -f .latex_of_wiki_offsets *.log *.aux *.out *.toc - -clean: clean-aux - rm -f manual.pdf manual-wiki.tex diff --git a/server/thirdparty/lwt-2.3.2/manual/manual-wiki.tex b/server/thirdparty/lwt-2.3.2/manual/manual-wiki.tex deleted file mode 100644 index e56f773..0000000 --- a/server/thirdparty/lwt-2.3.2/manual/manual-wiki.tex +++ /dev/null @@ -1,1359 +0,0 @@ - -\section{ Introduction } - -When writing a program, a common developer's task is to handle IO -operations. Indeed most software interact with several different -resources, such as: - - - -\begin{itemize} -\item the kernel, by doing system calls -\item the user, by reading the keyboard, the mouse, or any input device -\item a graphical server, to build graphical user interface -\item other computers, by using the network -\item ... - -\end{itemize} - -When this list contains only one item, it is pretty easy to -handle. However as this list grows it becomes harder and harder to -make everything works together. Several choices have been proposed -to solve this problem: - - - -\begin{itemize} -\item using a main loop, and integrate all components we are -interacting with into this main loop. -\item using preemptive system threads - -\end{itemize} - -Both solution have their advantages and their drawbacks. For the -first one, it may works, but it becomes very complicated to write -some piece of asynchronous sequential code. The typical example being with -graphical user interfaces freezing and not redrawing themselves -because they are waiting for some blocking part of the code to -complete. - - - -If you already wrote code using preemptive threads, you shall know -that doing it right with threads is a hard job. Moreover system -threads consume non negligible resources, and so you can only launch -a limited number of threads at the same time. Thus this is not a -real solution. - - - -{\tt Lwt} offers a new alternative. It provides very light-weight -cooperative threads; ``launching'' a thread is a very quick -operation, it does not require a new stack, a new process, or -anything else. Moreover context switches are very fast. In fact, it -is so easy that we will launch a thread for every system call. And -composing cooperative threads will allow us to write highly -asynchronous programs. - - - -In a first part, we will explain the concepts of {\tt Lwt}, then we will -describe the many sub-libraries of {\tt Lwt}. - - - -\section{ The Lwt core library } - -In this section we describe the basics of {\tt Lwt}. It is advised to -start an ocaml toplevel and try the given code examples. To start, -launch {\tt ocaml} in a terminal or in emacs with the tuareg -mode, and type: - - - -\begin{verbatim} -# #use "topfind";; -# #require "lwt";; - -\end{verbatim} - -{\tt Lwt} is also shipped with an improved toplevel, which supports line -edition and completion. If it has been correctly installed, you -should be able to start it with the following command: - - - -\begin{verbatim} -$ lwt-toplevel - -\end{verbatim} - -\subsection{ Lwt concepts } - -Let's take a classical function of the {\tt Pervasives} module: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# Pervasives.input_char; -- : in_channel -> char = - -\end{lstlisting} -This function will wait for a character to come on the given input -channel, then return it. The problem with this function is that it is -blocking: while it is being executed, the whole program will be -blocked, and other events will not be handled until it returns. - - - -Now let's look at the lwt equivalent: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# Lwt_io.read_char;; -- : Lwt_io.input_channel -> char Lwt.t = - -\end{lstlisting} -As you can see, it does not returns a character but something of -type {\tt char Lwt.t}. The type {\tt 'a Lwt.t} is the type -of threads returning a value of type {\tt 'a}. Actually the -{\tt Lwt\_io.read\_char} will try to read a character from the -given input channel and \emph{immediatly} returns a light-weight -thread. - - - -Now, let's see what we can do with a {\tt Lwt} thread. The following -code create a pipe, and launch a thread reading on the input side: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# let ic, oc = Lwt_io.pipe ();; -val ic : Lwt_io.input_channel = -val oc : Lwt_io.output_channel = -# let t = Lwt_io.read_char ic;; -val t : char Lwt.t = - -\end{lstlisting} -We can now look at the state of our newly created thread: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# Lwt.state t;; -- : char Lwt.state = Sleep - -\end{lstlisting} -A thread may be in one of the following states: - - - -\begin{itemize} -\item {\tt Return x}, which means that the thread has terminated -successfully and returned the value {\tt x} -\item {\tt Fail exn}, which means that the thread has terminated, -but instead of returning a value, it failed with the exception -{\tt exn} -\item {\tt Sleep}, which means that the thread is currently -sleeping and have not yet returned a value or an exception - -\end{itemize} - -The thread {\tt t} is sleeping because there is currently nothing -to read on the pipe. Let's write something: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# Lwt_io.write_char oc 'a';; -- : unit Lwt.t = -# Lwt.state t;; -- : char Lwt.state = Return 'a' - -\end{lstlisting} -So, after we write something, the reading thread has been wakeup and -has returned the value {\tt 'a'}. - - - -\subsection{ Primitives for thread creation } - -There are several primitives for creating {\tt Lwt} threads. These -functions are located in the module {\tt Lwt}. - - - -Here are the main primitives: - - - -\begin{itemize} -\item {\tt Lwt.return : 'a -> 'a Lwt.t} -\mbox{}\\ -creates a thread which has already terminated and returned a value -\item {\tt Lwt.fail : exn -> 'a Lwt.t} -\mbox{}\\ -creates a thread which has already terminated and failed with an -exception -\item {\tt Lwt.wait : unit -> 'a Lwt.t * 'a Lwt.u} -\mbox{}\\ -creates a sleeping thread and returns this thread plus a wakener (of -type {\tt 'a Lwt.u}) which must be used to wakeup the sleeping -thread. - -\end{itemize} - -To wake up a sleeping thread, you must use one of the following -functions: - - - -\begin{itemize} -\item {\tt Lwt.wakeup : 'a Lwt.u -> 'a -> unit} -\mbox{}\\ -wakes up the thread with a value. -\item {\tt Lwt.wakeup\_exn : 'a Lwt.u -> exn -> unit} -\mbox{}\\ -wakes up the thread with an exception. - -\end{itemize} - -Note that this is an error to wakeup two times the same threads. {\tt Lwt} -will raise {\tt Invalid\_argument} if you try to do so. - - - -With these informations, try to guess the result of each of the -following expression: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# Lwt.state (Lwt.return 42);; -# Lwt.state (fail Exit);; -# let waiter, wakener = Lwt.wait ();; -# Lwt.state waiter;; -# Lwt.wakeup wakener 42;; -# Lwt.state waiter;; -# let waiter, wakener = Lwt.wait ();; -# Lwt.state waiter;; -# Lwt.wakeup_exn wakener Exit;; -# Lwt.state waiter;; - -\end{lstlisting} -\subsubsection{ Primitives for thread composition } - -The most important operation you need to know is {\tt bind}: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val bind : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t - -\end{lstlisting} -{\tt bind t f} creates a thread which waits for {\tt t} to -terminates, then pass the result to {\tt f}. If {\tt t} is a -sleeping thread, then {\tt bind t f} will be a sleeping thread too, -until {\tt t} terminates. If {\tt t} fails, then the resulting -thread will fail with the same exception. For example, consider the -following expression: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -Lwt.bind - (Lwt_io.read_line Lwt_io.stdin) - (fun str -> Lwt_io.printlf "You typed %S" str) - -\end{lstlisting} -This code will first wait for the user to enter a line of text, then -print a message on the standard output. - - - -Similarly to {\tt bind}, there is a function to handle the case -when {\tt t} fails: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val catch : (unit -> 'a Lwt.t) -> (exn -> 'a Lwt.t) -> 'a Lwt.t - -\end{lstlisting} -{\tt catch f g} will call {\tt f ()}, then waits for its -termination, and if it fails with an exception {\tt exn}, calls -{\tt g exn} to handle it. Note that both exceptions raised with -{\tt Pervasives.raise} and {\tt Lwt.fail} are caught by -{\tt catch}. - - - -\subsubsection{ Cancelable threads } - -In some case, we may want to cancel a thread. For example, because it -has not terminated after a timeout. This can be done with cancelable -threads. To create a cancelable thread, you must use the -{\tt Lwt.task} function: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val task : unit -> 'a Lwt.t * 'a Lwt.u - -\end{lstlisting} -It has the same semantic as {\tt Lwt.wait} except that the -sleeping thread can be canceled with {\tt Lwt.cancel}: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val cancel : 'a Lwt.t -> unit - -\end{lstlisting} -The thread will then fails with the exception -{\tt Lwt.Canceled}. To execute a function when the thread is -canceled, you must use {\tt Lwt.on\_cancel}: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val on_cancel : 'a Lwt.t -> (unit -> unit) -> unit - -\end{lstlisting} -Note that it is also possible to cancel a thread which has not been -created with {\tt Lwt.task}. In this case, the deepest cancelable -thread connected with the given thread will be cancelled. - - - -For example, consider the following code: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# let waiter, wakener = Lwt.task ();; -val waiter : '_a Lwt.t = -val wakener : '_a Lwt.u = -# let t = bind waiter (fun x -> return (x + 1));; -val t : int Lwt.t = - -\end{lstlisting} -Here, cancelling {\tt t} will in fact cancel {\tt waiter}. -{\tt t} will then fails with the exception {\tt Lwt.Canceled}: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# Lwt.cancel t;; -- : unit = () -# Lwt.state waiter;; -- : int Lwt.state = Fail Lwt.Canceled -# Lwt.state t;; -- : int Lwt.state = Fail Lwt.Canceled - -\end{lstlisting} -By the way, it is possible to prevent a thread from being canceled -by using the function {\tt Lwt.protected}: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val protected : 'a Lwt.t -> 'a Lwt.t - -\end{lstlisting} -Canceling {\tt (proctected t)} will have no effect on {\tt t}. - - - -\subsubsection{ Primitives for multi-thread composition } - -We now show how to compose several threads at the same time. The -main functions for this are in the {\tt Lwt} module: {\tt join}, -{\tt choose} and {\tt pick}. - - - -The first one, {\tt join} takes a list of threads and wait for all -of them to terminate: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val join : unit Lwt.t list -> unit Lwt.t - -\end{lstlisting} -Moreover, if at least one thread fails, {\tt join l} will fails with -the same exception as the first to fail, after all threads threads terminated. - - - -On the contrary {\tt choose} waits for at least one thread to -terminate, then returns the same value or exception: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val choose : 'a Lwt.t list -> 'a Lwt.t - -\end{lstlisting} -For example: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# let waiter1, wakener1 = Lwt.wait ();; -val waiter1 : '_a Lwt.t = -val wakener1 : '_a Lwt.u = -# let waiter2, wakener2 = Lwt.wait ();; -val waiter2 : '_a Lwt.t = -val wakener : '_a Lwt.u = -# let t = Lwt.choose [waiter1; waiter2];; -val t : '_a Lwt.t = -# Lwt.state t;; -- : '_a Lwt.state = Sleep -# Lwt.wakeup wakener2 42;; -- : unit = () -# Lwt.state t;; -- : int Lwt.state = Return 42 - -\end{lstlisting} -Thel last one, {\tt pick}, is the same as {\tt join} except that it cancels -all other threads when one terminates. - - - -\subsubsection{ Threads local storage } - -Lwt can stores variables with different values on different -threads. This is called threads local storage. For example, this can -be used to store contexts or thread identifiers. The contents of a -variable can be read with: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val Lwt.get : 'a Lwt.key -> 'a option - -\end{lstlisting} -which takes a key to identify the variable we want to read and -returns either {\tt None} if the variable is not set, or -{\tt Some x} if it is. The value returned is the value of the -variable in the current thread. - - - -New keys can be created with: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val Lwt.new_key : unit -> 'a Lwt.key - -\end{lstlisting} -To set a variable, you must use: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val Lwt.with_value : 'a Lwt.key -> 'a option -> (unit -> 'b) -> 'b - -\end{lstlisting} -{\tt with\_value key value f} will executes {\tt f} with -the binding {\tt key -> value}. The old value associated to -{\tt key} is restored after {\tt f} terminates. - - - -For example, you can use local storage to store thread identifiers -and use them in logs: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -let id_key = Lwt.new_key () - -let log msg = - let thread_id = - match Lwt.get id_key with - | Some id -> id - | None -> "main" - in - Lwt_io.printlf "%s: %s" thread_id msg - -lwt () = - Lwt.join [ - Lwt.with_value id_key (Some "thread 1") (fun () -> log "foo"); - Lwt.with_value id_key (Some "thread 2") (fun () -> log "bar"); - ] - -\end{lstlisting} -\subsubsection{ Rules } - -{\tt Lwt} will always try to execute the more it can before yielding and -switching to another cooperative thread. In order to make it works well, -you must follow the following rules: - - - -\begin{itemize} -\item do not write function that may takes time to complete without -using {\tt Lwt}, -\item do not do IOs that may block, otherwise the whole program will -hang. You must instead use asynchronous IOs operations. - -\end{itemize} - -\subsection{ The syntax extension } - -{\tt Lwt} offers a syntax extension which increases code readability and -makes coding using {\tt Lwt} easier. To use it add the ``lwt.syntax'' package when -compiling: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -$ ocamlfind ocamlc -syntax camlp4o -package lwt.syntax -linkpkg -o foo foo.ml - -\end{lstlisting} -Or in the toplevel (after loading topfind): - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# #camlp4o;; -# #require "lwt.syntax";; - -\end{lstlisting} -The following construction are added to the language: - - - -\begin{itemize} -\item {\tt lwt} \emph{pattern$_{\mbox{1}}$} {\tt =} \emph{expr$_{\mbox{1}}$} [ {\tt and} -\emph{pattern$_{\mbox{2}}$} {\tt =} \emph{expr$_{\mbox{2}}$} ... ] {\tt in} \emph{expr} -\mbox{}\\ -which is a parallel let-binding construction. For example in the -following code: - -\end{itemize} - -\lstset{language=[Objective]Caml}\begin{lstlisting} -lwt x = f () and y = g () in -expr - -\end{lstlisting} -the thread {\tt f ()} and {\tt g ()} are launched in parallel -and their result are then bound to {\tt x} and {\tt y} in the -expression \emph{expr}. - - - -Of course you can also launch the two threads sequentially by -writing your code like that: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -lwt x = f () in -lwt y = g () in -expr - -\end{lstlisting} -\begin{itemize} -\item {\tt try\_lwt} \emph{expr} [ {\tt with} \emph{pattern$_{\mbox{1}}$} -{\tt ->} \emph{expr$_{\mbox{1}}$} ... ] [ {\tt finally} \emph{expr'} ] -\mbox{}\\ -which is the equivalent of the standard {\tt try-with} -construction but for {\tt Lwt}. Both exception raised by -{\tt Pervasives.raise} and {\tt Lwt.fail} are caught."; - -\end{itemize} - -\begin{itemize} -\item {\tt for\_lwt} \emph{ident} {\tt =} \emph{expr$_{\mbox{init}}$} ( {\tt to} {\tt |} -{\tt downto} ) \emph{expr$_{\mbox{final}}$} {\tt do} \emph{expr} -{\tt done} -\mbox{}\\ -which is the equivalent of the standard {\tt for} construction -but for {\tt Lwt}. - -\end{itemize} - -\begin{itemize} -\item {\tt raise\_lwt} \emph{exn} -\mbox{}\\ -which is the same as {\tt Lwt.fail} \emph{exn} but with backtrace support. - -\end{itemize} - -\subsubsection{ Correspondence table } - -You can keep in mind the following table to write code using lwt: - - - -\noindent -\begin{tabular}{p{0.5\textwidth}p{0.5\textwidth}} -\multicolumn{1}{l}{\begin{minipage}{0.5\textwidth}\centering without {\tt Lwt} \end{minipage}}&\multicolumn{1}{l}{\begin{minipage}{0.5\textwidth}\centering with {\tt Lwt} \end{minipage}}\\ - & \\ - {\tt let} \emph{pattern$_{\mbox{1}}$} {\tt =} \emph{expr$_{\mbox{1}}$} & {\tt lwt} \emph{pattern$_{\mbox{1}}$} {\tt =} \emph{expr$_{\mbox{1}}$} \\ - {\tt and} \emph{pattern$_{\mbox{2}}$} {\tt =} \emph{expr$_{\mbox{2}}$} & {\tt and} \emph{pattern$_{\mbox{2}}$} {\tt =} \emph{expr$_{\mbox{2}}$} \\ - ... & ... \\ - {\tt and} \emph{pattern$_{\mbox{n}}$} {\tt =} \emph{expr$_{\mbox{n}}$} {\tt in} & {\tt and} \emph{pattern$_{\mbox{n}}$} {\tt =} \emph{expr$_{\mbox{n}}$} {\tt in} \\ - \emph{expr} & \emph{expr} \\ - & \\ - {\tt try} & {\tt try\_lwt} \\ - \emph{ expr} & \emph{ expr} \\ - {\tt with} & {\tt with} \\ - \emph{ } {\tt |} \emph{pattern$_{\mbox{1}}$} {\tt ->} \emph{expr$_{\mbox{1}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{1}}$} {\tt ->} \emph{expr$_{\mbox{1}}$} \\ - \emph{ } {\tt |} \emph{pattern$_{\mbox{2}}$} {\tt ->} \emph{expr$_{\mbox{2}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{2}}$} {\tt ->} \emph{expr$_{\mbox{2}}$} \\ - \emph{ } ... & \emph{ } ... \\ - \emph{ } {\tt |} \emph{pattern$_{\mbox{n}}$} {\tt ->} \emph{expr$_{\mbox{n}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{n}}$} {\tt ->} \emph{expr$_{\mbox{n}}$} \\ - & \\ - {\tt for} \emph{ident} {\tt =} \emph{expr$_{\mbox{init}}$} {\tt to} \emph{expr$_{\mbox{final}}$} {\tt do} & {\tt for\_lwt} \emph{ident} {\tt =} \emph{expr$_{\mbox{init}}$} {\tt to} \emph{expr$_{\mbox{final}}$} {\tt do} \\ - \emph{ expr} & \emph{ expr} \\ - {\tt done} & {\tt done} \\ - & \\ - {\tt raise} \emph{exn} & {\tt raise\_lwt} \emph{exn} \\ - & \\ - {\tt assert} \emph{expr} & {\tt assert\_lwt} \emph{expr} \\ - & \\ - {\tt match} \emph{expr} {\tt with} & {\tt match\_lwt} \emph{expr} {\tt with} \\ - \emph{ } {\tt |} \emph{pattern$_{\mbox{1}}$} {\tt ->} \emph{expr$_{\mbox{1}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{1}}$} {\tt ->} \emph{expr$_{\mbox{1}}$} \\ - \emph{ } {\tt |} \emph{pattern$_{\mbox{2}}$} {\tt ->} \emph{expr$_{\mbox{2}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{2}}$} {\tt ->} \emph{expr$_{\mbox{2}}$} \\ - \emph{ } ... & \emph{ } ... \\ - \emph{ } {\tt |} \emph{pattern$_{\mbox{n}}$} {\tt ->} \emph{expr$_{\mbox{n}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{n}}$} {\tt ->} \emph{expr$_{\mbox{n}}$} \\ - & \\ - {\tt while} \emph{expr} {\tt do} & {\tt while\_lwt} \emph{expr} {\tt do} \\ - \emph{ expr} & \emph{ expr} \\ - {\tt done} & {\tt done} \\ -\end{tabular} - -\subsection{ Backtrace support } - -When using {\tt Lwt}, exceptions are not recorded by the ocaml runtime, and so you can not -get backtraces. However it is possible to get them when using the syntax extension. All you -have to do is to pass the {\tt -lwt-debug} switch to {\tt camlp4}: - - - -\begin{verbatim} -$ ocamlfind ocamlc -syntax camlp4o -package lwt.syntax \ - -ppopt -lwt-debug -linkpkg -o foo foo.ml - -\end{verbatim} - -\subsection{ Other modules of the core library } - -The core library contains several modules that depend only on -{\tt Lwt}. The following naming convention is used in {\tt Lwt}: when a -function takes as argument a function returning a thread that is going -to be executed sequentially, it is suffixed with ``{\tt \_s}''. And -when it is going to be executed in parallel, it is suffixed with -``{\tt \_p}''. For example, in the {\tt Lwt\_list} module we have: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t -val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - -\end{lstlisting} -\subsubsection{ Mutexes } - -{\tt Lwt\_mutex} provides mutexes for {\tt Lwt}. Its use is almost the -same as the {\tt Mutex} module of the thread library shipped with -OCaml. In general, programs using {\tt Lwt} do not need a lot of -mutexes. They are only usefull for serialising operations. - - - -\subsubsection{ Lists } - -The {\tt Lwt\_list} module defines iteration and scanning functions -over lists, similar to the ones of the {\tt List} module, but using -functions that return a thread. For example: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t -val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t - -\end{lstlisting} -In {\tt iter\_s f l}, {\tt iter\_s} will call f on each elements -of {\tt l}, waiting for completion between each elements. On the -contrary, in {\tt iter\_p f l}, {\tt iter\_p} will call f on all -elements of {\tt l}, then wait for all the threads to terminate. - - - -\subsubsection{ Data streams } - -{\tt Lwt} streams are used in a lot of places in {\tt Lwt} and its sub -libraries. They offer a high-level interface to manipulate data flows. - - - -A stream is an object which returns elements sequentially and -lazily. Lazily means that the source of the stream is guessed for new -elements only when needed. This module contains a lot of stream -transformation, iteration, and scanning functions. - - - -The common way of creating a stream is by using -{\tt Lwt\_stream.from} or by using {\tt Lwt\_stream.create}: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val from : (unit -> 'a option Lwt.t) -> 'a Lwt_stream.t -val create : unit -> 'a Lwt_stream.t * ('a option -> unit) - -\end{lstlisting} -As for streams of the standard library, {\tt from} takes as -argument a function which is used to create new elements. - - - -{\tt create} returns a function used to push new elements -into the stream and the stream which will receive them. - - - -For example: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# let stream, push = Lwt_stream.create ();; -val stream : '_a Lwt_stream.t = -val push : '_a option -> unit = -# push (Some 1);; -- : unit = () -# push (Some 2);; -- : unit = () -# push (Some 3);; -- : unit = () -# Lwt.state (Lwt_stream.next stream);; -- : int Lwt.state = Return 1 -# Lwt.state (Lwt_stream.next stream);; -- : int Lwt.state = Return 2 -# Lwt.state (Lwt_stream.next stream);; -- : int Lwt.state = Return 3 -# Lwt.state (Lwt_stream.next stream);; -- : int Lwt.state = Sleep - -\end{lstlisting} -Note that streams are consumable. Once you take an element from a -stream, it is removed from it. So, if you want to iterates two times -over a stream, you may consider ``clonning'' it, with -{\tt Lwt\_stream.clone}. Cloned stream will returns the same -elements in the same order. Consuming one will not consume the other. -For example: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# let s = Lwt_stream.of_list [1; 2];; -val s : int Lwt_stream.t = -# let s' = Lwt_stream.clone s;; -val s' : int Lwt_stream.t = -# Lwt.state (Lwt_stream.next s);; -- : int Lwt.state = Return 1 -# Lwt.state (Lwt_stream.next s);; -- : int Lwt.state = Return 2 -# Lwt.state (Lwt_stream.next s');; -- : int Lwt.state = Return 1 -# Lwt.state (Lwt_stream.next s');; -- : int Lwt.state = Return 2 - -\end{lstlisting} -\subsubsection{ Mailbox variables } - -The {\tt Lwt\_mvar} module provides mailbox variables. A mailbox -variable, also called a ``mvar'', is a cell which may contains 0 or 1 -element. If it contains no elements, we say that the mvar is empty, -if it contains one, we say that it is full. Adding an element to a -full mvar will block until one is taken. Taking an element from an -empty mvar will block until one is added. - - - -Mailbox variables are commonly used to pass messages between threads. - - - -Note that a mailbox variable can be seen as a pushable stream with a -limited memory. - - - -\section{ Running a Lwt program } - -Threads you create with {\tt Lwt} always have the type -{\tt Lwt.t}. If you want to write a program and run it this is not -enough. Indeed you don't know when a {\tt Lwt} thread is terminated. - - - -For example if your program is just: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -let _ = Lwt_io.printl "Hello, world!" - -\end{lstlisting} -you have no guarantee that the thread writing {\tt "Hello, world!"} -on the terminal will be terminated when the program exit. In order -to wait for a thread to terminate, you have to call the function -{\tt Lwt\_main.run}: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val Lwt_main.run : 'a Lwt.t -> 'a - -\end{lstlisting} -This functions wait for the given thread to terminate and returns -its result. In fact it does more than that; it also run the -scheduler which is responsible for making thread to progress when -events are received from the outside world. - - - -So basically, when you write a {\tt Lwt} program you must call at -the toplevel the function {\tt Lwt\_main.run}. For instance: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -let () = Lwt_main.run (Lwt_io.printl "Hello, world!") - -\end{lstlisting} -Note that you must call {\tt Lwt\_main.run} only once at a time. It -cannot be used anywhere to get the result of a thread. It must only -be used in the entry point of your program. - - - -\section{ The {\tt lwt.unix} library } - -The package {\tt lwt.unix} contains all {\tt unix} dependant -modules of {\tt Lwt}. Among all its features, it implements cooperative -versions of functions of the standard library and the unix library. - - - -\subsection{ Unix primitives } - -The {\tt Lwt\_unix} provides cooperative system calls. For example, -the {\tt Lwt} counterpart of {\tt Unix.read} is: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val read : file_descr -> string -> int -> int -> int Lwt.t - -\end{lstlisting} -{\tt Lwt\_io} provides features similar to buffered channels of -the standard library (of type {\tt in\_channel} or -{\tt out\_channel}) but cooperatively. - - - -{\tt Lwt\_gc} allow you to register finaliser that return a -thread. At the end of the program, {\tt Lwt} will wait for all the -finaliser to terminates. - - - -\subsection{ The Lwt scheduler } - -Threads doing IO may be put asleep until some events are received by -the process. For example when you read from a file descriptor, you -may have to wait for the file descriptor to become readable if no -data are immediatly available on it. - - - -{\tt Lwt} contains a shceduler which is responsible for managing -multiple threads waiting for events, and restart them when needed. -This scheduler is implemented by the two modules {\tt Lwt\_engine} -and {\tt Lwt\_main}. {\tt Lwt\_engine} is a low-level module, it -provides signatures for IO multiplexers as well as several builtin -implementation. {\tt Lwt} support by default multiplexing IO with -{\tt libev} or {\tt Unix.select}. The signature is given by the -class {\tt Lwt\_engine.t}. - - - -{\tt libev} is used by default on Unix, because it supports any -number of file descriptors while Unix.select supports only 1024 at -most, and is also much more efficient. On Windows {\tt Unix.select} -is used because {\tt libev} does not works properly. The user may -change at any time the backend in use. - - - -The engine can also be used directly in order to integrate other -libraries with {\tt Lwt}. For example {\tt GTK} need to be notified -when some events are received. If you use {\tt Lwt} with {\tt GTK} -you need to use the {\tt Lwt} scheduler to monitor {\tt GTK} -sources. This is what is done by the {\tt lwt.glib} package. - - - -The {\tt Lwt\_main} module contains the \emph{main loop} of -{\tt Lwt}. It is run by calling the function {\tt Lwt\_main.run}: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val Lwt_main.run : 'a Lwt.t -> 'a - -\end{lstlisting} -This function continously run the scheduler until the thread passed -as argument terminates. - - - -\subsection{ The logging facility } - -The package {\tt lwt.unix} contains a module {\tt Lwt\_log} -providing loggers. It support logging to a file, a channel, or to the -syslog daemon. You can also defines your own logger by providing the -appropriate functions (function {\tt Lwt\_log.make}). - - - -Several loggers can be merged into one. Sending logs on the merged -logger will send these logs to all its components. - - - -For example to redirect all logs to {\tt stderr} and to the syslog -daemon: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# Lwt_log.default_logger := - Lwt_log.broadcast [ - Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr (); - Lwt_log.syslog ~facility:`User (); - ] -;; - -\end{lstlisting} -{\tt Lwt} also provides a syntax extension, in the package -{\tt lwt.syntax.log}. It does not modify the language but -it replaces log statement of the form: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -Lwt_log.info_f ~section "something happened: %s" msg - -\end{lstlisting} -by: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -if Lwt_log.Section.level section <= Lwt_log.Info then - Lwt_log.info_f ~section "somethign happend: %s" msg -else - Lwt.return () - -\end{lstlisting} -The advantages of using the syntax extension are the following: - - - -\begin{itemize} -\item it check the log level before calling the logging function, so -arguments are not computed if not needed -\item debugging logs can be removed at parsing time - -\end{itemize} - -By default, the syntax extension remove all logs with the level -{\tt debug}. To keep them pass the command line option -{\tt -lwt-debug} to camlp4. - - - -\section{ The Lwt.react library } - -The {\tt Lwt\_react} module provide helpers for using the {\tt react} -library with {\tt Lwt}. It extends the {\tt React} module by adding -{\tt Lwt} specific functions. It can be used as a replacement of -{\tt React}. For example you can add at the beginning of you -program: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -open Lwt_react - -\end{lstlisting} -instead of: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -open React - -\end{lstlisting} -or: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -module React = Lwt_react - -\end{lstlisting} -Among the added functionnality we have {\tt Lwt\_react.E.next}, which -takes an event and returns a thread which will wait until the next -occurence of this event. For example: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# open Lwt_react;; -# let event, push = E.create ();; -val event : '_a React.event = -val push : '_a -> unit = -# let t = E.next event;; -val t : '_a Lwt.t = -# Lwt.state t;; -- : '_a Lwt.state = Sleep -# push 42;; -- : unit = () -# Lwt.state t;; -- : int Lwt.state = Return 42 - -\end{lstlisting} -Another interesting feature is the ability to limit events -(resp. signals) to occurs (resp. to changes) too often. For example, -suppose you are doing a program which displays something on the screeen -each time a signal changes. If at some point the signal changes 1000 -times per second, you probably want not to render it 1000 times per -second. For that you use {\tt Lwt\_react.S.limit}: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val limit : (unit -> unit Lwt.t) -> 'a React.signal -> 'a React.signal - -\end{lstlisting} -{\tt Lwt\_react.S.limit f signal} returns a signal which varies as -{\tt signal} except that two consecutive updates are separeted by a -call to {\tt f}. For example if {\tt f} returns a thread which sleep -for 0.1 seconds, then there will be no more than 10 changes per -second. For example: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -open Lwt_react - -let draw x = - (* Draw the screen *) - ... - -let () = - (* The signal we are interested in: *) - let signal = ... in - - (* The limited signal: *) - let signal' = S.limit (fun () -> Lwt_unix.sleep 0.1) signal in - - (* Redraw the screen each time the limited signal change: *) - S.notify_p draw signal' - -\end{lstlisting} -\section{ The lwt.text library } - -The {\tt lwt.text} library provides functions to deal with text -mode (in a terminal). It is composed of the three following modules: - - - -\begin{itemize} -\item {\tt Lwt\_text}, which is the equivalent of {\tt Lwt\_io} -but for unicode text channels -\item {\tt Lwt\_term}, providing various terminal utilities, such as -reading a key from the terminal -\item {\tt Lwt\_read\_line}, which provides functions to input text -from the user with line editing support - -\end{itemize} - -\subsection{ Text channels } - -A text channel is basically a byte channel plus an encoding. Input -(resp. output) text channels decode (resp. encode) unicode characters -on the fly. By default, output text channels use transliteration, so -they will not fails because text you want to print cannot be encoded -in the system encoding. - - - -For example, with you locale sets to ``C'', and the variable -{\tt name} set to ``Jérémie'', you got: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# lwt () = Lwt_text.printlf "My name is %s" name;; -My name is J?r?mie - -\end{lstlisting} -\subsection{ Terminal utilities } - -The {\tt Lwt\_term} allow you to put the terminal in \emph{raw mode}, -meanings that input is not buffered and character are -returned as the user type them. For example, you can read a key with: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# lwt key = Lwt_term.read_key ();; -val key : Lwt_term.key = Lwt_term.Key_control 'j' - -\end{lstlisting} -The second main feature of {\tt Lwt\_term} is the ability to prints -text with styles. For example, to print text in bold and blue: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# open Lwt_term;; -# lwt () = printlc [fg blue; bold; text "foo"];; -foo - -\end{lstlisting} -If the output is not a terminal, then {\tt printlc} will drop -styles, and act as {\tt Lwt\_text.printl}. - - - -\subsection{ Read-line } - -{\tt Lwt\_read\_line} provides a full featured and fully -customisable read-line implementation. You can either use the -high-level and easy to use {\tt read\_*} functions, or use the -advanced {\tt Lwt\_read\_line.Control.read\_*} functions. - - - -For example: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -# open Lwt_term;; -# lwt l = Lwt_read_line.read_line ~prompt:[text "foo> "] ();; -foo> Hello, world! -val l : Text.t = "Hello, world!" - -\end{lstlisting} -The second class of functions is a bit more complicated to use, but -allow to control a running read-line instances. For example you can -temporary hide it to draw something, you can send it commands, fake -input, and the prompt is a signal so it can change dynamically. - - - -\section{ Other libraries } - -\subsection{ Detaching computation to preemptive threads } - -It may happen that you want to run a function which will take time to -compute or that you want to use a blocking function that cannot be -used in a non-blocking way. For these situations, {\tt Lwt} allow you to -\emph{detach} the computation to a preemptive thread. - - - -This is done by the module {\tt Lwt\_preemptive} of the -{\tt lwt.preemptive} package which maintains a spool of system -threads. The main function is: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -val detach : ('a -> 'b) -> 'a -> 'b Lwt.t - -\end{lstlisting} -{\tt detach f x} will execute {\tt f x} in another thread and -asynchronously wait for the result. - - - -The {\tt lwt.extra} package provides wrappers for a few blocking -functions of the standard C library like {\tt gethostbyname} (in -the module {\tt Lwt\_lib}). - - - -\subsection{ SSL support } - -The package {\tt lwt.ssl} provides the module {\tt Lwt\_ssl} -which allow to use SSL asynchronously - - - -\subsection{ Glib integration } - -The {\tt lwt.glib} embed the {\tt glib} main loop into the -{\tt Lwt} one. This allow you to write GTK application using {\tt Lwt}. The -one thing you have to do is to call {\tt Lwt\_glib.install} at -the beginning of you program. - - - -\section{ Writing stubs using {\tt Lwt} } - -\subsection{ Thread-safe notifications } - -If you want to notify the main thread from another thread, you can use the {\tt Lwt} -thread safe notification system. First you need to create a notification identifier -(which is just an integer) from the OCaml side using the -{\tt Lwt\_unix.make\_notification} function, then you can send it from either the -OCaml code with {\tt Lwt\_unix.send\_notification} function, or from the C code using -the function {\tt lwt\_unix\_send\_notification} (defined in {\tt lwt\_unix\_.h}). - - - -Notification are received and processed asynchronously by the main thread. - - - -\subsection{ Jobs } - -For operations that can not be executed asynchronously, {\tt Lwt} uses a -system of jobs that can be executed in a different threads. A job is -composed of four functions: - - - -\begin{itemize} -\item A function to create the job, which creates a job structure info -and stores parameters in it. This function is executed in the -main thread. -\item A function which execute the job. This one may be executed asynchronously -in another thread. -\item A function which read the result of the job. This function is -executed in the main thread. -\item And finally a function that free resources allocated for the -job, which is also executed in the main thread. - -\end{itemize} - -We show as example the implementation of {\tt Lwt\_unix.mkdir}. On the C -side we have: - - - -\lstset{language=c}\begin{lstlisting}/* The job info structure */ -struct job_mkdir { - /* Informations required by lwt. - It must be the first field of the structure. */ - struct lwt_unix_job job; - - /* The name of the directory to create. */ - char *name; - - /* Permissions for the directory. */ - int perms; - - /* The result of the call to mkdir. */ - int result; - - /* The errno value after the call. */ - int error_code; -}; - -/* Convenient macro for retrieving a mkdir job info structure from an - ocaml custom value. */ -#define Job_mkdir_val(v) *(struct job_mkdir**)Data_custom_val(v) - -/* The function that effectively executes the job. */ -static void worker_mkdir(struct job_mkdir *job) -{ - /* Call mkdir and save its result. */ - job->result = mkdir(job->name, job->perms); - - /* Save the contents of [errno]. */ - job->error_code = errno; -} - -/* The stub that create the job. */ -CAMLprim value lwt_unix_mkdir_job(value val_name, value val_perms) -{ - struct job_mkdir *job = lwt_unix_new(struct job_mkdir); - - /* Sets the worker for this job. */ - job->job.worker = (lwt_unix_job_worker)worker_mkdir; - - /* Copy the name of the directory into the C memory. */ - job->name = lwt_unix_strdup(String_val(val_name)); - - /* Copy the perms parameter. */ - job->perms = Int_val(val_perms); - - /* Put the job into an ocaml custom value and returns it. */ - return lwt_unix_alloc_job(&(job->job)); -} - -/* The stub that read the result of the job. */ -CAMLprim value lwt_unix_mkdir_result(value val_job) -{ - struct job_mkdir *job = Job_mkdir_val(val_job); - - /* If mkdir failed, raise the unix error now. */ - if (job->result < 0) unix_error(job->error_code, "mkdir", Nothing); - - return Val_unit; -} - -/* The stub that free resources. */ -CAMLprim value lwt_unix_mkdir_free(value val_job) -{ - struct job_mkdir *job = Job_mkdir_val(val_job); - - /* Free the name of the directory. */ - free(job->name); - - /* Free resources allocated by lwt_unix for this job. */ - lwt_unix_free_job(&job->job); - - return Val_unit; -} -\end{lstlisting} -and on the ocaml side: - - - -\lstset{language=[Objective]Caml}\begin{lstlisting} -(* The stub for creating the job. *) -external mkdir_job : string -> int -> [ `unix_mkdir ] job = "lwt_unix_mkdir_job" - -(* The stub for reading the result of the job. *) -external mkdir_result : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_result" - -(* The stub reading the result of the job. *) -external mkdir_free : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_free" - -(* And finally the ocaml function. *) -let mkdir name perms = - Lwt_unix.execute_job (mkdir_job name perms) mkdir_result mkdir_free - -\end{lstlisting} \ No newline at end of file diff --git a/server/thirdparty/lwt-2.3.2/manual/manual.pdf b/server/thirdparty/lwt-2.3.2/manual/manual.pdf deleted file mode 100644 index 6aa1da8..0000000 Binary files a/server/thirdparty/lwt-2.3.2/manual/manual.pdf and /dev/null differ diff --git a/server/thirdparty/lwt-2.3.2/manual/manual.tex b/server/thirdparty/lwt-2.3.2/manual/manual.tex deleted file mode 100644 index bfe4576..0000000 --- a/server/thirdparty/lwt-2.3.2/manual/manual.tex +++ /dev/null @@ -1,52 +0,0 @@ -\documentclass{article} -\usepackage{fullpage} -\usepackage[utf8]{inputenc} -\usepackage{url} -\usepackage{hyperref} -\usepackage{listings} -\usepackage{xcolor} - -\hypersetup{% - a4paper=true, - pdfstartview=FitH, - colorlinks=false, - pdfborder=0 0 0, - pdftitle = {Lwt user manual}, - pdfauthor = {Jérémie Dimino}, - pdfkeywords = {OCaml, Lwt, Cooperative threads, Coroutines} -} - -\lstset{ - language=[Objective]Caml, - extendedchars, - showspaces=false, - showstringspaces=false, - showtabs=false, - basicstyle=\ttfamily, - frame=l, - framerule=1.5mm, - xleftmargin=6mm, - framesep=4mm, - rulecolor=\color{lightgray}, - emph={lwt,for\_lwt,try\_lwt,raise\_lwt}, - emphstyle=\color[rgb]{0.627451, 0.125490, 0.941176}, - moredelim=*[s][\itshape]{(*}{*)}, - moredelim=[is][\textcolor{darkgray}]{§}{§}, - escapechar=°, - keywordstyle=\color[rgb]{0.627451, 0.125490, 0.941176}, - stringstyle=\color[rgb]{0.545098, 0.278431, 0.364706}, - commentstyle=\color[rgb]{0.698039, 0.133333, 0.133333}, - numberstyle=\color[rgb]{0.372549, 0.619608, 0.627451} -} - -\title{Lwt user manual} -\author{Jérémie Dimino} - -\begin{document} - -\maketitle -\tableofcontents - -\include{manual-wiki} - -\end{document} diff --git a/server/thirdparty/lwt-2.3.2/manual/manual.wiki b/server/thirdparty/lwt-2.3.2/manual/manual.wiki deleted file mode 100644 index 818af70..0000000 --- a/server/thirdparty/lwt-2.3.2/manual/manual.wiki +++ /dev/null @@ -1,1028 +0,0 @@ -<>.>> - -== Introduction == - - When writing a program, a common developer's task is to handle IO - operations. Indeed most software interact with several different - resources, such as: - - * the kernel, by doing system calls - * the user, by reading the keyboard, the mouse, or any input device - * a graphical server, to build graphical user interface - * other computers, by using the network - * ... - - When this list contains only one item, it is pretty easy to - handle. However as this list grows it becomes harder and harder to - make everything works together. Several choices have been proposed - to solve this problem: - - * using a main loop, and integrate all components we are - interacting with into this main loop. - * using preemptive system threads - - Both solution have their advantages and their drawbacks. For the - first one, it may works, but it becomes very complicated to write - some piece of asynchronous sequential code. The typical example being with - graphical user interfaces freezing and not redrawing themselves - because they are waiting for some blocking part of the code to - complete. - - If you already wrote code using preemptive threads, you shall know - that doing it right with threads is a hard job. Moreover system - threads consume non negligible resources, and so you can only launch - a limited number of threads at the same time. Thus this is not a - real solution. - - {{{Lwt}}} offers a new alternative. It provides very light-weight - cooperative threads; ``launching'' a thread is a very quick - operation, it does not require a new stack, a new process, or - anything else. Moreover context switches are very fast. In fact, it - is so easy that we will launch a thread for every system call. And - composing cooperative threads will allow us to write highly - asynchronous programs. - - In a first part, we will explain the concepts of {{{Lwt}}}, then we will - describe the many sub-libraries of {{{Lwt}}}. - -== The Lwt core library == - - In this section we describe the basics of {{{Lwt}}}. It is advised to - start an ocaml toplevel and try the given code examples. To start, - launch {{{ocaml}}} in a terminal or in emacs with the tuareg - mode, and type: - -{{{ -# #use "topfind";; -# #require "lwt";; -}}} - - {{{Lwt}}} is also shipped with an improved toplevel, which supports line - edition and completion. If it has been correctly installed, you - should be able to start it with the following command: - -{{{ -$ lwt-toplevel -}}} - -=== Lwt concepts === - - Let's take a classical function of the {{{Pervasives}}} module: - -< char = ->> - - This function will wait for a character to come on the given input - channel, then return it. The problem with this function is that it is - blocking: while it is being executed, the whole program will be - blocked, and other events will not be handled until it returns. - - Now let's look at the lwt equivalent: - -< char Lwt.t = ->> - - As you can see, it does not returns a character but something of - type {{{char Lwt.t}}}. The type {{{'a Lwt.t}}} is the type - of threads returning a value of type {{{'a}}}. Actually the - {{{Lwt_io.read_char}}} will try to read a character from the - given input channel and //immediatly// returns a light-weight - thread. - - Now, let's see what we can do with a {{{Lwt}}} thread. The following - code create a pipe, and launch a thread reading on the input side: - -< -val oc : Lwt_io.output_channel = -# let t = Lwt_io.read_char ic;; -val t : char Lwt.t = ->> - - We can now look at the state of our newly created thread: - -<> - - A thread may be in one of the following states: - - * {{{Return x}}}, which means that the thread has terminated - successfully and returned the value {{{x}}} - * {{{Fail exn}}}, which means that the thread has terminated, - but instead of returning a value, it failed with the exception - {{{exn}}} - * {{{Sleep}}}, which means that the thread is currently - sleeping and have not yet returned a value or an exception - - The thread {{{t}}} is sleeping because there is currently nothing - to read on the pipe. Let's write something: - -< -# Lwt.state t;; -- : char Lwt.state = Return 'a' ->> - - So, after we write something, the reading thread has been wakeup and - has returned the value {{{'a'}}}. - -=== Primitives for thread creation === - - There are several primitives for creating {{{Lwt}}} threads. These - functions are located in the module {{{Lwt}}}. - - Here are the main primitives: - - * {{{Lwt.return : 'a -> 'a Lwt.t}}} - \\ - creates a thread which has already terminated and returned a value - * {{{Lwt.fail : exn -> 'a Lwt.t}}} - \\ - creates a thread which has already terminated and failed with an - exception - * {{{Lwt.wait : unit -> 'a Lwt.t * 'a Lwt.u}}} - \\ - creates a sleeping thread and returns this thread plus a wakener (of - type {{{'a Lwt.u}}}) which must be used to wakeup the sleeping - thread. - - To wake up a sleeping thread, you must use one of the following - functions: - - * {{{Lwt.wakeup : 'a Lwt.u -> 'a -> unit}}} - \\ - wakes up the thread with a value. - * {{{Lwt.wakeup_exn : 'a Lwt.u -> exn -> unit}}} - \\ - wakes up the thread with an exception. - - Note that this is an error to wakeup two times the same threads. {{{Lwt}}} - will raise {{{Invalid_argument}}} if you try to do so. - - With these informations, try to guess the result of each of the - following expression: - -<> - -==== Primitives for thread composition ==== - - The most important operation you need to know is {{{bind}}}: - -< ('a -> 'b Lwt.t) -> 'b Lwt.t ->> - - {{{bind t f}}} creates a thread which waits for {{{t}}} to - terminates, then pass the result to {{{f}}}. If {{{t}}} is a - sleeping thread, then {{{bind t f}}} will be a sleeping thread too, - until {{{t}}} terminates. If {{{t}}} fails, then the resulting - thread will fail with the same exception. For example, consider the - following expression: - -< Lwt_io.printlf "You typed %S" str) ->> - - This code will first wait for the user to enter a line of text, then - print a message on the standard output. - - Similarly to {{{bind}}}, there is a function to handle the case - when {{{t}}} fails: - -< 'a Lwt.t) -> (exn -> 'a Lwt.t) -> 'a Lwt.t ->> - - {{{catch f g}}} will call {{{f ()}}}, then waits for its - termination, and if it fails with an exception {{{exn}}}, calls - {{{g exn}}} to handle it. Note that both exceptions raised with - {{{Pervasives.raise}}} and {{{Lwt.fail}}} are caught by - {{{catch}}}. - -==== Cancelable threads ==== - - In some case, we may want to cancel a thread. For example, because it - has not terminated after a timeout. This can be done with cancelable - threads. To create a cancelable thread, you must use the - {{{Lwt.task}}} function: - -< 'a Lwt.t * 'a Lwt.u ->> - - It has the same semantic as {{{Lwt.wait}}} except that the - sleeping thread can be canceled with {{{Lwt.cancel}}}: - -< unit ->> - - The thread will then fails with the exception - {{{Lwt.Canceled}}}. To execute a function when the thread is - canceled, you must use {{{Lwt.on_cancel}}}: - -< (unit -> unit) -> unit ->> - - Note that it is also possible to cancel a thread which has not been - created with {{{Lwt.task}}}. In this case, the deepest cancelable - thread connected with the given thread will be cancelled. - - For example, consider the following code: - -< -val wakener : '_a Lwt.u = -# let t = bind waiter (fun x -> return (x + 1));; -val t : int Lwt.t = ->> - - Here, cancelling {{{t}}} will in fact cancel {{{waiter}}}. - {{{t}}} will then fails with the exception {{{Lwt.Canceled}}}: - -<> - - By the way, it is possible to prevent a thread from being canceled - by using the function {{{Lwt.protected}}}: - -< 'a Lwt.t ->> - - Canceling {{{(proctected t)}}} will have no effect on {{{t}}}. - -==== Primitives for multi-thread composition ==== - - We now show how to compose several threads at the same time. The - main functions for this are in the {{{Lwt}}} module: {{{join}}}, - {{{choose}}} and {{{pick}}}. - - The first one, {{{join}}} takes a list of threads and wait for all - of them to terminate: - -< unit Lwt.t ->> - - Moreover, if at least one thread fails, {{{join l}}} will fails with - the same exception as the first to fail, after all threads threads terminated. - - On the contrary {{{choose}}} waits for at least one thread to - terminate, then returns the same value or exception: - -< 'a Lwt.t ->> - - For example: - -< -val wakener1 : '_a Lwt.u = -# let waiter2, wakener2 = Lwt.wait ();; -val waiter2 : '_a Lwt.t = -val wakener : '_a Lwt.u = -# let t = Lwt.choose [waiter1; waiter2];; -val t : '_a Lwt.t = -# Lwt.state t;; -- : '_a Lwt.state = Sleep -# Lwt.wakeup wakener2 42;; -- : unit = () -# Lwt.state t;; -- : int Lwt.state = Return 42 ->> - - Thel last one, {{{pick}}}, is the same as {{{join}}} except that it cancels - all other threads when one terminates. - -==== Threads local storage ==== - - Lwt can stores variables with different values on different - threads. This is called threads local storage. For example, this can - be used to store contexts or thread identifiers. The contents of a - variable can be read with: - -< 'a option ->> - - which takes a key to identify the variable we want to read and - returns either {{{None}}} if the variable is not set, or - {{{Some x}}} if it is. The value returned is the value of the - variable in the current thread. - - New keys can be created with: - -< 'a Lwt.key ->> - - To set a variable, you must use: - -< 'a option -> (unit -> 'b) -> 'b ->> - - {{{with_value key value f}}} will executes {{{f}}} with - the binding {{{key -> value}}}. The old value associated to - {{{key}}} is restored after {{{f}}} terminates. - - For example, you can use local storage to store thread identifiers - and use them in logs: - -< id - | None -> "main" - in - Lwt_io.printlf "%s: %s" thread_id msg - -lwt () = - Lwt.join [ - Lwt.with_value id_key (Some "thread 1") (fun () -> log "foo"); - Lwt.with_value id_key (Some "thread 2") (fun () -> log "bar"); - ] ->> - -==== Rules ==== - - {{{Lwt}}} will always try to execute the more it can before yielding and - switching to another cooperative thread. In order to make it works well, - you must follow the following rules: - - * do not write function that may takes time to complete without - using {{{Lwt}}}, - * do not do IOs that may block, otherwise the whole program will - hang. You must instead use asynchronous IOs operations. - -=== The syntax extension === - - {{{Lwt}}} offers a syntax extension which increases code readability and - makes coding using {{{Lwt}}} easier. To use it add the ``lwt.syntax'' package when - compiling: - -<> - - Or in the toplevel (after loading topfind): - -<> - - The following construction are added to the language: - - * {{{lwt}}} //pattern,,1,,// {{{=}}} //expr,,1,,// [ {{{and}}} - //pattern,,2,,// {{{=}}} //expr,,2,,// ... ] {{{in}}} //expr// - \\ - which is a parallel let-binding construction. For example in the - following code: - -<> - - the thread {{{f ()}}} and {{{g ()}}} are launched in parallel - and their result are then bound to {{{x}}} and {{{y}}} in the - expression //expr//. - - Of course you can also launch the two threads sequentially by - writing your code like that: - -<> - - * {{{try_lwt}}} //expr// [ {{{with}}} //pattern,,1,,// - {{{->}}} //expr,,1,,// ... ] [ {{{finally}}} //expr'// ] - \\ - which is the equivalent of the standard {{{try-with}}} - construction but for {{{Lwt}}}. Both exception raised by - {{{Pervasives.raise}}} and {{{Lwt.fail}}} are caught."; - - * {{{for_lwt}}} //ident// {{{=}}} //expr,,init,,// ( {{{to}}} {{{|}}} - {{{downto}}} ) //expr,,final,,// {{{do}}} //expr// - {{{done}}} - \\ - which is the equivalent of the standard {{{for}}} construction - but for {{{Lwt}}}. - - * {{{raise_lwt}}} //exn// - \\ - which is the same as {{{Lwt.fail}}} //exn// but with backtrace support. - -==== Correspondence table ==== - - You can keep in mind the following table to write code using lwt: - - |= without {{{Lwt}}} |= with {{{Lwt}}} | - | | | - | {{{let}}} //pattern,,1,,// {{{=}}} //expr,,1,,// | {{{lwt}}} //pattern,,1,,// {{{=}}} //expr,,1,,// | - | {{{and}}} //pattern,,2,,// {{{=}}} //expr,,2,,// | {{{and}}} //pattern,,2,,// {{{=}}} //expr,,2,,// | - | ... | ... | - | {{{and}}} //pattern,,n,,// {{{=}}} //expr,,n,,// {{{in}}} | {{{and}}} //pattern,,n,,// {{{=}}} //expr,,n,,// {{{in}}} | - | //expr// | //expr// | - | | | - | {{{try}}} | {{{try_lwt}}} | - | // expr// | // expr// | - | {{{with}}} | {{{with}}} | - | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | - | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | - | // // ... | // // ... | - | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | - | | | - | {{{for}}} //ident// {{{=}}} //expr,,init,,// {{{to}}} //expr,,final,,// {{{do}}} | {{{for_lwt}}} //ident// {{{=}}} //expr,,init,,// {{{to}}} //expr,,final,,// {{{do}}} | - | // expr// | // expr// | - | {{{done}}} | {{{done}}} | - | | | - | {{{raise}}} //exn// | {{{raise_lwt}}} //exn// | - | | | - | {{{assert}}} //expr// | {{{assert_lwt}}} //expr// | - | | | - | {{{match}}} //expr// {{{with}}} | {{{match_lwt}}} //expr// {{{with}}} | - | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | - | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | - | // // ... | // // ... | - | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | - | | | - | {{{while}}} //expr// {{{do}}} | {{{while_lwt}}} //expr// {{{do}}} | - | // expr// | // expr// | - | {{{done}}} | {{{done}}} | - -=== Backtrace support === - - When using {{{Lwt}}}, exceptions are not recorded by the ocaml runtime, and so you can not - get backtraces. However it is possible to get them when using the syntax extension. All you - have to do is to pass the {{{-lwt-debug}}} switch to {{{camlp4}}}: - -{{{ -$ ocamlfind ocamlc -syntax camlp4o -package lwt.syntax \ - -ppopt -lwt-debug -linkpkg -o foo foo.ml -}}} - -=== Other modules of the core library === - - The core library contains several modules that depend only on - {{{Lwt}}}. The following naming convention is used in {{{Lwt}}}: when a - function takes as argument a function returning a thread that is going - to be executed sequentially, it is suffixed with ``{{{_s}}}''. And - when it is going to be executed in parallel, it is suffixed with - ``{{{_p}}}''. For example, in the {{{Lwt_list}}} module we have: - -< 'b Lwt.t) -> 'a list -> 'b list Lwt.t -val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t ->> - -==== Mutexes ==== - - {{{Lwt_mutex}}} provides mutexes for {{{Lwt}}}. Its use is almost the - same as the {{{Mutex}}} module of the thread library shipped with - OCaml. In general, programs using {{{Lwt}}} do not need a lot of - mutexes. They are only usefull for serialising operations. - -==== Lists ==== - - The {{{Lwt_list}}} module defines iteration and scanning functions - over lists, similar to the ones of the {{{List}}} module, but using - functions that return a thread. For example: - -< unit Lwt.t) -> 'a list -> unit Lwt.t -val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t ->> - - In {{{iter_s f l}}}, {{{iter_s}}} will call f on each elements - of {{{l}}}, waiting for completion between each elements. On the - contrary, in {{{iter_p f l}}}, {{{iter_p}}} will call f on all - elements of {{{l}}}, then wait for all the threads to terminate. - -==== Data streams ==== - - {{{Lwt}}} streams are used in a lot of places in {{{Lwt}}} and its sub - libraries. They offer a high-level interface to manipulate data flows. - - A stream is an object which returns elements sequentially and - lazily. Lazily means that the source of the stream is guessed for new - elements only when needed. This module contains a lot of stream - transformation, iteration, and scanning functions. - - The common way of creating a stream is by using - {{{Lwt_stream.from}}} or by using {{{Lwt_stream.create}}}: - -< 'a option Lwt.t) -> 'a Lwt_stream.t -val create : unit -> 'a Lwt_stream.t * ('a option -> unit) ->> - - As for streams of the standard library, {{{from}}} takes as - argument a function which is used to create new elements. - - {{{create}}} returns a function used to push new elements - into the stream and the stream which will receive them. - - For example: - -< -val push : '_a option -> unit = -# push (Some 1);; -- : unit = () -# push (Some 2);; -- : unit = () -# push (Some 3);; -- : unit = () -# Lwt.state (Lwt_stream.next stream);; -- : int Lwt.state = Return 1 -# Lwt.state (Lwt_stream.next stream);; -- : int Lwt.state = Return 2 -# Lwt.state (Lwt_stream.next stream);; -- : int Lwt.state = Return 3 -# Lwt.state (Lwt_stream.next stream);; -- : int Lwt.state = Sleep ->> - - Note that streams are consumable. Once you take an element from a - stream, it is removed from it. So, if you want to iterates two times - over a stream, you may consider ``clonning'' it, with - {{{Lwt_stream.clone}}}. Cloned stream will returns the same - elements in the same order. Consuming one will not consume the other. - For example: - -< -# let s' = Lwt_stream.clone s;; -val s' : int Lwt_stream.t = -# Lwt.state (Lwt_stream.next s);; -- : int Lwt.state = Return 1 -# Lwt.state (Lwt_stream.next s);; -- : int Lwt.state = Return 2 -# Lwt.state (Lwt_stream.next s');; -- : int Lwt.state = Return 1 -# Lwt.state (Lwt_stream.next s');; -- : int Lwt.state = Return 2 ->> - -==== Mailbox variables ==== - - The {{{Lwt_mvar}}} module provides mailbox variables. A mailbox - variable, also called a ``mvar'', is a cell which may contains 0 or 1 - element. If it contains no elements, we say that the mvar is empty, - if it contains one, we say that it is full. Adding an element to a - full mvar will block until one is taken. Taking an element from an - empty mvar will block until one is added. - - Mailbox variables are commonly used to pass messages between threads. - - Note that a mailbox variable can be seen as a pushable stream with a - limited memory. - -== Running a Lwt program == - - Threads you create with {{{Lwt}}} always have the type - {{{Lwt.t}}}. If you want to write a program and run it this is not - enough. Indeed you don't know when a {{{Lwt}}} thread is terminated. - - For example if your program is just: - -<> - - you have no guarantee that the thread writing {{{"Hello, world!"}}} - on the terminal will be terminated when the program exit. In order - to wait for a thread to terminate, you have to call the function - {{{Lwt_main.run}}}: - -< 'a ->> - - This functions wait for the given thread to terminate and returns - its result. In fact it does more than that; it also run the - scheduler which is responsible for making thread to progress when - events are received from the outside world. - - So basically, when you write a {{{Lwt}}} program you must call at - the toplevel the function {{{Lwt_main.run}}}. For instance: - -<> - - Note that you must call {{{Lwt_main.run}}} only once at a time. It - cannot be used anywhere to get the result of a thread. It must only - be used in the entry point of your program. - -== The {{{lwt.unix}}} library == - - The package {{{lwt.unix}}} contains all {{{unix}}} dependant - modules of {{{Lwt}}}. Among all its features, it implements cooperative - versions of functions of the standard library and the unix library. - -=== Unix primitives === - - The {{{Lwt_unix}}} provides cooperative system calls. For example, - the {{{Lwt}}} counterpart of {{{Unix.read}}} is: - -< string -> int -> int -> int Lwt.t ->> - - {{{Lwt_io}}} provides features similar to buffered channels of - the standard library (of type {{{in_channel}}} or - {{{out_channel}}}) but cooperatively. - - {{{Lwt_gc}}} allow you to register finaliser that return a - thread. At the end of the program, {{{Lwt}}} will wait for all the - finaliser to terminates. - -=== The Lwt scheduler === - - Threads doing IO may be put asleep until some events are received by - the process. For example when you read from a file descriptor, you - may have to wait for the file descriptor to become readable if no - data are immediatly available on it. - - {{{Lwt}}} contains a shceduler which is responsible for managing - multiple threads waiting for events, and restart them when needed. - This scheduler is implemented by the two modules {{{Lwt_engine}}} - and {{{Lwt_main}}}. {{{Lwt_engine}}} is a low-level module, it - provides signatures for IO multiplexers as well as several builtin - implementation. {{{Lwt}}} support by default multiplexing IO with - {{{libev}}} or {{{Unix.select}}}. The signature is given by the - class {{{Lwt_engine.t}}}. - - {{{libev}}} is used by default on Unix, because it supports any - number of file descriptors while Unix.select supports only 1024 at - most, and is also much more efficient. On Windows {{{Unix.select}}} - is used because {{{libev}}} does not works properly. The user may - change at any time the backend in use. - - The engine can also be used directly in order to integrate other - libraries with {{{Lwt}}}. For example {{{GTK}}} need to be notified - when some events are received. If you use {{{Lwt}}} with {{{GTK}}} - you need to use the {{{Lwt}}} scheduler to monitor {{{GTK}}} - sources. This is what is done by the {{{lwt.glib}}} package. - - The {{{Lwt_main}}} module contains the //main loop// of - {{{Lwt}}}. It is run by calling the function {{{Lwt_main.run}}}: - -< 'a ->> - - This function continously run the scheduler until the thread passed - as argument terminates. - -=== The logging facility === - - The package {{{lwt.unix}}} contains a module {{{Lwt_log}}} - providing loggers. It support logging to a file, a channel, or to the - syslog daemon. You can also defines your own logger by providing the - appropriate functions (function {{{Lwt_log.make}}}). - - Several loggers can be merged into one. Sending logs on the merged - logger will send these logs to all its components. - - For example to redirect all logs to {{{stderr}}} and to the syslog - daemon: - -<> - - {{{Lwt}}} also provides a syntax extension, in the package - {{{lwt.syntax.log}}}. It does not modify the language but - it replaces log statement of the form: - -<> - - by: - -<> - - The advantages of using the syntax extension are the following: - - * it check the log level before calling the logging function, so - arguments are not computed if not needed - * debugging logs can be removed at parsing time - - By default, the syntax extension remove all logs with the level - {{{debug}}}. To keep them pass the command line option - {{{-lwt-debug}}} to camlp4. - -== The Lwt.react library == - - The {{{Lwt_react}}} module provide helpers for using the {{{react}}} - library with {{{Lwt}}}. It extends the {{{React}}} module by adding - {{{Lwt}}} specific functions. It can be used as a replacement of - {{{React}}}. For example you can add at the beginning of you - program: - -<> - - instead of: - -<> - - or: - -<> - - Among the added functionnality we have {{{Lwt_react.E.next}}}, which - takes an event and returns a thread which will wait until the next - occurence of this event. For example: - -< -val push : '_a -> unit = -# let t = E.next event;; -val t : '_a Lwt.t = -# Lwt.state t;; -- : '_a Lwt.state = Sleep -# push 42;; -- : unit = () -# Lwt.state t;; -- : int Lwt.state = Return 42 ->> - - Another interesting feature is the ability to limit events - (resp. signals) to occurs (resp. to changes) too often. For example, - suppose you are doing a program which displays something on the screeen - each time a signal changes. If at some point the signal changes 1000 - times per second, you probably want not to render it 1000 times per - second. For that you use {{{Lwt_react.S.limit}}}: - -< unit Lwt.t) -> 'a React.signal -> 'a React.signal ->> - - {{{Lwt_react.S.limit f signal}}} returns a signal which varies as - {{{signal}}} except that two consecutive updates are separeted by a - call to {{{f}}}. For example if {{{f}}} returns a thread which sleep - for 0.1 seconds, then there will be no more than 10 changes per - second. For example: - -< Lwt_unix.sleep 0.1) signal in - - (* Redraw the screen each time the limited signal change: *) - S.notify_p draw signal' ->> - -== The lwt.text library == - - The {{{lwt.text}}} library provides functions to deal with text - mode (in a terminal). It is composed of the three following modules: - - * {{{Lwt_text}}}, which is the equivalent of {{{Lwt_io}}} - but for unicode text channels - * {{{Lwt_term}}}, providing various terminal utilities, such as - reading a key from the terminal - * {{{Lwt_read_line}}}, which provides functions to input text - from the user with line editing support - -=== Text channels === - - A text channel is basically a byte channel plus an encoding. Input - (resp. output) text channels decode (resp. encode) unicode characters - on the fly. By default, output text channels use transliteration, so - they will not fails because text you want to print cannot be encoded - in the system encoding. - - For example, with you locale sets to ``C'', and the variable - {{{name}}} set to ``Jérémie'', you got: - -<> - -=== Terminal utilities === - - The {{{Lwt_term}}} allow you to put the terminal in //raw mode//, - meanings that input is not buffered and character are - returned as the user type them. For example, you can read a key with: - -<> - - The second main feature of {{{Lwt_term}}} is the ability to prints - text with styles. For example, to print text in bold and blue: - -<> - - If the output is not a terminal, then {{{printlc}}} will drop - styles, and act as {{{Lwt_text.printl}}}. - -=== Read-line === - - {{{Lwt_read_line}}} provides a full featured and fully - customisable read-line implementation. You can either use the - high-level and easy to use {{{read_*}}} functions, or use the - advanced {{{Lwt_read_line.Control.read_*}}} functions. - - For example: - -< "] ();; -foo> Hello, world! -val l : Text.t = "Hello, world!" ->> - - The second class of functions is a bit more complicated to use, but - allow to control a running read-line instances. For example you can - temporary hide it to draw something, you can send it commands, fake - input, and the prompt is a signal so it can change dynamically. - -== Other libraries == - -=== Detaching computation to preemptive threads === - - It may happen that you want to run a function which will take time to - compute or that you want to use a blocking function that cannot be - used in a non-blocking way. For these situations, {{{Lwt}}} allow you to - //detach// the computation to a preemptive thread. - - This is done by the module {{{Lwt_preemptive}}} of the - {{{lwt.preemptive}}} package which maintains a spool of system - threads. The main function is: - -< 'b) -> 'a -> 'b Lwt.t ->> - - {{{detach f x}}} will execute {{{f x}}} in another thread and - asynchronously wait for the result. - - The {{{lwt.extra}}} package provides wrappers for a few blocking - functions of the standard C library like {{{gethostbyname}}} (in - the module {{{Lwt_lib}}}). - -=== SSL support === - - The package {{{lwt.ssl}}} provides the module {{{Lwt_ssl}}} - which allow to use SSL asynchronously - -=== Glib integration === - - The {{{lwt.glib}}} embed the {{{glib}}} main loop into the - {{{Lwt}}} one. This allow you to write GTK application using {{{Lwt}}}. The - one thing you have to do is to call {{{Lwt_glib.install}}} at - the beginning of you program. - -== Writing stubs using {{{Lwt}}} == - -=== Thread-safe notifications === - - If you want to notify the main thread from another thread, you can use the {{{Lwt}}} - thread safe notification system. First you need to create a notification identifier - (which is just an integer) from the OCaml side using the - {{{Lwt_unix.make_notification}}} function, then you can send it from either the - OCaml code with {{{Lwt_unix.send_notification}}} function, or from the C code using - the function {{{lwt_unix_send_notification}}} (defined in {{{lwt_unix_.h}}}). - - Notification are received and processed asynchronously by the main thread. - -=== Jobs === - - For operations that can not be executed asynchronously, {{{Lwt}}} uses a - system of jobs that can be executed in a different threads. A job is - composed of four functions: - - * A function to create the job, which creates a job structure info - and stores parameters in it. This function is executed in the - main thread. - * A function which execute the job. This one may be executed asynchronously - in another thread. - * A function which read the result of the job. This function is - executed in the main thread. - * And finally a function that free resources allocated for the - job, which is also executed in the main thread. - - We show as example the implementation of {{{Lwt_unix.mkdir}}}. On the C - side we have: - -<result = mkdir(job->name, job->perms); - - /* Save the contents of [errno]. */ - job->error_code = errno; -} - -/* The stub that create the job. */ -CAMLprim value lwt_unix_mkdir_job(value val_name, value val_perms) -{ - struct job_mkdir *job = lwt_unix_new(struct job_mkdir); - - /* Sets the worker for this job. */ - job->job.worker = (lwt_unix_job_worker)worker_mkdir; - - /* Copy the name of the directory into the C memory. */ - job->name = lwt_unix_strdup(String_val(val_name)); - - /* Copy the perms parameter. */ - job->perms = Int_val(val_perms); - - /* Put the job into an ocaml custom value and returns it. */ - return lwt_unix_alloc_job(&(job->job)); -} - -/* The stub that read the result of the job. */ -CAMLprim value lwt_unix_mkdir_result(value val_job) -{ - struct job_mkdir *job = Job_mkdir_val(val_job); - - /* If mkdir failed, raise the unix error now. */ - if (job->result < 0) unix_error(job->error_code, "mkdir", Nothing); - - return Val_unit; -} - -/* The stub that free resources. */ -CAMLprim value lwt_unix_mkdir_free(value val_job) -{ - struct job_mkdir *job = Job_mkdir_val(val_job); - - /* Free the name of the directory. */ - free(job->name); - - /* Free resources allocated by lwt_unix for this job. */ - lwt_unix_free_job(&job->job); - - return Val_unit; -} ->> - - and on the ocaml side: - -< int -> [ `unix_mkdir ] job = "lwt_unix_mkdir_job" - -(* The stub for reading the result of the job. *) -external mkdir_result : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_result" - -(* The stub reading the result of the job. *) -external mkdir_free : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_free" - -(* And finally the ocaml function. *) -let mkdir name perms = - Lwt_unix.execute_job (mkdir_job name perms) mkdir_result mkdir_free ->> diff --git a/server/thirdparty/lwt-2.3.2/manual/menu.wiki b/server/thirdparty/lwt-2.3.2/manual/menu.wiki deleted file mode 100644 index 37caab6..0000000 --- a/server/thirdparty/lwt-2.3.2/manual/menu.wiki +++ /dev/null @@ -1,2 +0,0 @@ -= Lwt -==[[manual|Overview]] \ No newline at end of file diff --git a/server/thirdparty/lwt-2.3.2/myocamlbuild.ml b/server/thirdparty/lwt-2.3.2/myocamlbuild.ml deleted file mode 100644 index 73d08b1..0000000 --- a/server/thirdparty/lwt-2.3.2/myocamlbuild.ml +++ /dev/null @@ -1,771 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Myocamlbuild - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(* Keep that in sync with the list in discover.ml *) -let search_paths = [ - "/usr"; - "/usr/local"; - "/opt"; - "/opt/local"; - "/sw"; - "/mingw"; -] - -(* OASIS_START *) -(* DO NOT EDIT (digest: 4c177063a31680580ca13639e7a11972) *) -module OASISGettext = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISGettext.ml" - - let ns_ str = - str - - let s_ str = - str - - let f_ (str : ('a, 'b, 'c, 'd) format4) = - str - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - let init = - [] - -end - -module OASISExpr = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISExpr.ml" - - - - open OASISGettext - - type test = string - - type flag = string - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - type 'a choices = (t * 'a) list - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - -end - - -module BaseEnvLight = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseEnvLight.ml" - - module MapString = Map.Make(String) - - type t = string MapString.t - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - let var_get name env = - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - in - var_expand (MapString.find name env) - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -module MyOCamlbuildFindlib = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" - - (** OCamlbuild extension, copied from - * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild - * by N. Pouillard and others - * - * Updated on 2009/02/28 - * - * Modified by Sylvain Le Gall - *) - open Ocamlbuild_plugin - - (* these functions are not really officially exported *) - let run_and_read = - Ocamlbuild_pack.My_unix.run_and_read - - let blank_sep_strings = - Ocamlbuild_pack.Lexers.blank_sep_strings - - let split s ch = - let x = - ref [] - in - let rec go s = - let pos = - String.index s ch - in - x := (String.before s pos)::!x; - go (String.after s (pos + 1)) - in - try - go s - with Not_found -> !x - - let split_nl s = split s '\n' - - let before_space s = - try - String.before s (String.index s ' ') - with Not_found -> s - - (* this lists all supported packages *) - let find_packages () = - List.map before_space (split_nl & run_and_read "ocamlfind list") - - (* this is supposed to list available syntaxes, but I don't know how to do it. *) - let find_syntaxes () = ["camlp4o"; "camlp4r"] - - (* ocamlfind command *) - let ocamlfind x = S[A"ocamlfind"; x] - - let dispatch = - function - | Before_options -> - (* by using Before_options one let command line options have an higher priority *) - (* on the contrary using After_options will guarantee to have the higher priority *) - (* override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop" - - | After_rules -> - - (* When one link an OCaml library/binary/package, one should use -linkpkg *) - flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; - end - (find_packages ()); - - (* Like -package but for extensions syntax. Morover -syntax is useless - * when linking. *) - List.iter begin fun syntax -> - flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - end (find_syntaxes ()); - - (* The default "thread" tag is not compatible with ocamlfind. - * Indeed, the default rules add the "threads.cma" or "threads.cmxa" - * options when using this tag. When using the "-linkpkg" option with - * ocamlfind, this module will then be added twice on the command line. - * - * To solve this, one approach is to add the "-thread" option when using - * the "threads" package using the previous plugin. - *) - flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) - - | _ -> - () - -end - -module MyOCamlbuildBase = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" - - (** Base functions for writing myocamlbuild.ml - @author Sylvain Le Gall - *) - - - - open Ocamlbuild_plugin - - type dir = string - type file = string - type name = string - type tag = string - -# 55 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" - - type t = - { - lib_ocaml: (name * dir list) list; - lib_c: (name * dir * file list) list; - flags: (tag list * (spec OASISExpr.choices)) list; - } - - let env_filename = - Pathname.basename - BaseEnvLight.default_filename - - let dispatch_combine lst = - fun e -> - List.iter - (fun dispatch -> dispatch e) - lst - - let dispatch t e = - let env = - BaseEnvLight.load - ~filename:env_filename - ~allow_empty:true - () - in - match e with - | Before_options -> - let no_trailing_dot s = - if String.length s >= 1 && s.[0] = '.' then - String.sub s 1 ((String.length s) - 1) - else - s - in - List.iter - (fun (opt, var) -> - try - opt := no_trailing_dot (BaseEnvLight.var_get var env) - with Not_found -> - Printf.eprintf "W: Cannot get variable %s" var) - [ - Options.ext_obj, "ext_obj"; - Options.ext_lib, "ext_lib"; - Options.ext_dll, "ext_dll"; - ] - - | After_rules -> - (* Declare OCaml libraries *) - List.iter - (function - | lib, [] -> - ocaml_lib lib; - | lib, dir :: tl -> - ocaml_lib ~dir:dir lib; - List.iter - (fun dir -> - flag - ["ocaml"; "use_"^lib; "compile"] - (S[A"-I"; P dir])) - tl) - t.lib_ocaml; - - (* Declare C libraries *) - List.iter - (fun (lib, dir, headers) -> - (* Handle C part of library *) - flag ["link"; "library"; "ocaml"; "byte"; "use_lib"^lib] - (S[A"-dllib"; A("-l"^lib); A"-cclib"; A("-l"^lib)]); - - flag ["link"; "library"; "ocaml"; "native"; "use_lib"^lib] - (S[A"-cclib"; A("-l"^lib)]); - - flag ["link"; "program"; "ocaml"; "byte"; "use_lib"^lib] - (S[A"-dllib"; A("dll"^lib)]); - - (* When ocaml link something that use the C library, then one - need that file to be up to date. - *) - dep ["link"; "ocaml"; "use_lib"^lib] - [dir/"lib"^lib^"."^(!Options.ext_lib)]; - - (* TODO: be more specific about what depends on headers *) - (* Depends on .h files *) - dep ["compile"; "c"] - headers; - - (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] - (S[A"-I"; P(dir)]); - ) - t.lib_c; - - (* Add flags *) - List.iter - (fun (tags, cond_specs) -> - let spec = - BaseEnvLight.var_choose cond_specs env - in - flag tags & spec) - t.flags - | _ -> - () - - let dispatch_default t = - dispatch_combine - [ - dispatch t; - MyOCamlbuildFindlib.dispatch; - ] - -end - - -open Ocamlbuild_plugin;; -let package_default = - { - MyOCamlbuildBase.lib_ocaml = - [ - ("src/core/lwt", ["src/core"]); - ("src/unix/lwt-unix", ["src/unix"]); - ("src/react/lwt-react", ["src/react"]); - ("tests/test", ["tests"]); - ("src/text/lwt-text", ["src/text"]); - ("syntax/lwt-syntax", ["syntax"]); - ("src/top/lwt-top", ["src/top"]); - ("src/preemptive/lwt-preemptive", ["src/preemptive"]); - ("src/simple_top/lwt-simple-top", ["src/simple_top"]); - ("src/glib/lwt-glib", ["src/glib"]); - ("syntax/lwt-syntax-log", ["syntax"]); - ("src/extra/lwt-extra", ["src/extra"]); - ("syntax/optcomp", ["syntax"]); - ("syntax/lwt-syntax-options", ["syntax"]); - ("src/ssl/lwt-ssl", ["src/ssl"]) - ]; - lib_c = - [ - ("lwt-unix", - "src/unix", - ["src/unix/lwt_config.h"; "src/unix/lwt_unix.h"]); - ("lwt-text", "src/text", []); - ("lwt-glib", "src/glib", []) - ]; - flags = - [ - (["oasis_library_lwt_unix_cclib"; "link"], - [ - (OASISExpr.EBool true, S []); - (OASISExpr.EFlag "libev", S [A "-cclib"; A "-lev"]); - (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), - S [A "-cclib"; A "-lpthread"]); - (OASISExpr.EAnd - (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), - OASISExpr.EFlag "libev"), - S [A "-cclib"; A "-lpthread"; A "-cclib"; A "-lev"]); - (OASISExpr.ETest ("os_type", "Win32"), - S [A "-cclib"; A "ws2_32.lib"]); - (OASISExpr.EAnd - (OASISExpr.ETest ("os_type", "Win32"), - OASISExpr.EFlag "libev"), - S [A "-cclib"; A "ws2_32.lib"; A "-cclib"; A "-lev"]); - (OASISExpr.EAnd - (OASISExpr.ETest ("os_type", "Win32"), - OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))), - S [A "-cclib"; A "ws2_32.lib"; A "-cclib"; A "-lpthread"]); - (OASISExpr.EAnd - (OASISExpr.EAnd - (OASISExpr.ETest ("os_type", "Win32"), - OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))), - OASISExpr.EFlag "libev"), - S - [ - A "-cclib"; - A "ws2_32.lib"; - A "-cclib"; - A "-lpthread"; - A "-cclib"; - A "-lev" - ]) - ]); - (["oasis_library_lwt_unix_cclib"; "ocamlmklib"; "c"], - [ - (OASISExpr.EBool true, S []); - (OASISExpr.EFlag "libev", S [A "-lev"]); - (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), - S [A "-lpthread"]); - (OASISExpr.EAnd - (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), - OASISExpr.EFlag "libev"), - S [A "-lpthread"; A "-lev"]); - (OASISExpr.ETest ("os_type", "Win32"), S [A "ws2_32.lib"]); - (OASISExpr.EAnd - (OASISExpr.ETest ("os_type", "Win32"), - OASISExpr.EFlag "libev"), - S [A "ws2_32.lib"; A "-lev"]); - (OASISExpr.EAnd - (OASISExpr.ETest ("os_type", "Win32"), - OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))), - S [A "ws2_32.lib"; A "-lpthread"]); - (OASISExpr.EAnd - (OASISExpr.EAnd - (OASISExpr.ETest ("os_type", "Win32"), - OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))), - OASISExpr.EFlag "libev"), - S [A "ws2_32.lib"; A "-lpthread"; A "-lev"]) - ]) - ]; - } - ;; - -let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; - -(* OASIS_STOP *) - -open Ocamlbuild_plugin - -let pkg_config flags = - with_temp_file "lwt" "pkg-config" - (fun tmp -> - Command.execute ~quiet:true & Cmd(S[A "pkg-config"; S flags; Sh ">"; A tmp]); - List.map (fun arg -> A arg) (string_list_of_file tmp)) - -let define_c_library ?(msvc = false) ~name ~c_name () = - let tag = Printf.sprintf "use_C_%s" name in - - (* Get compile flags. *) - let opt = pkg_config [A "--cflags"; A c_name] in - - (* Get linking flags. *) - let lib = - if msvc then - (* With msvc we need to pass "glib-2.0.lib" instead of - "-lglib-2.0" otherwise executables will fail. *) - pkg_config [A "--libs-only-L"; A c_name] @ pkg_config [A "--libs-only-l"; A "--msvc-syntax"; A c_name] - else - pkg_config [A "--libs"; A c_name] - in - - (* Add flags for linking with the C library: *) - flag ["ocamlmklib"; "c"; tag] & S lib; - - (* C stubs using the C library must be compiled with the library - specifics flags: *) - flag ["c"; "compile"; tag] & S (List.map (fun arg -> S[A"-ccopt"; arg]) opt); - - (* OCaml libraries must depends on the C library: *) - flag ["link"; "ocaml"; tag] & S (List.map (fun arg -> S[A"-cclib"; arg]) lib) - -let () = - dispatch - (fun hook -> - dispatch_default hook; - match hook with - | Before_options -> - Options.make_links := false - - | After_rules -> - dep ["file:src/unix/lwt_unix_stubs.c"] ["src/unix/lwt_unix_unix.c"; "src/unix/lwt_unix_windows.c"]; - dep ["pa_optcomp"] ["src/unix/lwt_config.ml"]; - - (* Internal syntax extension *) - List.iter - (fun base -> - let tag = "pa_" ^ base and file = "syntax/pa_" ^ base ^ ".cmo" in - flag ["ocaml"; "compile"; tag] & S[A"-ppopt"; A file]; - flag ["ocaml"; "ocamldep"; tag] & S[A"-ppopt"; A file]; - flag ["ocaml"; "doc"; tag] & S[A"-ppopt"; A file]; - dep ["ocaml"; "ocamldep"; tag] [file]) - ["lwt_options"; "lwt"; "lwt_log"; "optcomp"]; - - (* Optcomp for .mli *) - flag ["ocaml"; "compile"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"]; - flag ["ocaml"; "ocamldep"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"]; - flag ["ocaml"; "doc"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"]; - dep ["ocaml"; "ocamldep"; "pa_optcomp_standalone"] ["syntax/optcomp.byte"]; - - (* Use an introduction page with categories *) - tag_file "lwt-api.docdir/index.html" ["apiref"]; - dep ["apiref"] ["apiref-intro"]; - flag ["apiref"] & S[A "-intro"; P "apiref-intro"; A"-colorize-code"]; - - (* Glib bindings: *) - let env = BaseEnvLight.load ~allow_empty:true ~filename:MyOCamlbuildBase.env_filename () in - let msvc = BaseEnvLight.var_get "ccomp_type" env = "msvc" in - if BaseEnvLight.var_get "glib" env = "true" || BaseEnvLight.var_get "all" env = "true" then - define_c_library ~msvc ~name:"glib" ~c_name:"glib-2.0" (); - - let opts = S[A "-ppopt"; A "-let"; A "-ppopt"; A ("windows=" ^ if BaseEnvLight.var_get "os_type" env <> "Unix" then "true" else "false")] in - flag ["ocaml"; "compile"; "pa_optcomp"] & opts; - flag ["ocaml"; "ocamldep"; "pa_optcomp"] & opts; - (*flag ["ocaml"; "doc"; "pa_optcomp"] & opts; Does not work... *) - - flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg"; - - let env = BaseEnvLight.load () in - let stdlib_path = BaseEnvLight.var_get "standard_library" env in - - (* Try to find the path where compiler libraries are: *) - let compiler_libs = - let stdlib = String.chomp stdlib_path in - try - let path = - List.find Pathname.exists [ - stdlib / "compiler-libs"; - stdlib / "compiler-lib"; - stdlib / ".." / "compiler-libs"; - stdlib / ".." / "compiler-lib"; - ] - in - path :: List.filter Pathname.exists [ path / "typing"; path / "utils"; path / "parsing" ] - with Not_found -> - [] - in - - (* Add directories for compiler-libraries: *) - let paths = List.map (fun path -> S[A"-I"; A path]) compiler_libs in - List.iter - (fun stage -> flag ["ocaml"; stage; "use_compiler_libs"] & S paths) - ["compile"; "ocamldep"; "doc"; "link"]; - - dep ["file:src/top/toplevel_temp.top"] ["src/core/lwt.cma"; - "src/react/lwt-react.cma"; - "src/unix/lwt-unix.cma"; - "src/text/lwt-text.cma"; - "src/top/lwt-top.cma"]; - - flag ["file:src/top/toplevel_temp.top"] & S[A"-I"; A"src/unix"; - A"-I"; A"src/text"; - A"src/core/lwt.cma"; - A"src/react/lwt-react.cma"; - A"src/unix/lwt-unix.cma"; - A"src/text/lwt-text.cma"; - A"src/top/lwt-top.cma"]; - - (* Expunge compiler modules *) - rule "toplevel expunge" - ~dep:"src/top/toplevel_temp.top" - ~prod:"src/top/lwt_toplevel.byte" - (fun _ _ -> - let directories = - stdlib_path - :: "src/core" - :: "src/react" - :: "src/unix" - :: "src/text" - :: "src/top" - :: (List.map - (fun lib -> - String.chomp - (run_and_read - ("ocamlfind query " ^ lib))) - ["findlib"; "react"; "unix"; "text"]) - in - let modules = - List.fold_left - (fun set directory -> - List.fold_left - (fun set fname -> - if Pathname.check_extension fname "cmi" then - StringSet.add (module_name_of_pathname fname) set - else - set) - set - (Array.to_list (Pathname.readdir directory))) - StringSet.empty directories - in - Cmd(S[A(stdlib_path / "expunge"); - A"src/top/toplevel_temp.top"; - A"src/top/lwt_toplevel.byte"; - A"outcometree"; A"topdirs"; A"toploop"; - S(List.map (fun x -> A x) (StringSet.elements modules))])); - - (* Search for a header file in standard directories. *) - let search_header header = - let rec loop = function - | [] -> - None - | dir :: dirs -> - if Sys.file_exists (dir ^ "/include/" ^ header) then - Some dir - else - loop dirs - in - loop search_paths - in - - (* Add directories for libev and pthreads *) - let flags dir = - flag ["ocamlmklib"; "c"; "use_stubs"] & A("-L" ^ dir ^ "/lib"); - flag ["c"; "compile"; "use_stubs"] & S[A"-ccopt"; A("-I" ^ dir ^ "/include")]; - flag ["link"; "ocaml"; "use_stubs"] & S[A"-cclib"; A("-L" ^ dir ^ "/lib")] - in - begin - match search_header "ev.h", search_header "pthread.h" with - | None, None -> () - | Some path, None | None, Some path -> flags path - | Some path1, Some path2 when path1 = path2 -> flags path1 - | Some path1, Some path2 -> flags path1; flags path2 - end - - | _ -> - ()) - diff --git a/server/thirdparty/lwt-2.3.2/setup.ml b/server/thirdparty/lwt-2.3.2/setup.ml deleted file mode 100644 index f799762..0000000 --- a/server/thirdparty/lwt-2.3.2/setup.ml +++ /dev/null @@ -1,6552 +0,0 @@ -(* - * setup.ml - * -------- - * Copyright : (c) 2011, Jeremie Dimino - * Licence : BSD3 - * - * This file is a part of lwt. - *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: 91ec49eb394436f650011e25724ddc84) *) -(* - Regenerated by OASIS v0.2.0 - Visit http://oasis.forge.ocamlcore.org for more information and - documentation about functions used in this file. -*) -module OASISGettext = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISGettext.ml" - - let ns_ str = - str - - let s_ str = - str - - let f_ (str : ('a, 'b, 'c, 'd) format4) = - str - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - let init = - [] - -end - -module OASISContext = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISContext.ml" - - open OASISGettext - - type level = - [ `Debug - | `Info - | `Warning - | `Error] - - type t = - { - verbose: bool; - debug: bool; - ignore_plugins: bool; - printf: level -> string -> unit; - } - - let printf lvl str = - let beg = - match lvl with - | `Error -> s_ "E: " - | `Warning -> s_ "W: " - | `Info -> s_ "I: " - | `Debug -> s_ "D: " - in - match lvl with - | `Error -> - prerr_endline (beg^str) - | _ -> - print_endline (beg^str) - - let default = - ref - { - verbose = true; - debug = false; - ignore_plugins = false; - printf = printf; - } - - let quiet = - {!default with - verbose = false; - debug = false; - } - - - let args () = - ["-quiet", - Arg.Unit (fun () -> default := {!default with verbose = false}), - (s_ " Run quietly"); - - "-debug", - Arg.Unit (fun () -> default := {!default with debug = true}), - (s_ " Output debug message")] -end - -module OASISUtils = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISUtils.ml" - - module MapString = Map.Make(String) - - let map_string_of_assoc assoc = - List.fold_left - (fun acc (k, v) -> MapString.add k v acc) - MapString.empty - assoc - - module SetString = Set.Make(String) - - let set_string_add_list st lst = - List.fold_left - (fun acc e -> SetString.add e acc) - st - lst - - let set_string_of_list = - set_string_add_list - SetString.empty - - - let compare_csl s1 s2 = - String.compare (String.lowercase s1) (String.lowercase s2) - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - - let equal s1 s2 = - (String.lowercase s1) = (String.lowercase s2) - - let hash s = - Hashtbl.hash (String.lowercase s) - end) - - let split sep str = - let str_len = - String.length str - in - let rec split_aux acc pos = - if pos < str_len then - ( - let pos_sep = - try - String.index_from str pos sep - with Not_found -> - str_len - in - let part = - String.sub str pos (pos_sep - pos) - in - let acc = - part :: acc - in - if pos_sep >= str_len then - ( - (* Nothing more in the string *) - List.rev acc - ) - else if pos_sep = (str_len - 1) then - ( - (* String end with a separator *) - List.rev ("" :: acc) - ) - else - ( - split_aux acc (pos_sep + 1) - ) - ) - else - ( - List.rev acc - ) - in - split_aux [] 0 - - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buff = - Buffer.create (String.length s) - in - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - Buffer.add_char buff hyphen; - - String.iter - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - Buffer.add_char buff c - else - Buffer.add_char buff hyphen) - s; - - String.lowercase (Buffer.contents buff) - end - - let varname_concat ?(hyphen='_') p s = - let p = - let p_len = - String.length p - in - if p_len > 0 && p.[p_len - 1] = hyphen then - String.sub p 0 (p_len - 1) - else - p - in - let s = - let s_len = - String.length s - in - if s_len > 0 && s.[0] = hyphen then - String.sub s 1 (s_len - 1) - else - s - in - Printf.sprintf "%s%c%s" p hyphen s - - - let is_varname str = - str = varname_of_string str - - let failwithf1 fmt a = - failwith (Printf.sprintf fmt a) - - let failwithf2 fmt a b = - failwith (Printf.sprintf fmt a b) - - let failwithf3 fmt a b c = - failwith (Printf.sprintf fmt a b c) - - let failwithf4 fmt a b c d = - failwith (Printf.sprintf fmt a b c d) - - let failwithf5 fmt a b c d e = - failwith (Printf.sprintf fmt a b c d e) - -end - -module PropList = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/PropList.ml" - - open OASISGettext - - type name = string - - exception Not_set of name * string option - exception No_printer of name - exception Unknown_field of name * name - - let string_of_exception = - function - | Not_set (nm, Some rsn) -> - Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn - | Not_set (nm, None) -> - Printf.sprintf (f_ "Field '%s' is not set") nm - | No_printer nm -> - Printf.sprintf (f_ "No default printer for value %s") nm - | Unknown_field (nm, schm) -> - Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm - | e -> - raise e - - module Data = - struct - - type t = - (name, unit -> unit) Hashtbl.t - - let create () = - Hashtbl.create 13 - - let clear t = - Hashtbl.clear t - -# 59 "/home/chambart/bordel/oasis/oasis/src/oasis/PropList.ml" - end - - module Schema = - struct - - type ('ctxt, 'extra) value = - { - get: Data.t -> string; - set: Data.t -> ?context:'ctxt -> string -> unit; - help: (unit -> string) option; - extra: 'extra; - } - - type ('ctxt, 'extra) t = - { - name: name; - fields: (name, ('ctxt, 'extra) value) Hashtbl.t; - order: name Queue.t; - name_norm: string -> string; - } - - let create ?(case_insensitive=false) nm = - { - name = nm; - fields = Hashtbl.create 13; - order = Queue.create (); - name_norm = - (if case_insensitive then - String.lowercase - else - fun s -> s); - } - - let add t nm set get extra help = - let key = - t.name_norm nm - in - - if Hashtbl.mem t.fields key then - failwith - (Printf.sprintf - (f_ "Field '%s' is already defined in schema '%s'") - nm t.name); - Hashtbl.add - t.fields - key - { - set = set; - get = get; - help = help; - extra = extra; - }; - Queue.add nm t.order - - let mem t nm = - Hashtbl.mem t.fields nm - - let find t nm = - try - Hashtbl.find t.fields (t.name_norm nm) - with Not_found -> - raise (Unknown_field (nm, t.name)) - - let get t data nm = - (find t nm).get data - - let set t data nm ?context x = - (find t nm).set - data - ?context - x - - let fold f acc t = - Queue.fold - (fun acc k -> - let v = - find t k - in - f acc k v.extra v.help) - acc - t.order - - let iter f t = - fold - (fun () -> f) - () - t - - let name t = - t.name - end - - module Field = - struct - - type ('ctxt, 'value, 'extra) t = - { - set: Data.t -> ?context:'ctxt -> 'value -> unit; - get: Data.t -> 'value; - sets: Data.t -> ?context:'ctxt -> string -> unit; - gets: Data.t -> string; - help: (unit -> string) option; - extra: 'extra; - } - - let new_id = - let last_id = - ref 0 - in - fun () -> incr last_id; !last_id - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - (* Default value container *) - let v = - ref None - in - - (* If name is not given, create unique one *) - let nm = - match name with - | Some s -> s - | None -> Printf.sprintf "_anon_%d" (new_id ()) - in - - (* Last chance to get a value: the default *) - let default () = - match default with - | Some d -> d - | None -> raise (Not_set (nm, Some (s_ "no default value"))) - in - - (* Get data *) - let get data = - (* Get value *) - try - (Hashtbl.find data nm) (); - match !v with - | Some x -> x - | None -> default () - with Not_found -> - default () - in - - (* Set data *) - let set data ?context x = - let x = - match update with - | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end - | None -> - x - in - Hashtbl.replace - data - nm - (fun () -> v := Some x) - in - - (* Parse string value, if possible *) - let parse = - match parse with - | Some f -> - f - | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) - in - - (* Set data, from string *) - let sets data ?context s = - set ?context data (parse ?context s) - in - - (* Output value as string, if possible *) - let print = - match print with - | Some f -> - f - | None -> - fun _ -> raise (No_printer nm) - in - - (* Get data, as a string *) - let gets data = - print (get data) - in - - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; - - { - set = set; - get = get; - sets = sets; - gets = gets; - help = help; - extra = extra; - } - - let fset data t ?context x = - t.set data ?context x - - let fget data t = - t.get data - - let fsets data t ?context s = - t.sets data ?context s - - let fgets data t = - t.gets data - - end - - module FieldRO = - struct - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - let fld = - Field.create ?schema ?name ?parse ?print ?default ?update ?help extra - in - fun data -> Field.fget data fld - - end -end - -module OASISMessage = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISMessage.ml" - - - open OASISGettext - open OASISContext - - let generic_message ~ctxt lvl fmt = - let cond = - match lvl with - | `Debug -> ctxt.debug - | _ -> ctxt.verbose - in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt - - let debug ~ctxt fmt = - generic_message ~ctxt `Debug fmt - - let info ~ctxt fmt = - generic_message ~ctxt `Info fmt - - let warning ~ctxt fmt = - generic_message ~ctxt `Warning fmt - - let error ~ctxt fmt = - generic_message ~ctxt `Error fmt - - - let string_of_exception e = - try - PropList.string_of_exception e - with - | Failure s -> - s - | e -> - Printexc.to_string e - - (* TODO - let register_exn_printer f = - *) - -end - -module OASISVersion = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISVersion.ml" - - open OASISGettext - - - - type s = string - - type t = string - - type comparator = - | VGreater of t - | VGreaterEqual of t - | VEqual of t - | VLesser of t - | VLesserEqual of t - | VOr of comparator * comparator - | VAnd of comparator * comparator - - - (* Range of allowed characters *) - let is_digit c = - '0' <= c && c <= '9' - - let is_alpha c = - ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') - - let is_special = - function - | '.' | '+' | '-' | '~' -> true - | _ -> false - - let rec version_compare v1 v2 = - if v1 <> "" || v2 <> "" then - begin - (* Compare ascii string, using special meaning for version - * related char - *) - let val_ascii c = - if c = '~' then -1 - else if is_digit c then 0 - else if c = '\000' then 0 - else if is_alpha c then Char.code c - else (Char.code c) + 256 - in - - let len1 = String.length v1 in - let len2 = String.length v2 in - - let p = ref 0 in - - (** Compare ascii part *) - let compare_vascii () = - let cmp = ref 0 in - while !cmp = 0 && - !p < len1 && !p < len2 && - not (is_digit v1.[!p] && is_digit v2.[!p]) do - cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); - incr p - done; - if !cmp = 0 && !p < len1 && !p = len2 then - val_ascii v1.[!p] - else if !cmp = 0 && !p = len1 && !p < len2 then - - (val_ascii v2.[!p]) - else - !cmp - in - - (** Compare digit part *) - let compare_digit () = - let extract_int v p = - let start_p = !p in - while !p < String.length v && is_digit v.[!p] do - incr p - done; - match String.sub v start_p (!p - start_p) with - | "" -> 0, - v - | s -> int_of_string s, - String.sub v !p ((String.length v) - !p) - in - let i1, tl1 = extract_int v1 (ref !p) in - let i2, tl2 = extract_int v2 (ref !p) in - i1 - i2, tl1, tl2 - in - - match compare_vascii () with - | 0 -> - begin - match compare_digit () with - | 0, tl1, tl2 -> - if tl1 <> "" && is_digit tl1.[0] then - 1 - else if tl2 <> "" && is_digit tl2.[0] then - -1 - else - version_compare tl1 tl2 - | n, _, _ -> - n - end - | n -> - n - end - else - begin - 0 - end - - - let version_of_string str = - String.iter - (fun c -> - if is_alpha c || is_digit c || is_special c then - () - else - failwith - (Printf.sprintf - (f_ "Char %C is not allowed in version '%s'") - c str)) - str; - str - - let string_of_version t = - t - - let chop t = - try - let pos = - String.rindex t '.' - in - String.sub t 0 pos - with Not_found -> - t - - let rec comparator_apply v op = - match op with - | VGreater cv -> - (version_compare v cv) > 0 - | VGreaterEqual cv -> - (version_compare v cv) >= 0 - | VLesser cv -> - (version_compare v cv) < 0 - | VLesserEqual cv -> - (version_compare v cv) <= 0 - | VEqual cv -> - (version_compare v cv) = 0 - | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) - | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) - - let rec string_of_comparator = - function - | VGreater v -> "> "^(string_of_version v) - | VEqual v -> "= "^(string_of_version v) - | VLesser v -> "< "^(string_of_version v) - | VGreaterEqual v -> ">= "^(string_of_version v) - | VLesserEqual v -> "<= "^(string_of_version v) - | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) - | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) - - let rec varname_of_comparator = - let concat p v = - OASISUtils.varname_concat - p - (OASISUtils.varname_of_string - (string_of_version v)) - in - function - | VGreater v -> concat "gt" v - | VLesser v -> concat "lt" v - | VEqual v -> concat "eq" v - | VGreaterEqual v -> concat "ge" v - | VLesserEqual v -> concat "le" v - | VOr (c1, c2) -> - (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) - | VAnd (c1, c2) -> - (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - -end - -module OASISLicense = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISLicense.ml" - - (** License for _oasis fields - @author Sylvain Le Gall - *) - - - - type license = string - - type license_exception = string - - type license_version = - | Version of OASISVersion.t - | VersionOrLater of OASISVersion.t - | NoVersion - - - type license_dep_5 = - { - license: license; - exceptions: license_exception list; - version: license_version; - } - - type t = - | DEP5License of license_dep_5 - | OtherLicense of string (* URL *) - - -end - -module OASISExpr = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISExpr.ml" - - - - open OASISGettext - - type test = string - - type flag = string - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - type 'a choices = (t * 'a) list - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - -end - -module OASISTypes = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISTypes.ml" - - - - - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - - type findlib_name = string - type findlib_full = string - - type compiled_object = - | Byte - | Native - | Best - - - type dependency = - | FindlibPackage of findlib_full * OASISVersion.comparator option - | InternalLibrary of name - - - type tool = - | ExternalTool of name - | InternalExecutable of name - - - type vcs = - | Darcs - | Git - | Svn - | Cvs - | Hg - | Bzr - | Arch - | Monotone - | OtherVCS of url - - - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] - - type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] - - type 'a plugin = 'a * name * OASISVersion.t option - - type all_plugin = plugin_kind plugin - - type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list - -# 102 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISTypes.ml" - - type 'a conditional = 'a OASISExpr.choices - - type custom = - { - pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; - } - - - type common_section = - { - cs_name: name; - cs_data: PropList.Data.t; - cs_plugin_data: plugin_data; - } - - - type build_section = - { - bs_build: bool conditional; - bs_install: bool conditional; - bs_path: unix_dirname; - bs_compiled_object: compiled_object; - bs_build_depends: dependency list; - bs_build_tools: tool list; - bs_c_sources: unix_filename list; - bs_data_files: (unix_filename * unix_filename option) list; - bs_ccopt: args conditional; - bs_cclib: args conditional; - bs_dlllib: args conditional; - bs_dllpath: args conditional; - bs_byteopt: args conditional; - bs_nativeopt: args conditional; - } - - - type library = - { - lib_modules: string list; - lib_internal_modules: string list; - lib_findlib_parent: findlib_name option; - lib_findlib_name: findlib_name option; - lib_findlib_containers: findlib_name list; - } - - type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } - - type flag = - { - flag_description: string option; - flag_default: bool conditional; - } - - type source_repository = - { - src_repo_type: vcs; - src_repo_location: url; - src_repo_browser: url option; - src_repo_module: string option; - src_repo_branch: string option; - src_repo_tag: string option; - src_repo_subdir: unix_filename option; - } - - type test = - { - test_type: [`Test] plugin; - test_command: command_line conditional; - test_custom: custom; - test_working_directory: unix_filename option; - test_run: bool conditional; - test_tools: tool list; - } - - type doc_format = - | HTML of unix_filename - | DocText - | PDF - | PostScript - | Info of unix_filename - | DVI - | OtherDoc - - - type doc = - { - doc_type: [`Doc] plugin; - doc_custom: custom; - doc_build: bool conditional; - doc_install: bool conditional; - doc_install_dir: unix_filename; - doc_title: string; - doc_authors: string list; - doc_abstract: string option; - doc_format: doc_format; - doc_data_files: (unix_filename * unix_filename option) list; - doc_build_tools: tool list; - } - - type section = - | Library of common_section * build_section * library - | Executable of common_section * build_section * executable - | Flag of common_section * flag - | SrcRepo of common_section * source_repository - | Test of common_section * test - | Doc of common_section * doc - - - type package = - { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: string option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } - -end - -module OASISUnixPath = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISUnixPath.ml" - - type unix_filename = string - type unix_dirname = string - - type host_filename = string - type host_dirname = string - - let current_dir_name = "." - - let parent_dir_name = ".." - - let concat f1 f2 = - if f1 = current_dir_name then - f2 - else if f2 = current_dir_name then - f1 - else - f1^"/"^f2 - - let make = - function - | hd :: tl -> - List.fold_left - (fun f p -> concat f p) - hd - tl - | [] -> - invalid_arg "OASISUnixPath.make" - - let dirname f = - try - String.sub f 0 (String.rindex f '/') - with Not_found -> - current_dir_name - - let basename f = - try - let pos_start = - (String.rindex f '/') + 1 - in - String.sub f pos_start ((String.length f) - pos_start) - with Not_found -> - f - - let chop_extension f = - try - let last_dot = - String.rindex f '.' - in - let sub = - String.sub f 0 last_dot - in - try - let last_slash = - String.rindex f '/' - in - if last_slash < last_dot then - sub - else - f - with Not_found -> - sub - - with Not_found -> - f - - let capitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.capitalize base) - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.uncapitalize base) -end - -module OASISSection = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISSection.ml" - - (** Manipulate section - @author Sylvain Le Gall - *) - - open OASISTypes - - type section_kind = - | KLibrary - | KExecutable - | KFlag - | KSrcRepo - | KTest - | KDoc - - (** Extract generic information - *) - let section_kind_common = - function - | Library (cs, _, _) -> - KLibrary, cs - | Executable (cs, _, _) -> - KExecutable, cs - | Flag (cs, _) -> - KFlag, cs - | SrcRepo (cs, _) -> - KSrcRepo, cs - | Test (cs, _) -> - KTest, cs - | Doc (cs, _) -> - KDoc, cs - - (** Common section of a section - *) - let section_common sct = - snd (section_kind_common sct) - - (** Key used to identify section - *) - let section_id sct = - let k, cs = - section_kind_common sct - in - k, cs.cs_name - - let string_of_section sct = - let k, nm = - section_id sct - in - (match k with - | KLibrary -> "library" - | KExecutable -> "executable" - | KFlag -> "flag" - | KSrcRepo -> "src repository" - | KTest -> "test" - | KDoc -> "doc") - ^" "^nm - -end - -module OASISBuildSection = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISBuildSection.ml" - -end - -module OASISExecutable = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISExecutable.ml" - - open OASISTypes - - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = - OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.dirname exec.exec_main_is) - in - let is_native_exec = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native () - | Byte -> false - in - - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), - - if not is_native_exec && - not exec.exec_custom && - bs.bs_c_sources <> [] then - Some (dir^"/dll"^cs.cs_name^(ext_dll ())) - else - None - -end - -module OASISLibrary = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISLibrary.ml" - - open OASISTypes - open OASISUtils - open OASISGettext - - type library_name = name - - let generated_unix_files ~ctxt (cs, bs, lib) - source_file_exists is_native ext_lib ext_dll = - (* The headers that should be compiled along *) - let headers = - List.fold_left - (fun hdrs modul -> - try - let base_fn = - List.find - (fun fn -> - source_file_exists (fn^".ml") || - source_file_exists (fn^".mli") || - source_file_exists (fn^".mll") || - source_file_exists (fn^".mly")) - (List.map - (OASISUnixPath.concat bs.bs_path) - [modul; - OASISUnixPath.uncapitalize_file modul; - OASISUnixPath.capitalize_file modul]) - in - [base_fn^".cmi"] :: hdrs - with Not_found -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - (List.map (OASISUnixPath.concat bs.bs_path) - [modul^".cmi"; - OASISUnixPath.uncapitalize_file modul ^ ".cmi"; - OASISUnixPath.capitalize_file modul ^ ".cmi"]) - :: hdrs) - [] - lib.lib_modules - in - - let acc_nopath = - [] - in - - (* Compute what libraries should be built *) - let acc_nopath = - let byte acc = - [cs.cs_name^".cma"] :: acc - in - let native acc = - [cs.cs_name^".cmxs"] :: [cs.cs_name^".cmxa"] :: [cs.cs_name^(ext_lib ())] :: acc - in - match bs.bs_compiled_object with - | Native -> - byte (native acc_nopath) - | Best when is_native () -> - byte (native acc_nopath) - | Byte | Best -> - byte acc_nopath - in - - (* Add C library to be built *) - let acc_nopath = - if bs.bs_c_sources <> [] then - begin - ["lib"^cs.cs_name^(ext_lib ())] - :: - ["dll"^cs.cs_name^(ext_dll ())] - :: - acc_nopath - end - else - acc_nopath - in - - (* All the files generated *) - List.rev_append - (List.rev_map - (List.rev_map - (OASISUnixPath.concat bs.bs_path)) - acc_nopath) - headers - - - type group_t = - | Container of findlib_name * (group_t list) - | Package of (findlib_name * - common_section * - build_section * - library * - (group_t list)) - - let group_libs pkg = - (** Associate a name with its children *) - let children = - List.fold_left - (fun mp -> - function - | Library (cs, bs, lib) -> - begin - match lib.lib_findlib_parent with - | Some p_nm -> - begin - let children = - try - MapString.find p_nm mp - with Not_found -> - [] - in - MapString.add p_nm ((cs, bs, lib) :: children) mp - end - | None -> - mp - end - | _ -> - mp) - MapString.empty - pkg.sections - in - - (* Compute findlib name of a single node *) - let findlib_name (cs, _, lib) = - match lib.lib_findlib_name with - | Some nm -> nm - | None -> cs.cs_name - in - - (** Build a package tree *) - let rec tree_of_library containers ((cs, bs, lib) as acc) = - match containers with - | hd :: tl -> - Container (hd, [tree_of_library tl acc]) - | [] -> - Package - (findlib_name acc, cs, bs, lib, - (try - List.rev_map - (fun ((_, _, child_lib) as child_acc) -> - tree_of_library - child_lib.lib_findlib_containers - child_acc) - (MapString.find cs.cs_name children) - with Not_found -> - [])) - in - - (** Merge containers with the same name *) - let rec merge_containers groups = - (* Collect packages and create the map "container name -> merged children" *) - let packages, containers = - List.fold_left - (fun (packages, containers) group -> - match group with - | Container(name, children) -> - let children' = - try - MapString.find name containers - with Not_found -> - [] - in - (packages, - MapString.add name (children' @ children) containers) - | Package(name, cs, bs, lib, children) -> - (Package(name, cs, bs, lib, merge_containers children) :: packages, - containers)) - ([], MapString.empty) - groups - in - (* Recreate the list of groups *) - packages @ - (MapString.fold - (fun name children acc -> - Container(name, merge_containers children) :: acc) - containers []) - in - - (* TODO: check that libraries are unique *) - merge_containers - (List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when lib.lib_findlib_parent = None -> - (tree_of_library lib.lib_findlib_containers (cs, bs, lib)) :: acc - | _ -> - acc) - [] - pkg.sections) - - (** Compute internal to findlib library matchings, including subpackage - and return a map of it. - *) - let findlib_name_map pkg = - - (* Compute names in a tree *) - let rec findlib_names_aux path mp grp = - let fndlb_nm, children, mp = - match grp with - | Container (fndlb_nm, children) -> - fndlb_nm, children, mp - - | Package (fndlb_nm, {cs_name = nm}, _, _, children) -> - fndlb_nm, children, (MapString.add nm (path, fndlb_nm) mp) - in - let fndlb_nm_full = - (match path with - | Some pth -> pth^"." - | None -> "")^ - fndlb_nm - in - List.fold_left - (findlib_names_aux (Some fndlb_nm_full)) - mp - children - in - - List.fold_left - (findlib_names_aux None) - MapString.empty - (group_libs pkg) - - - let findlib_of_name ?(recurse=false) map nm = - try - let (path, fndlb_nm) = - MapString.find nm map - in - match path with - | Some pth when recurse -> pth^"."^fndlb_nm - | _ -> fndlb_nm - - with Not_found -> - failwithf1 - (f_ "Unable to translate internal library '%s' to findlib name") - nm - - let name_findlib_map pkg = - let mp = - findlib_name_map pkg - in - MapString.fold - (fun nm _ acc -> - let fndlb_nm_full = - findlib_of_name - ~recurse:true - mp - nm - in - MapString.add fndlb_nm_full nm acc) - mp - MapString.empty - - let findlib_of_group = - function - | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _) -> fndlb_nm - - let root_of_group grp = - let rec root_lib_aux = - function - | Container (_, children) -> - root_lib_lst children - | Package (_, cs, bs, lib, children) -> - if lib.lib_findlib_parent = None then - cs, bs, lib - else - root_lib_lst children - and root_lib_lst = - function - | [] -> - raise Not_found - | hd :: tl -> - try - root_lib_aux hd - with Not_found -> - root_lib_lst tl - in - try - root_lib_aux grp - with Not_found -> - failwithf1 - (f_ "Unable to determine root library of findlib library '%s'") - (findlib_of_group grp) - - -end - -module OASISFlag = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISFlag.ml" - -end - -module OASISPackage = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISPackage.ml" - -end - -module OASISSourceRepository = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISSourceRepository.ml" - -end - -module OASISTest = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISTest.ml" - -end - -module OASISDocument = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISDocument.ml" - -end - - -module BaseEnvLight = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseEnvLight.ml" - - module MapString = Map.Make(String) - - type t = string MapString.t - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - let var_get name env = - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - in - var_expand (MapString.find name env) - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -module BaseContext = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseContext.ml" - - open OASISContext - - let args = args - - let default = default - -end - -module BaseMessage = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseMessage.ml" - - (** Message to user, overrid for Base - @author Sylvain Le Gall - *) - open OASISMessage - open BaseContext - - let debug fmt = debug ~ctxt:!default fmt - - let info fmt = info ~ctxt:!default fmt - - let warning fmt = warning ~ctxt:!default fmt - - let error fmt = error ~ctxt:!default fmt - - let string_of_exception = string_of_exception - -end - -module BaseFilePath = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseFilePath.ml" - - - open Filename - - module Unix = OASISUnixPath - - let make = - function - | [] -> - invalid_arg "BaseFilename.make" - | hd :: tl -> - List.fold_left Filename.concat hd tl - - let of_unix ufn = - if Sys.os_type = "Unix" then - ufn - else - make - (List.map - (fun p -> - if p = Unix.current_dir_name then - current_dir_name - else if p = Unix.parent_dir_name then - parent_dir_name - else - p) - (OASISUtils.split '/' ufn)) - -end - -module BaseEnv = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseEnv.ml" - - open OASISTypes - open OASISGettext - open OASISUtils - open PropList - - module MapString = BaseEnvLight.MapString - - type origin_t = - | ODefault - | OGetEnv - | OFileLoad - | OCommandLine - - type cli_handle_t = - | CLINone - | CLIAuto - | CLIWith - | CLIEnable - | CLIUser of (Arg.key * Arg.spec * Arg.doc) list - - type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } - - let schema = - Schema.create "environment" - - (* Environment data *) - let env = - Data.create () - - (* Environment data from file *) - let env_from_file = - ref MapString.empty - - (* Lexer for var *) - let var_lxr = - Genlex.make_lexer [] - - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command - * without defining executable name really. I.e. if there is - * an exec Executable toto, then $(toto) should be replace - * by its real name. It is however useful to have this function - * for other variable that depend on the host and should be - * written better than that. - *) - let st = - var_lxr (Stream.of_string var) - in - match Stream.npeek 3 st with - | [Genlex.Ident "utoh"; Genlex.Ident nm] -> - BaseFilePath.of_unix (var_get nm) - | [Genlex.Ident "utoh"; Genlex.String s] -> - BaseFilePath.of_unix s - | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> - String.escaped (var_get nm) - | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> - String.escaped s - | [Genlex.Ident nm] -> - var_get nm - | _ -> - failwithf2 - (f_ "Unknown expression '%s' in variable expansion of %s.") - var - str - with - | Unknown_field (_, _) -> - failwithf2 - (f_ "No variable %s defined when trying to expand %S.") - var - str - | Stream.Error e -> - failwithf3 - (f_ "Syntax error when parsing '%s' when trying to \ - expand %S: %s") - var - str - e) - str; - Buffer.contents buff - - and var_get name = - let vl = - try - Schema.get schema env name - with Unknown_field _ as e -> - begin - try - MapString.find name !env_from_file - with Not_found -> - raise e - end - in - var_expand vl - - let var_choose ?printer ?name lst = - OASISExpr.choose - ?printer - ?name - var_get - lst - - let var_protect vl = - let buff = - Buffer.create (String.length vl) - in - String.iter - (function - | '$' -> Buffer.add_string buff "\\$" - | c -> Buffer.add_char buff c) - vl; - Buffer.contents buff - - let var_define - ?(hide=false) - ?(dump=true) - ?short_desc - ?(cli=CLINone) - ?arg_help - ?group - name (* TODO: type constraint on the fact that name must be a valid OCaml - id *) - dflt = - - let default = - [ - OFileLoad, lazy (MapString.find name !env_from_file); - ODefault, dflt; - OGetEnv, lazy (Sys.getenv name); - ] - in - - let extra = - { - hide = hide; - dump = dump; - cli = cli; - arg_help = arg_help; - group = group; - } - in - - (* Try to find a value that can be defined - *) - let var_get_low lst = - let errors, res = - List.fold_left - (fun (errors, res) (_, v) -> - if res = None then - begin - try - errors, Some (Lazy.force v) - with - | Not_found -> - errors, res - | Failure rsn -> - (rsn :: errors), res - | e -> - (Printexc.to_string e) :: errors, res - end - else - errors, res) - ([], None) - (List.sort - (fun (o1, _) (o2, _) -> - if o1 < o2 then - 1 - else if o1 = o2 then - 0 - else - -1) - lst) - in - match res, errors with - | Some v, _ -> - v - | None, [] -> - raise (Not_set (name, None)) - | None, lst -> - raise (Not_set (name, Some (String.concat (s_ ", ") lst))) - in - - let help = - match short_desc with - | Some fs -> Some fs - | None -> None - in - - let var_get_lst = - FieldRO.create - ~schema - ~name - ~parse:(fun ?(context=ODefault) s -> [context, lazy s]) - ~print:var_get_low - ~default - ~update:(fun ?context x old_x -> x @ old_x) - ?help - extra - in - - fun () -> - var_expand (var_get_low (var_get_lst env)) - - let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = - if Schema.mem schema name then - begin - Schema.set schema env ~context:ODefault name (Lazy.force dflt); - fun () -> var_get name - end - else - begin - var_define - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt - end - - let var_ignore (e : unit -> string) = - () - - let print_hidden = - var_define - ~hide:true - ~dump:false - ~cli:CLIAuto - ~arg_help:"Print even non-printable variable. (debug)" - "print_hidden" - (lazy "false") - - let var_all () = - List.rev - (Schema.fold - (fun acc nm def _ -> - if not def.hide || bool_of_string (print_hidden ()) then - nm :: acc - else - acc) - [] - schema) - - let default_filename = - BaseEnvLight.default_filename - - let load ?allow_empty ?filename () = - env_from_file := BaseEnvLight.load ?allow_empty ?filename () - - let unload () = - (* TODO: reset lazy values *) - env_from_file := MapString.empty; - Data.clear env - - let dump ?(filename=default_filename) () = - let chn = - open_out_bin filename - in - Schema.iter - (fun nm def _ -> - if def.dump then - begin - try - let value = - Schema.get - schema - env - nm - in - Printf.fprintf chn "%s = %S\n" nm value - with Not_set _ -> - () - end) - schema; - close_out chn - - let print () = - let printable_vars = - Schema.fold - (fun acc nm def short_descr_opt -> - if not def.hide || bool_of_string (print_hidden ()) then - begin - try - let value = - Schema.get - schema - env - nm - in - let txt = - match short_descr_opt with - | Some s -> s () - | None -> nm - in - (txt, value) :: acc - with Not_set _ -> - acc - end - else - acc) - [] - schema - in - let max_length = - List.fold_left max 0 - (List.rev_map String.length - (List.rev_map fst printable_vars)) - in - let dot_pad str = - String.make ((max_length - (String.length str)) + 3) '.' - in - - print_newline (); - print_endline "Configuration: "; - print_newline (); - List.iter - (fun (name,value) -> - Printf.printf "%s: %s %s\n" name (dot_pad name) value) - printable_vars; - Printf.printf "%!"; - print_newline () - - let args () = - let arg_concat = - OASISUtils.varname_concat ~hyphen:'-' - in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; - - ] - @ - List.flatten - (Schema.fold - (fun acc name def short_descr_opt -> - let var_set s = - Schema.set - schema - env - ~context:OCommandLine - name - s - in - - let arg_name = - OASISUtils.varname_of_string ~hyphen:'-' name - in - - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - in - - let arg_hlp = - match def.arg_help with - | Some s -> s - | None -> "str" - in - - let default_value = - try - Printf.sprintf - (f_ " [%s]") - (Schema.get - schema - env - name) - with Not_set _ -> - "" - in - - let args = - match def.cli with - | CLINone -> - [] - | CLIAuto -> - [ - arg_concat "--" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIWith -> - [ - arg_concat "--with-" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIEnable -> - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp - (if default_value = " [true]" then - (s_ " [default]") - else - ""); - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp - (if default_value = " [false]" then - (s_ " [default]") - else - ""); - ] - | CLIUser lst -> - lst - in - args :: acc) - [] - schema) -end - -module BaseExec = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseExec.ml" - - open OASISGettext - open OASISUtils - open BaseMessage - - let run ?f_exit_code cmd args = - let cmdline = - String.concat " " (cmd :: args) - in - info (f_ "Running command '%s'") cmdline; - match f_exit_code, Sys.command cmdline with - | None, 0 -> () - | None, i -> - failwithf2 - (f_ "Command '%s' terminated with error code %d") - cmdline i - | Some f, i -> - f i - - let run_read_output cmd args = - let fn = - Filename.temp_file "oasis-" ".txt" - in - let () = - try - run cmd (args @ [">"; Filename.quote fn]) - with e -> - Sys.remove fn; - raise e - in - let chn = - open_in fn - in - let routput = - ref [] - in - ( - try - while true do - routput := (input_line chn) :: !routput - done - with End_of_file -> - () - ); - close_in chn; - Sys.remove fn; - List.rev !routput - - let run_read_one_line cmd args = - match run_read_output cmd args with - | [fst] -> - fst - | lst -> - failwithf1 - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) -end - -module BaseFileUtil = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseFileUtil.ml" - - open OASISGettext - - let find_file paths exts = - - (* Cardinal product of two list *) - let ( * ) lst1 lst2 = - List.flatten - (List.map - (fun a -> - List.map - (fun b -> a,b) - lst2) - lst1) - in - - let rec combined_paths lst = - match lst with - | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a,b) -> Filename.concat a b) - (p1 * p2)) - in - combined_paths (acc :: tl) - | [e] -> - e - | [] -> - [] - in - - let alternatives = - List.map - (fun (p,e) -> - if String.length e > 0 && e.[0] <> '.' then - p ^ "." ^ e - else - p ^ e) - ((combined_paths paths) * exts) - in - List.find - Sys.file_exists - alternatives - - let which prg = - let path_sep = - match Sys.os_type with - | "Win32" -> - ';' - | _ -> - ':' - in - let path_lst = - OASISUtils.split - path_sep - (Sys.getenv "PATH") - in - let exec_ext = - match Sys.os_type with - | "Win32" -> - "" - :: - (OASISUtils.split - path_sep - (Sys.getenv "PATHEXT")) - | _ -> - [""] - in - find_file [path_lst; [prg]] exec_ext - - (**/**) - let rec fix_dir dn = - (* Windows hack because Sys.file_exists "src\\" = false when - * Sys.file_exists "src" = true - *) - let ln = - String.length dn - in - if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then - fix_dir (String.sub dn 0 (ln - 1)) - else - dn - - let q = Filename.quote - (**/**) - - let cp src tgt = - BaseExec.run - (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") - [q src; q tgt] - - let mkdir tgt = - BaseExec.run - (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") - [q tgt] - - let rec mkdir_parent f tgt = - let tgt = - fix_dir tgt - in - if Sys.file_exists tgt then - begin - if not (Sys.is_directory tgt) then - OASISUtils.failwithf1 - (f_ "Cannot create directory '%s', a file of the same name already \ - exists") - tgt - end - else - begin - mkdir_parent f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then - begin - f tgt; - mkdir tgt - end - end - - let rmdir tgt = - if Sys.readdir tgt = [||] then - begin - match Sys.os_type with - | "Win32" -> - BaseExec.run "rd" [q tgt] - | _ -> - BaseExec.run "rm" ["-r"; q tgt] - end - - let glob fn = - let basename = - Filename.basename fn - in - if String.length basename >= 2 && - basename.[0] = '*' && - basename.[1] = '.' then - begin - let ext_len = - (String.length basename) - 2 - in - let ext = - String.sub basename 2 ext_len - in - let dirname = - Filename.dirname fn - in - Array.fold_left - (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) - ext_len - in - if fn_ext = ext then - (Filename.concat dirname fn) :: acc - else - acc - with Invalid_argument _ -> - acc) - [] - (Sys.readdir dirname) - end - else - begin - if Sys.file_exists fn then - [fn] - else - [] - end -end - -module BaseArgExt = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseArgExt.ml" - - open OASISUtils - open OASISGettext - - let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in - - try - Arg.parse_argv - ~current:current - (Array.concat [[|"none"|]; argv]) - (Arg.align args) - (failwithf1 (f_ "Don't know what to do with arguments: '%s'")) - (s_ "configure options:") - with - | Arg.Help txt -> - print_endline txt; - exit 0 - | Arg.Bad txt -> - prerr_endline txt; - exit 1 -end - -module BaseCheck = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseCheck.ml" - - open BaseEnv - open BaseMessage - open OASISUtils - open OASISGettext - - let prog_best prg prg_lst = - var_redefine - prg - (lazy - (let alternate = - List.fold_left - (fun res e -> - match res with - | Some _ -> - res - | None -> - try - Some (BaseFileUtil.which e) - with Not_found -> - None) - None - prg_lst - in - match alternate with - | Some prg -> prg - | None -> raise Not_found)) - - let prog prg = - prog_best prg [prg] - - let prog_opt prg = - prog_best prg [prg^".opt"; prg] - - let ocamlfind = - prog "ocamlfind" - - let version - var_prefix - cmp - fversion - () = - (* Really compare version provided *) - let var = - var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) - in - var_redefine - ~hide:true - var - (lazy - (let version_str = - match fversion () with - | "[Distributed with OCaml]" -> - begin - try - (var_get "ocaml_version") - with Not_found -> - warning - (f_ "Variable ocaml_version not defined, fallback \ - to default"); - Sys.ocaml_version - end - | res -> - res - in - let version = - OASISVersion.version_of_string version_str - in - if OASISVersion.comparator_apply version cmp then - version_str - else - failwithf3 - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str)) - () - - let package_version pkg = - BaseExec.run_read_one_line - (ocamlfind ()) - ["query"; "-format"; "%v"; pkg] - - let package ?version_comparator pkg () = - let var = - OASISUtils.varname_concat - "pkg_" - (OASISUtils.varname_of_string pkg) - in - let findlib_dir pkg = - let dir = - BaseExec.run_read_one_line - (ocamlfind ()) - ["query"; "-format"; "%d"; pkg] - in - if Sys.file_exists dir && Sys.is_directory dir then - dir - else - failwithf2 - (f_ "When looking for findlib package %s, \ - directory %s return doesn't exist") - pkg dir - in - let vl = - var_redefine - var - (lazy (findlib_dir pkg)) - () - in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl -end - -module BaseOCamlcConfig = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseOCamlcConfig.ml" - - - open BaseEnv - open OASISUtils - open OASISGettext - - module SMap = Map.Make(String) - - let ocamlc = - BaseCheck.prog_opt "ocamlc" - - let ocamlc_config_map = - (* Map name to value for ocamlc -config output - (name ^": "^value) - *) - let rec split_field mp lst = - match lst with - | line :: tl -> - let mp = - try - let pos_semicolon = - String.index line ':' - in - if pos_semicolon > 1 then - ( - let name = - String.sub line 0 pos_semicolon - in - let linelen = - String.length line - in - let value = - if linelen > pos_semicolon + 2 then - String.sub - line - (pos_semicolon + 2) - (linelen - pos_semicolon - 2) - else - "" - in - SMap.add name value mp - ) - else - ( - mp - ) - with Not_found -> - ( - mp - ) - in - split_field mp tl - | [] -> - mp - in - - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (lazy - (var_protect - (Marshal.to_string - (split_field - SMap.empty - (BaseExec.run_read_output - (ocamlc ()) ["-config"])) - []))) - - let var_define nm = - (* Extract data from ocamlc -config *) - let avlbl_config_get () = - Marshal.from_string - (ocamlc_config_map ()) - 0 - in - let nm_config = - match nm with - | "ocaml_version" -> "version" - | _ -> nm - in - var_redefine - nm - (lazy - (try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value - with Not_found -> - failwithf2 - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ()))) - -end - -module BaseStandardVar = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseStandardVar.ml" - - - open OASISGettext - open OASISTypes - open OASISExpr - open BaseCheck - open BaseEnv - - let ocamlfind = BaseCheck.ocamlfind - let ocamlc = BaseOCamlcConfig.ocamlc - let ocamlopt = prog_opt "ocamlopt" - let ocamlbuild = prog "ocamlbuild" - - - (**/**) - let rpkg = - ref None - - let pkg_get () = - match !rpkg with - | Some pkg -> pkg - | None -> failwith (s_ "OASIS Package is not set") - (**/**) - - let pkg_name = - var_define - ~short_desc:(fun () -> s_ "Package name") - "pkg_name" - (lazy (pkg_get ()).name) - - let pkg_version = - var_define - ~short_desc:(fun () -> s_ "Package version") - "pkg_version" - (lazy - (OASISVersion.string_of_version (pkg_get ()).version)) - - let c = BaseOCamlcConfig.var_define - - let os_type = c "os_type" - let system = c "system" - let architecture = c "architecture" - let ccomp_type = c "ccomp_type" - let ocaml_version = c "ocaml_version" - - (* TODO: Check standard variable presence at runtime *) - - let standard_library_default = c "standard_library_default" - let standard_library = c "standard_library" - let standard_runtime = c "standard_runtime" - let bytecomp_c_compiler = c "bytecomp_c_compiler" - let native_c_compiler = c "native_c_compiler" - let model = c "model" - let ext_obj = c "ext_obj" - let ext_asm = c "ext_asm" - let ext_lib = c "ext_lib" - let ext_dll = c "ext_dll" - let default_executable_name = c "default_executable_name" - let systhread_supported = c "systhread_supported" - - - (**/**) - let p name hlp dflt = - var_define - ~short_desc:hlp - ~cli:CLIAuto - ~arg_help:"dir" - name - dflt - - let (/) a b = - if os_type () = Sys.os_type then - Filename.concat a b - else if os_type () = "Unix" then - BaseFilePath.Unix.concat a b - else - OASISUtils.failwithf1 - (f_ "Cannot handle os_type %s filename concat") - (os_type ()) - (**/**) - - let prefix = - p "prefix" - (fun () -> s_ "Install architecture-independent files dir") - (lazy - (match os_type () with - | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) - | _ -> - "/usr/local")) - - let exec_prefix = - p "exec_prefix" - (fun () -> s_ "Install architecture-dependent files in dir") - (lazy "$prefix") - - let bindir = - p "bindir" - (fun () -> s_ "User executables") - (lazy ("$exec_prefix"/"bin")) - - let sbindir = - p "sbindir" - (fun () -> s_ "System admin executables") - (lazy ("$exec_prefix"/"sbin")) - - let libexecdir = - p "libexecdir" - (fun () -> s_ "Program executables") - (lazy ("$exec_prefix"/"libexec")) - - let sysconfdir = - p "sysconfdir" - (fun () -> s_ "Read-only single-machine data") - (lazy ("$prefix"/"etc")) - - let sharedstatedir = - p "sharedstatedir" - (fun () -> s_ "Modifiable architecture-independent data") - (lazy ("$prefix"/"com")) - - let localstatedir = - p "localstatedir" - (fun () -> s_ "Modifiable single-machine data") - (lazy ("$prefix"/"var")) - - let libdir = - p "libdir" - (fun () -> s_ "Object code libraries") - (lazy ("$exec_prefix"/"lib")) - - let datarootdir = - p "datarootdir" - (fun () -> s_ "Read-only arch-independent data root") - (lazy ("$prefix"/"share")) - - let datadir = - p "datadir" - (fun () -> s_ "Read-only architecture-independent data") - (lazy ("$datarootdir")) - - let infodir = - p "infodir" - (fun () -> s_ "Info documentation") - (lazy ("$datarootdir"/"info")) - - let localedir = - p "localedir" - (fun () -> s_ "Locale-dependent data") - (lazy ("$datarootdir"/"locale")) - - let mandir = - p "mandir" - (fun () -> s_ "Man documentation") - (lazy ("$datarootdir"/"man")) - - let docdir = - p "docdir" - (fun () -> s_ "Documentation root") - (lazy ("$datarootdir"/"doc"/"$pkg_name")) - - let htmldir = - p "htmldir" - (fun () -> s_ "HTML documentation") - (lazy ("$docdir")) - - let dvidir = - p "dvidir" - (fun () -> s_ "DVI documentation") - (lazy ("$docdir")) - - let pdfdir = - p "pdfdir" - (fun () -> s_ "PDF documentation") - (lazy ("$docdir")) - - let psdir = - p "psdir" - (fun () -> s_ "PS documentation") - (lazy ("$docdir")) - - let destdir = - p "destdir" - (fun () -> s_ "Prepend a path when installing package") - (lazy - (raise - (PropList.Not_set - ("destdir", - Some (s_ "undefined by construct"))))) - - let findlib_version = - var_define - "findlib_version" - (lazy - (BaseCheck.package_version "findlib")) - - let is_native = - var_define - "is_native" - (lazy - (try - let _s : string = - ocamlopt () - in - "true" - with PropList.Not_set _ -> - let _s : string = - ocamlc () - in - "false")) - - let ext_program = - var_define - "suffix_program" - (lazy - (match os_type () with - | "Win32" -> ".exe" - | _ -> "" - )) - - let rm = - var_define - ~short_desc:(fun () -> s_ "Remove a file.") - "rm" - (lazy - (match os_type () with - | "Win32" -> "del" - | _ -> "rm -f")) - - let rmdir = - var_define - ~short_desc:(fun () -> s_ "Remove a directory.") - "rmdir" - (lazy - (match os_type () with - | "Win32" -> "rd" - | _ -> "rm -rf")) - - let debug = - var_define - ~short_desc:(fun () -> s_ "Compile with ocaml debug flag on.") - "debug" - (lazy "true") - - let profile = - var_define - ~short_desc:(fun () -> s_ "Compile with ocaml profile flag on.") - "profile" - (lazy "false") - - let init pkg = - rpkg := Some pkg - -end - -module BaseFileAB = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseFileAB.ml" - - open BaseEnv - open OASISGettext - open BaseMessage - - let to_filename fn = - let fn = - BaseFilePath.of_unix fn - in - if not (Filename.check_suffix fn ".ab") then - warning - (f_ "File '%s' doesn't have '.ab' extension") - fn; - Filename.chop_extension fn - - let replace fn_lst = - let buff = - Buffer.create 13 - in - List.iter - (fun fn -> - let fn = - BaseFilePath.of_unix fn - in - let chn_in = - open_in fn - in - let chn_out = - open_out (to_filename fn) - in - ( - try - while true do - Buffer.add_string buff (var_expand (input_line chn_in)); - Buffer.add_char buff '\n' - done - with End_of_file -> - () - ); - Buffer.output_buffer chn_out buff; - Buffer.clear buff; - close_in chn_in; - close_out chn_out) - fn_lst -end - -module BaseLog = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseLog.ml" - - open OASISUtils - - let default_filename = - Filename.concat - (Filename.dirname BaseEnv.default_filename) - "setup.log" - - module SetTupleString = - Set.Make - (struct - type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with - | 0 -> String.compare s12 s22 - | n -> n - end) - - let load () = - if Sys.file_exists default_filename then - begin - let chn = - open_in default_filename - in - let scbuf = - Scanf.Scanning.from_file default_filename - in - let rec read_aux (st, lst) = - if not (Scanf.Scanning.end_of_input scbuf) then - begin - let acc = - try - Scanf.bscanf scbuf "%S %S@\n" - (fun e d -> - let t = - e, d - in - if SetTupleString.mem t st then - st, lst - else - SetTupleString.add t st, - t :: lst) - with Scanf.Scan_failure _ -> - failwith - (Scanf.bscanf scbuf - "%l" - (fun line -> - Printf.sprintf - "Malformed log file '%s' at line %d" - default_filename - line)) - in - read_aux acc - end - else - begin - close_in chn; - List.rev lst - end - in - read_aux (SetTupleString.empty, []) - end - else - begin - [] - end - - let register event data = - let chn_out = - open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename - in - Printf.fprintf chn_out "%S %S\n" event data; - close_out chn_out - - let unregister event data = - if Sys.file_exists default_filename then - begin - let lst = - load () - in - let chn_out = - open_out default_filename - in - let write_something = - ref false - in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - begin - write_something := true; - Printf.fprintf chn_out "%S %S\n" e d - end) - lst; - close_out chn_out; - if not !write_something then - Sys.remove default_filename - end - - let filter events = - let st_events = - List.fold_left - (fun st e -> - SetString.add e st) - SetString.empty - events - in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ()) - - let exists event data = - List.exists - (fun v -> (event, data) = v) - (load ()) -end - -module BaseBuilt = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseBuilt.ml" - - open OASISTypes - open OASISGettext - open BaseStandardVar - open BaseMessage - - type t = - | BExec (* Executable *) - | BExecLib (* Library coming with executable *) - | BLib (* Library *) - | BDoc (* Document *) - - let to_log_event_file t nm = - "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BDoc -> "doc")^ - "_"^nm - - let to_log_event_done t nm = - "is_"^(to_log_event_file t nm) - - let register t nm lst = - BaseLog.register - (to_log_event_done t nm) - "true"; - List.iter - (fun alt -> - let registered = - List.fold_left - (fun registered fn -> - if Sys.file_exists fn then - begin - BaseLog.register - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end - else - registered) - false - alt - in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) - lst - - let unregister t nm = - List.iter - (fun (e, d) -> - BaseLog.unregister e d) - (BaseLog.filter - [to_log_event_file t nm; - to_log_event_done t nm]) - - let fold t nm f acc = - List.fold_left - (fun acc (_, fn) -> - if Sys.file_exists fn then - begin - f acc fn - end - else - begin - warning - (f_ "File '%s' has been marked as built \ - for %s but doesn't exist") - fn - (Printf.sprintf - (match t with - | BExec | BExecLib -> - (f_ "executable %s") - | BLib -> - (f_ "library %s") - | BDoc -> - (f_ "documentation %s")) - nm); - acc - end) - acc - (BaseLog.filter - [to_log_event_file t nm]) - - let is_built t nm = - List.fold_left - (fun is_built (_, d) -> - (try - bool_of_string d - with _ -> - false)) - false - (BaseLog.filter - [to_log_event_done t nm]) - - let of_executable ffn (cs, bs, exec) = - let unix_exec_is, unix_dll_opt = - OASISExecutable.unix_exec_is - (cs, bs, exec) - (fun () -> - bool_of_string - (is_native ())) - ext_dll - ext_program - in - let evs = - (BExec, cs.cs_name, [[ffn unix_exec_is]]) - :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) - in - evs, - unix_exec_is, - unix_dll_opt - - let of_library ffn (cs, bs, lib) = - let unix_lst = - OASISLibrary.generated_unix_files - ~ctxt:!BaseContext.default - (cs, bs, lib) - (fun fn -> - Sys.file_exists (BaseFilePath.of_unix fn)) - (fun () -> - bool_of_string (is_native ())) - ext_lib - ext_dll - in - let evs = - [BLib, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - -end - -module BaseCustom = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseCustom.ml" - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - let run cmd args extra_args = - BaseExec.run - (var_expand cmd) - (List.map - var_expand - (args @ (Array.to_list extra_args))) - - let hook ?(failsafe=false) cstm f e = - let optional_command lst = - let printer = - function - | Some (cmd, args) -> String.concat " " (cmd :: args) - | None -> s_ "No command" - in - match - var_choose - ~name:(s_ "Pre/Post Command") - ~printer - lst with - | Some (cmd, args) -> - begin - try - run cmd args [||] - with e when failsafe -> - warning - (f_ "Command '%s' fail with error: %s") - (String.concat " " (cmd :: args)) - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - end - | None -> - () - in - let res = - optional_command cstm.pre_command; - f e - in - optional_command cstm.post_command; - res -end - -module BaseDynVar = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseDynVar.ml" - - - open OASISTypes - open OASISGettext - open BaseEnv - open BaseBuilt - - let init pkg = - List.iter - (function - | Executable (cs, bs, exec) -> - var_ignore - (var_redefine - (* We don't save this variable *) - ~dump:false - ~short_desc:(fun () -> - Printf.sprintf - (f_ "Filename of executable '%s'") - cs.cs_name) - cs.cs_name - (lazy - (let fn_opt = - fold - BExec cs.cs_name - (fun _ fn -> Some fn) - None - in - match fn_opt with - | Some fn -> fn - | None -> - raise - (PropList.Not_set - (cs.cs_name, - Some (Printf.sprintf - (f_ "Executable '%s' not yet built.") - cs.cs_name)))))) - - | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> - ()) - pkg.sections -end - -module BaseTest = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseTest.ml" - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISExpr - open OASISGettext - - let test lst pkg extra_args = - - let one_test (failure, n) (test_plugin, cs, test) = - if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then - begin - let () = - info (f_ "Running test '%s'") cs.cs_name - in - let back_cwd = - match test.test_working_directory with - | Some dir -> - let cwd = - Sys.getcwd () - in - let chdir d = - info (f_ "Changing directory to '%s'") d; - Sys.chdir d - in - chdir dir; - fun () -> chdir cwd - - | None -> - fun () -> () - in - try - let failure_percent = - BaseCustom.hook - test.test_custom - (test_plugin pkg (cs, test)) - extra_args - in - back_cwd (); - (failure_percent +. failure, n + 1) - with e -> - begin - back_cwd (); - raise e - end - end - else - begin - info (f_ "Skipping test '%s'") cs.cs_name; - (failure, n) - end - in - let (failed, n) = - List.fold_left - one_test - (0.0, 0) - lst - in - let failure_percent = - if n = 0 then - 0.0 - else - failed /. (float_of_int n) - in - let msg = - Printf.sprintf - (f_ "Tests had a %.2f%% failure rate") - (100. *. failure_percent) - in - if failure_percent > 0.0 then - failwith msg - else - info "%s" msg -end - -module BaseDoc = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseDoc.ml" - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - let doc lst pkg extra_args = - - let one_doc (doc_plugin, cs, doc) = - if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then - begin - info (f_ "Building documentation '%s'") cs.cs_name; - BaseCustom.hook - doc.doc_custom - (doc_plugin pkg (cs, doc)) - extra_args - end - in - List.iter - one_doc - lst -end - -module BaseSetup = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseSetup.ml" - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISSection - open OASISGettext - open OASISUtils - - type std_args_fun = - package -> string array -> unit - - type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) - - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - version: string; - } - - (* Associate a plugin function with data from package *) - let join_plugin_sections filter_map lst = - List.rev - (List.fold_left - (fun acc sct -> - match filter_map sct with - | Some e -> - e :: acc - | None -> - acc) - [] - lst) - - (* Search for plugin data associated with a section name *) - let lookup_plugin_section plugin action nm lst = - try - List.assoc nm lst - with Not_found -> - failwithf3 - (f_ "Cannot find plugin %s matching section %s for %s action") - plugin - nm - action - - let configure t args = - (* Run configure *) - BaseCustom.hook - t.package.conf_custom - (t.configure t.package) - args; - - (* Reload environment *) - unload (); - load (); - - (* Replace data in file *) - BaseFileAB.replace t.package.files_ab - - let build t args = - BaseCustom.hook - t.package.build_custom - (t.build t.package) - args - - let doc t args = - BaseDoc.doc - (join_plugin_sections - (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - let test t args = - BaseTest.test - (join_plugin_sections - (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - let all t args = - let rno_doc = - ref false - in - let rno_test = - ref false - in - Arg.parse_argv - ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: - (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; - - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; - ] - (failwithf1 (f_ "Don't know what to do with '%s'")) - ""; - - info "Running configure step"; - configure t [||]; - - info "Running build step"; - build t [||]; - - (* Load setup.log dynamic variables *) - BaseDynVar.init t.package; - - if not !rno_doc then - begin - info "Running doc step"; - doc t [||]; - end - else - begin - info "Skipping doc step" - end; - - if not !rno_test then - begin - info "Running test step"; - test t [||] - end - else - begin - info "Skipping test step" - end - - let install t args = - BaseCustom.hook - t.package.install_custom - (t.install t.package) - args - - let uninstall t args = - BaseCustom.hook - t.package.uninstall_custom - (t.uninstall t.package) - args - - let reinstall t args = - uninstall t args; - install t args - - let clean, distclean = - let failsafe f a = - try - f a - with e -> - warning - (f_ "Action fail with error: %s") - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - in - - let generic_clean t cstm mains docs tests args = - BaseCustom.hook - ~failsafe:true - cstm - (fun () -> - (* Clean section *) - List.iter - (function - | Test (cs, test) -> - let f = - try - List.assoc cs.cs_name tests - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, test)) - args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, doc)) - args - | Library _ - | Executable _ - | Flag _ - | SrcRepo _ -> - ()) - t.package.sections; - (* Clean whole package *) - List.iter - (fun f -> - failsafe - (f t.package) - args) - mains) - () - in - - let clean t args = - generic_clean - t - t.package.clean_custom - t.clean - t.clean_doc - t.clean_test - args - in - - let distclean t args = - (* Call clean *) - clean t args; - - (* Remove generated file *) - List.iter - (fun fn -> - if Sys.file_exists fn then - begin - info (f_ "Remove '%s'") fn; - Sys.remove fn - end) - (BaseEnv.default_filename - :: - BaseLog.default_filename - :: - (List.rev_map BaseFileAB.to_filename t.package.files_ab)); - - (* Call distclean code *) - generic_clean - t - t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test - args - in - - clean, distclean - - let version t _ = - print_endline t.version - - let setup t = - let catch_exn = - ref true - in - try - let act_ref = - ref (fun _ -> - failwithf2 - (f_ "No action defined, run '%s %s -help'") - Sys.executable_name - Sys.argv.(0)) - - in - let extra_args_ref = - ref [] - in - let allow_empty_env_ref = - ref false - in - let arg_handle ?(allow_empty_env=false) act = - Arg.Tuple - [ - Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - - Arg.Unit - (fun () -> - allow_empty_env_ref := allow_empty_env; - act_ref := act); - ] - in - - Arg.parse - (Arg.align - [ - "-configure", - arg_handle ~allow_empty_env:true configure, - s_ "[options*] Configure the whole build process."; - - "-build", - arg_handle build, - s_ "[options*] Build executables and libraries."; - - "-doc", - arg_handle doc, - s_ "[options*] Build documents."; - - "-test", - arg_handle test, - s_ "[options*] Run tests."; - - "-all", - arg_handle ~allow_empty_env:true all, - s_ "[options*] Run configure, build, doc and test targets."; - - "-install", - arg_handle install, - s_ "[options*] Install libraries, data, executables \ - and documents."; - - "-uninstall", - arg_handle uninstall, - s_ "[options*] Uninstall libraries, data, executables \ - and documents."; - - "-reinstall", - arg_handle reinstall, - s_ "[options*] Uninstall and install libraries, data, \ - executables and documents."; - - "-clean", - arg_handle ~allow_empty_env:true clean, - s_ "[options*] Clean files generated by a build."; - - "-distclean", - arg_handle ~allow_empty_env:true distclean, - s_ "[options*] Clean files generated by a build and configure."; - - "-version", - arg_handle ~allow_empty_env:true version, - s_ " Display version of OASIS used to generate this setup.ml."; - - "-no-catch-exn", - Arg.Clear catch_exn, - s_ " Don't catch exception, useful for debugging."; - ] - @ (BaseContext.args ())) - (failwithf1 (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n"); - - (* Build initial environment *) - load ~allow_empty:!allow_empty_env_ref (); - - (** Initialize flags *) - List.iter - (function - | Flag (cs, {flag_description = hlp; - flag_default = choices}) -> - begin - let apply ?short_desc () = - var_ignore - (var_define - ~cli:CLIEnable - ?short_desc - (OASISUtils.varname_of_string cs.cs_name) - (lazy (string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices)))) - in - match hlp with - | Some hlp -> - apply ~short_desc:(fun () -> hlp) () - | None -> - apply () - end - | _ -> - ()) - t.package.sections; - - BaseStandardVar.init t.package; - - BaseDynVar.init t.package; - - !act_ref t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (string_of_exception e); - exit 1 - -end - -module BaseDev = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseDev.ml" - - - - open OASISGettext - open BaseMessage - - type t = - { - oasis_cmd: string; - } - - let update_and_run t = - (* Command line to run setup-dev *) - let oasis_args = - "setup-dev" :: "-run" :: - Sys.executable_name :: - (Array.to_list Sys.argv) - in - - let exit_on_child_error = - function - | 0 -> () - | 2 -> - (* Bad CLI arguments *) - error - (f_ "The command '%s %s' exit with code 2. It often means that we \ - don't use the right command-line arguments, rerun \ - 'oasis setup-dev'.") - t.oasis_cmd - (String.concat " " oasis_args) - - | 127 -> - (* Cannot find OASIS *) - error - (f_ "Cannot find executable '%s', check where 'oasis' is located \ - and rerun 'oasis setup-dev'") - t.oasis_cmd - - | i -> - exit i - in - - let () = - (* Run OASIS to generate a temporary setup.ml - *) - BaseExec.run - ~f_exit_code:exit_on_child_error - t.oasis_cmd - oasis_args - in - - () - -end - - -module InternalConfigurePlugin = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/internal/InternalConfigurePlugin.ml" - - (** Configure using internal scheme - @author Sylvain Le Gall - *) - - open BaseEnv - open OASISTypes - open OASISUtils - open OASISGettext - open BaseMessage - - (** Configure build using provided series of check to be done - * and then output corresponding file. - *) - let configure pkg argv = - let var_ignore_eval var = - let _s : string = - var () - in - () - in - - let errors = - ref SetString.empty - in - - let buff = - Buffer.create 13 - in - - let add_errors fmt = - Printf.kbprintf - (fun b -> - errors := SetString.add (Buffer.contents b) !errors; - Buffer.clear b) - buff - fmt - in - - let warn_exception e = - warning "%s" (string_of_exception e) - in - - (* Check tools *) - let check_tools lst = - List.iter - (function - | ExternalTool tool -> - begin - try - var_ignore_eval (BaseCheck.prog tool) - with e -> - warn_exception e; - add_errors (f_ "Cannot find external tool '%s'") tool - end - | InternalExecutable nm1 -> - (* Check that matching tool is built *) - List.iter - (function - | Executable ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal executable \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - lst - in - - let build_checks sct bs = - if var_choose bs.bs_build then - begin - if bs.bs_compiled_object = Native then - begin - try - var_ignore_eval BaseStandardVar.ocamlopt - with e -> - warn_exception e; - add_errors - (f_ "Section %s requires native compilation") - (OASISSection.string_of_section sct) - end; - - (* Check tools *) - check_tools bs.bs_build_tools; - - (* Check depends *) - List.iter - (function - | FindlibPackage (findlib_pkg, version_comparator) -> - begin - try - var_ignore_eval - (BaseCheck.package ?version_comparator findlib_pkg) - with e -> - warn_exception e; - match version_comparator with - | None -> - add_errors - (f_ "Cannot find findlib package %s") - findlib_pkg - | Some ver_cmp -> - add_errors - (f_ "Cannot find findlib package %s (%s)") - findlib_pkg - (OASISVersion.string_of_comparator ver_cmp) - end - | InternalLibrary nm1 -> - (* Check that matching library is built *) - List.iter - (function - | Library ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal library \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - bs.bs_build_depends - end - in - - (* Parse command line *) - BaseArgExt.parse argv (BaseEnv.args ()); - - (* OCaml version *) - begin - match pkg.ocaml_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp - BaseStandardVar.ocaml_version) - with e -> - warn_exception e; - add_errors - (f_ "OCaml version %s doesn't match version constraint %s") - (BaseStandardVar.ocaml_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* Findlib version *) - begin - match pkg.findlib_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp - BaseStandardVar.findlib_version) - with e -> - warn_exception e; - add_errors - (f_ "Findlib version %s doesn't match version constraint %s") - (BaseStandardVar.findlib_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* Check build depends *) - List.iter - (function - | Executable (_, bs, _) - | Library (_, bs, _) as sct -> - build_checks sct bs - | Doc (_, doc) -> - if var_choose doc.doc_build then - check_tools doc.doc_build_tools - | Test (_, test) -> - if var_choose test.test_run then - check_tools test.test_tools - | _ -> - ()) - pkg.sections; - - (* Save and print environment *) - if SetString.empty = !errors then - begin - dump (); - print () - end - else - begin - List.iter - (fun e -> error "%s" e) - (SetString.elements !errors); - failwithf1 - (fn_ - "%d configuration error" - "%d configuration errors" - (SetString.cardinal !errors)) - (SetString.cardinal !errors) - end - -end - -module InternalInstallPlugin = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/internal/InternalInstallPlugin.ml" - - (** Install using internal scheme - @author Sylvain Le Gall - *) - - open BaseEnv - open BaseStandardVar - open BaseMessage - open OASISTypes - open OASISLibrary - open OASISGettext - open OASISUtils - - let exec_hook = - ref (fun (cs, bs, exec) -> cs, bs, exec) - - let lib_hook = - ref (fun (cs, bs, lib) -> cs, bs, lib, []) - - let doc_hook = - ref (fun (cs, doc) -> cs, doc) - - let install_file_ev = - "install-file" - - let install_dir_ev = - "install-dir" - - let install_findlib_ev = - "install-findlib" - - let install pkg argv = - - let in_destdir = - try - let destdir = - destdir () - in - (* Practically speaking destdir is prepended - * at the beginning of the target filename - *) - fun fn -> destdir^fn - with PropList.Not_set _ -> - fun fn -> fn - in - - let install_file src_file envdir = - let tgt_dir = - in_destdir (envdir ()) - in - let tgt_file = - Filename.concat - tgt_dir - (Filename.basename src_file) - in - (* Create target directory if needed *) - BaseFileUtil.mkdir_parent - (fun dn -> - info (f_ "Creating directory '%s'") dn; - BaseLog.register install_dir_ev dn) - tgt_dir; - - (* Really install files *) - info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - BaseFileUtil.cp src_file tgt_file; - BaseLog.register install_file_ev tgt_file - in - - (* Install data into defined directory *) - let install_data srcdir lst tgtdir = - let tgtdir = - BaseFilePath.of_unix (var_expand tgtdir) - in - List.iter - (fun (src, tgt_opt) -> - let real_srcs = - BaseFileUtil.glob - (Filename.concat srcdir src) - in - if real_srcs = [] then - failwithf1 - (f_ "Wildcard '%s' doesn't match any files") - src; - List.iter - (fun fn -> - install_file - fn - (fun () -> - match tgt_opt with - | Some s -> - BaseFilePath.of_unix (var_expand s) - | None -> - tgtdir)) - real_srcs) - lst - in - - (** Install all libraries *) - let install_libs pkg = - - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, lib_extra = - !lib_hook data_lib - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then - begin - let acc = - (* Start with acc + lib_extra *) - List.rev_append lib_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - BaseFilePath.of_unix bs.bs_path - in - List.fold_left - (fun acc modul -> - try - List.find - Sys.file_exists - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - OASISUnixPath.uncapitalize_file modul^".mli"; - OASISUnixPath.capitalize_file modul^".mli"; - OASISUnixPath.uncapitalize_file modul^".ml"; - OASISUnixPath.capitalize_file modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - acc - end) - acc - lib.lib_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the library *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - in - - (* Install one group of library *) - let install_group_lib grp = - (* Iterate through all group nodes *) - let rec install_group_lib_aux data_and_files grp = - let data_and_files, children = - match grp with - | Container (_, children) -> - data_and_files, children - | Package (_, cs, bs, lib, children) -> - files_of_library data_and_files (cs, bs, lib), children - in - List.fold_left - install_group_lib_aux - data_and_files - children - in - - (* Findlib name of the root library *) - let findlib_name = - findlib_of_group grp - in - - (* Determine root library *) - let root_lib = - root_of_group grp - in - - (* All files to install for this library *) - let f_data, files = - install_group_lib_aux (ignore, []) grp - in - - (* Really install, if there is something to install *) - if files = [] then - begin - warning - (f_ "Nothing to install for findlib library '%s'") - findlib_name - end - else - begin - let meta = - (* Search META file *) - let (_, bs, _) = - root_lib - in - let res = - Filename.concat bs.bs_path "META" - in - if not (Sys.file_exists res) then - failwithf2 - (f_ "Cannot find file '%s' for findlib library %s") - res - findlib_name; - res - in - info - (f_ "Installing findlib library '%s'") - findlib_name; - BaseExec.run - (ocamlfind ()) - ("install" :: findlib_name :: meta :: files); - BaseLog.register install_findlib_ev findlib_name - end; - - (* Install data files *) - f_data (); - - in - - (* We install libraries in groups *) - List.iter - install_group_lib - (group_libs pkg) - in - - let install_execs pkg = - let install_exec data_exec = - let (cs, bs, exec) = - !exec_hook data_exec - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then - begin - let exec_libdir () = - Filename.concat - (libdir ()) - pkg.name - in - BaseBuilt.fold - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file - fn - bindir) - (); - BaseBuilt.fold - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> - install_file - fn - exec_libdir) - (); - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name) - end - in - List.iter - (function - | Executable (cs, bs, exec)-> - install_exec (cs, bs, exec) - | _ -> - ()) - pkg.sections - in - - let install_docs pkg = - let install_doc data = - let (cs, doc) = - !doc_hook data - in - if var_choose doc.doc_install && - BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then - begin - let tgt_dir = - BaseFilePath.of_unix (var_expand doc.doc_install_dir) - in - BaseBuilt.fold - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> - install_file - fn - (fun () -> tgt_dir)) - (); - install_data - Filename.current_dir_name - doc.doc_data_files - doc.doc_install_dir - end - in - List.iter - (function - | Doc (cs, doc) -> - install_doc (cs, doc) - | _ -> - ()) - pkg.sections - in - - install_libs pkg; - install_execs pkg; - install_docs pkg - - (* Uninstall already installed data *) - let uninstall _ argv = - List.iter - (fun (ev, data) -> - if ev = install_file_ev then - begin - if Sys.file_exists data then - begin - info - (f_ "Removing file '%s'") - data; - Sys.remove data - end - else - begin - warning - (f_ "File '%s' doesn't exist anymore") - data - end - end - else if ev = install_dir_ev then - begin - if Sys.file_exists data && Sys.is_directory data then - begin - if Sys.readdir data = [||] then - begin - info - (f_ "Removing directory '%s'") - data; - BaseFileUtil.rmdir data - end - else - begin - warning - (f_ "Directory '%s' is not empty (%s)") - data - (String.concat - ", " - (Array.to_list - (Sys.readdir data))) - end - end - else - begin - warning - (f_ "Directory '%s' doesn't exist anymore") - data - end - end - else if ev = install_findlib_ev then - begin - info (f_ "Removing findlib library '%s'") data; - BaseExec.run (ocamlfind ()) ["remove"; data] - end - else - failwithf1 (f_ "Unknown log event '%s'") ev; - BaseLog.unregister ev data) - (* We process event in reverse order *) - (List.rev - (BaseLog.filter - [install_file_ev; - install_dir_ev; - install_findlib_ev;])) - -end - - -module OCamlbuildCommon = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/OCamlbuildCommon.ml" - - (** Functions common to OCamlbuild build and doc plugin - *) - - open OASISGettext - open BaseEnv - open BaseStandardVar - - let ocamlbuild_clean_ev = - "ocamlbuild-clean" - - let ocamlbuildflags = - var_define - ~short_desc:(fun () -> "OCamlbuild additional flags") - "ocamlbuildflags" - (lazy "") - - (** Fix special arguments depending on environment *) - let fix_args args extra_argv = - List.flatten - [ - if (os_type ()) = "Win32" then - [ - "-classic-display"; - "-no-log"; - "-no-links"; - "-install-lib-dir"; - (Filename.concat (standard_library ()) "ocamlbuild") - ] - else - []; - - if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then - [ - "-byte-plugin" - ] - else - []; - args; - - if bool_of_string (debug ()) then - ["-tag"; "debug"] - else - []; - - if bool_of_string (profile ()) then - ["-tag"; "profile"] - else - []; - - OASISUtils.split ' ' (ocamlbuildflags ()); - - Array.to_list extra_argv; - ] - - (** Run 'ocamlbuild -clean' if not already done *) - let run_clean extra_argv = - let extra_cli = - String.concat " " (Array.to_list extra_argv) - in - (* Run if never called with these args *) - if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then - begin - BaseExec.run (ocamlbuild ()) (fix_args ["-clean"] extra_argv); - BaseLog.register ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ocamlbuild_clean_ev extra_cli - with _ -> - ()) - end - - (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild args extra_argv = - (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - BaseExec.run (ocamlbuild ()) (fix_args args extra_argv); - (* Remove any clean event, we must run it again *) - List.iter - (fun (e, d) -> BaseLog.unregister e d) - (BaseLog.filter [ocamlbuild_clean_ev]) - - (** Determine real build directory *) - let build_dir extra_argv = - let rec search_args dir = - function - | "-build-dir" :: dir :: tl -> - search_args dir tl - | _ :: tl -> - search_args dir tl - | [] -> - dir - in - search_args "_build" (fix_args [] extra_argv) - -end - -module OCamlbuildPlugin = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" - - (** Build using ocamlbuild - @author Sylvain Le Gall - *) - - open OASISTypes - open OASISGettext - open OASISUtils - open BaseEnv - open OCamlbuildCommon - open BaseStandardVar - open BaseMessage - - type target = - | Std of string list - | StdRename of string * string - - let cond_targets_hook = - ref (fun lst -> lst) - - let build pkg argv = - - (* Return the filename in build directory *) - let in_build_dir fn = - Filename.concat - (build_dir argv) - fn - in - - (* Return the unix filename in host build directory *) - let in_build_dir_of_unix fn = - in_build_dir (BaseFilePath.of_unix fn) - in - - let cond_targets = - List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_library - in_build_dir_of_unix - (cs, bs, lib) - in - - let ends_with nd fn = - let nd_len = - String.length nd - in - (String.length fn >= nd_len) - && - (String.sub - fn - (String.length fn - nd_len) - nd_len) = nd - in - - let tgts = - List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ".cma" fn || - ends_with ".cmxa" fn || - ends_with ".cmxs" fn || - ends_with (ext_lib ()) fn || - ends_with (ext_dll ()) fn)) - unix_files) - in - - match tgts with - | hd :: tl -> - (evs, Std hd) - :: - (List.map (fun tgts -> [], Std tgts) tl) - @ - acc - | [] -> - failwithf2 - (f_ "No possible ocamlbuild targets \ - in generated files %s for library %s") - (String.concat (s_ ", " ) (List.map (String.concat (s_ ", ")) tgts)) - cs.cs_name - end - - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, unix_exec_is, unix_dll_opt = - BaseBuilt.of_executable - in_build_dir_of_unix - (cs, bs, exec) - in - - let host_exec_is = - in_build_dir_of_unix unix_exec_is - in - - let target ext = - let unix_tgt = - (BaseFilePath.Unix.concat - bs.bs_path - (BaseFilePath.Unix.chop_extension - exec.exec_main_is))^ext - in - - evs, - (if unix_tgt = unix_exec_is then - Std [unix_tgt] - else - StdRename (unix_tgt, host_exec_is)) - in - - (* Add executable *) - let acc = - match bs.bs_compiled_object with - | Native -> - (target ".native") :: acc - | Best when bool_of_string (is_native ()) -> - (target ".native") :: acc - | Byte - | Best -> - (target ".byte") :: acc - in - acc - end - - | Library _ | Executable _ | Test _ - | SrcRepo _ | Flag _ | Doc _ -> - acc) - [] - (* Keep the pkg.sections ordered *) - (List.rev pkg.sections); - in - - (* Check and register built files *) - let check_and_register (bt, bnm, lst) = - List.iter - (fun fns -> - if not (List.exists Sys.file_exists fns) then - failwithf1 - (f_ "No one of expected built files %s exists") - (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) - lst; - (BaseBuilt.register bt bnm lst) - in - - (* Run a list of target + post process *) - let run_ocamlbuild rtargets = - run_ocamlbuild - (List.rev_map snd rtargets) - argv; - List.iter - check_and_register - (List.flatten (List.rev_map fst rtargets)) - in - - (* Compare two files, return true if they differ *) - let diff fn1 fn2 = - if Sys.file_exists fn1 && Sys.file_exists fn2 then - begin - let chn1 = open_in fn1 in - let chn2 = open_in fn2 in - let res = - if in_channel_length chn1 = in_channel_length chn2 then - begin - let len = - 4096 - in - let str1 = - String.make len '\000' - in - let str2 = - String.copy str1 - in - try - while (String.compare str1 str2) = 0 do - really_input chn1 str1 0 len; - really_input chn2 str2 0 len - done; - true - with End_of_file -> - false - end - else - true - in - close_in chn1; close_in chn2; - res - end - else - true - in - - let last_rtargets = - List.fold_left - (fun acc (built, tgt) -> - match tgt with - | Std nms -> - (built, List.hd nms) :: acc - | StdRename (src, tgt) -> - begin - (* We run with a fake list for event registering *) - run_ocamlbuild (([], src) :: acc); - - (* And then copy and register *) - begin - let src_fn = - in_build_dir_of_unix src - in - if diff src_fn tgt then - BaseFileUtil.cp src_fn tgt - else - info - (f_ "No need to copy file '%s' to '%s', same content") - src_fn tgt - end; - List.iter check_and_register built; - [] - end) - [] - (!cond_targets_hook cond_targets) - in - if last_rtargets <> [] then - run_ocamlbuild last_rtargets - - let clean pkg extra_args = - run_clean extra_args; - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - -end - -module OCamlbuildDocPlugin = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" - - (* Create documentation using ocamlbuild .odocl files - @author Sylvain Le Gall - *) - - open OASISTypes - open OASISGettext - open OASISMessage - open OCamlbuildCommon - open BaseStandardVar - - - - let doc_build path pkg (cs, doc) argv = - let index_html = - BaseFilePath.Unix.make - [ - path; - cs.cs_name^".docdir"; - "index.html"; - ] - in - let tgt_dir = - BaseFilePath.make - [ - build_dir argv; - BaseFilePath.of_unix path; - cs.cs_name^".docdir"; - ] - in - run_ocamlbuild [index_html] argv; - List.iter - (fun glb -> - BaseBuilt.register - BaseBuilt.BDoc - cs.cs_name - [BaseFileUtil.glob - (Filename.concat tgt_dir glb)]) - ["*.html"; "*.css"] - - let doc_clean t pkg (cs, doc) argv = - run_clean argv; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - -end - - -module CustomPlugin = struct -# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/custom/CustomPlugin.ml" - - (** Generate custom configure/build/doc/test/install system - @author - *) - - open BaseEnv - open OASISGettext - open OASISTypes - - - - type t = - { - cmd_main: command_line conditional; - cmd_clean: (command_line option) conditional; - cmd_distclean: (command_line option) conditional; - } - - let run = BaseCustom.run - - let main t _ extra_args = - let cmd, args = - var_choose - ~name:(s_ "main command") - t.cmd_main - in - run cmd args extra_args - - let clean t pkg extra_args = - match var_choose t.cmd_clean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - let distclean t pkg extra_args = - match var_choose t.cmd_distclean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - module Build = - struct - let main t pkg extra_args = - main t pkg extra_args; - List.iter - (fun sct -> - let evs = - match sct with - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, _ = - BaseBuilt.of_library - BaseFilePath.of_unix - (cs, bs, lib) - in - evs - end - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable - BaseFilePath.of_unix - (cs, bs, exec) - in - evs - end - | _ -> - [] - in - List.iter - (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) - evs) - pkg.sections - - let clean t pkg extra_args = - clean t pkg extra_args; - (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild - * considering moving this to BaseSetup? - *) - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - let distclean t pkg extra_args = - distclean t pkg extra_args - end - - module Test = - struct - let main t pkg (cs, test) extra_args = - try - main t pkg extra_args; - 0.0 - with Failure s -> - BaseMessage.warning - (f_ "Test '%s' fails: %s") - cs.cs_name - s; - 1.0 - - let clean t pkg (cs, test) extra_args = - clean t pkg extra_args - - let distclean t pkg (cs, test) extra_args = - distclean t pkg extra_args - end - - module Doc = - struct - let main t pkg (cs, _) extra_args = - main t pkg extra_args; - BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] - - let clean t pkg (cs, _) extra_args = - clean t pkg extra_args; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - - let distclean t pkg (cs, _) extra_args = - distclean t pkg extra_args - end - -end - - -open OASISTypes;; - -let setup_t = - { - BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build; - test = - [ - ("unix", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test_unix", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); - ("react", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test_react", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); - ("core", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test_core", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - doc = - [ - ("lwt-api", OCamlbuildDocPlugin.doc_build "./"); - ("lwt-manual", - CustomPlugin.Doc.main - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("make", ["-C"; "manual"; "manual.pdf"])) - ]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - install = InternalInstallPlugin.install; - uninstall = InternalInstallPlugin.uninstall; - clean = [OCamlbuildPlugin.clean]; - clean_test = - [ - ("unix", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test_unix", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); - ("react", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test_react", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); - ("core", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test_core", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - clean_doc = - [ - ("lwt-api", OCamlbuildDocPlugin.doc_clean "./"); - ("lwt-manual", - CustomPlugin.Doc.clean - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("make", ["-C"; "manual"; "manual.pdf"])) - ]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - distclean = []; - distclean_test = - [ - ("unix", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test_unix", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); - ("react", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test_react", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); - ("core", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("$test_core", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - distclean_doc = - [ - ("lwt-manual", - CustomPlugin.Doc.distclean - { - CustomPlugin.cmd_main = - [ - (OASISExpr.EBool true, - ("make", ["-C"; "manual"; "manual.pdf"])) - ]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) - ]; - package = - { - oasis_version = "0.1"; - ocaml_version = Some (OASISVersion.VGreaterEqual "3.12"); - findlib_version = None; - name = "lwt"; - version = "2.3.2"; - license = - OASISLicense.DEP5License - { - OASISLicense.license = "LGPL"; - exceptions = ["OCaml linking"]; - version = OASISLicense.Version "2.1"; - }; - license_file = Some "COPYING"; - copyrights = []; - maintainers = []; - authors = - [ - "J\195\169r\195\180me Vouillon"; - "Vincent Balat"; - "Nataliya Guts"; - "Pierre Clairambault"; - "St\195\169phane Glondu"; - "J\195\169r\195\169mie Dimino"; - "Warren Harris"; - "Pierre Chambart"; - "Mauricio Fernandez" - ]; - homepage = Some "http://ocsigen.org/lwt/"; - synopsis = "Lightweight thread library for Objective Caml"; - description = - Some - "Lwt is a library of cooperative threads implemented in monadic\nstyle. With respect to preemptive threads, cooperative threads are\nnot using a scheduler to distribute processor time between\nthreads. Instead of this, each thread must tell the others that he\nwants to let them work."; - categories = []; - conf_type = (`Configure, "internal", Some "0.2"); - conf_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = - [ - (OASISExpr.EBool true, - Some - (("ocaml", - [ - "discover.ml"; - "-ocamlc"; - "$ocamlc"; - "-ext-obj"; - "$ext_obj"; - "-exec-name"; - "$default_executable_name"; - "-use-libev"; - "$libev"; - "-os-type"; - "$os_type" - ]))) - ]; - }; - build_type = (`Build, "ocamlbuild", Some "0.2"); - build_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - install_type = (`Install, "internal", Some "0.2"); - install_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - uninstall_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - clean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - distclean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = - [ - (OASISExpr.EBool true, - Some - (("$rm", - ["src/unix/lwt_config.h"; "src/unix/lwt_config.ml" - ]))) - ]; - }; - files_ab = []; - sections = - [ - Library - ({ - cs_name = "lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/core"; - bs_compiled_object = Best; - bs_build_depends = []; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = - [ - "Lwt_condition"; - "Lwt_list"; - "Lwt"; - "Lwt_mutex"; - "Lwt_mvar"; - "Lwt_pool"; - "Lwt_sequence"; - "Lwt_stream"; - "Lwt_switch"; - "Lwt_util"; - "Lwt_pqueue" - ]; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_containers = []; - }); - Library - ({ - cs_name = "lwt-unix"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), - true) - ]; - bs_path = "src/unix"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "lwt"; - FindlibPackage ("unix", None); - FindlibPackage ("bigarray", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = - [ - "lwt_config.h"; - "lwt_unix.h"; - "lwt_unix_stubs.c"; - "lwt_libev_stubs.c" - ]; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = - [ - (OASISExpr.EBool true, []); - (OASISExpr.EFlag "libev", ["-lev"]); - (OASISExpr.ENot - (OASISExpr.ETest ("os_type", "Win32")), - ["-lpthread"]); - (OASISExpr.EAnd - (OASISExpr.ENot - (OASISExpr.ETest ("os_type", "Win32")), - OASISExpr.EFlag "libev"), - ["-lpthread"; "-lev"]); - (OASISExpr.ETest ("os_type", "Win32"), - ["ws2_32.lib"]); - (OASISExpr.EAnd - (OASISExpr.ETest ("os_type", "Win32"), - OASISExpr.EFlag "libev"), - ["ws2_32.lib"; "-lev"]); - (OASISExpr.EAnd - (OASISExpr.ETest ("os_type", "Win32"), - OASISExpr.ENot - (OASISExpr.ETest ("os_type", "Win32"))), - ["ws2_32.lib"; "-lpthread"]); - (OASISExpr.EAnd - (OASISExpr.EAnd - (OASISExpr.ETest ("os_type", "Win32"), - OASISExpr.ENot - (OASISExpr.ETest ("os_type", "Win32"))), - OASISExpr.EFlag "libev"), - ["ws2_32.lib"; "-lpthread"; "-lev"]) - ]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = - [ - "Lwt_chan"; - "Lwt_daemon"; - "Lwt_gc"; - "Lwt_io"; - "Lwt_log"; - "Lwt_main"; - "Lwt_process"; - "Lwt_throttle"; - "Lwt_timeout"; - "Lwt_unix"; - "Lwt_sys"; - "Lwt_engine"; - "Lwt_bytes" - ]; - lib_internal_modules = ["Lwt_log_rules"]; - lib_findlib_parent = Some "lwt"; - lib_findlib_name = Some "unix"; - lib_findlib_containers = []; - }); - Library - ({ - cs_name = "lwt-react"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "react", - OASISExpr.EFlag "all"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "react", - OASISExpr.EFlag "all"), - true) - ]; - bs_path = "src/react"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "lwt"; - FindlibPackage ("react", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Lwt_event"; "Lwt_signal"; "Lwt_react"]; - lib_internal_modules = []; - lib_findlib_parent = Some "lwt"; - lib_findlib_name = Some "react"; - lib_findlib_containers = []; - }); - Library - ({ - cs_name = "test"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests"; - bs_compiled_object = Best; - bs_build_depends = []; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Test"]; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_containers = []; - }); - Library - ({ - cs_name = "lwt-text"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "text", OASISExpr.EFlag "all"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "text", OASISExpr.EFlag "all"), - true) - ]; - bs_path = "src/text"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "lwt"; - InternalLibrary "lwt-unix"; - InternalLibrary "lwt-react"; - FindlibPackage ("text", None); - FindlibPackage ("text.bigarray", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = ["lwt_text_stubs.c"]; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Lwt_text"; "Lwt_term"; "Lwt_read_line"]; - lib_internal_modules = []; - lib_findlib_parent = Some "lwt"; - lib_findlib_name = Some "text"; - lib_findlib_containers = []; - }); - Executable - ({ - cs_name = "test_unix"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/unix"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "test"; - InternalLibrary "lwt"; - FindlibPackage ("unix", None); - InternalLibrary "lwt-unix" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = false; exec_main_is = "main.ml"; }); - Library - ({ - cs_name = "lwt-syntax"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "syntax"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("camlp4.lib", None); - FindlibPackage ("camlp4.quotations.o", None); - FindlibPackage ("camlp4.extend", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Pa_lwt"]; - lib_internal_modules = []; - lib_findlib_parent = Some "lwt"; - lib_findlib_name = Some "syntax"; - lib_findlib_containers = []; - }); - Executable - ({ - cs_name = "test_react"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EAnd - (OASISExpr.EFlag "unix", - OASISExpr.EFlag "react"), - OASISExpr.EFlag "all"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/react"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "test"; - InternalLibrary "lwt"; - FindlibPackage ("unix", None); - InternalLibrary "lwt-unix"; - FindlibPackage ("react", None); - InternalLibrary "lwt-react" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = false; exec_main_is = "main.ml"; }); - Executable - ({ - cs_name = "test_core"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/core"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "test"; - InternalLibrary "lwt"; - FindlibPackage ("unix", None); - InternalLibrary "lwt-unix" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = false; exec_main_is = "main.ml"; }); - Library - ({ - cs_name = "lwt-top"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "text", OASISExpr.EFlag "all"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "text", OASISExpr.EFlag "all"), - true) - ]; - bs_path = "src/top"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "lwt"; - InternalLibrary "lwt-text"; - FindlibPackage ("findlib", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Lwt_top"]; - lib_internal_modules = ["Lwt_ocaml_completion"]; - lib_findlib_parent = Some "lwt"; - lib_findlib_name = Some "top"; - lib_findlib_containers = []; - }); - Library - ({ - cs_name = "lwt-preemptive"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "preemptive", - OASISExpr.EFlag "all"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "preemptive", - OASISExpr.EFlag "all"), - true) - ]; - bs_path = "src/preemptive"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "lwt"; - InternalLibrary "lwt-unix"; - FindlibPackage ("threads", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Lwt_preemptive"]; - lib_internal_modules = []; - lib_findlib_parent = Some "lwt"; - lib_findlib_name = Some "preemptive"; - lib_findlib_containers = []; - }); - Flag - ({ - cs_name = "extra"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "Asynchronous unix functions"; - flag_default = [(OASISExpr.EBool true, true)]; - }); - SrcRepo - ({ - cs_name = "head"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - src_repo_type = Darcs; - src_repo_location = "http://ocsigen.org/darcs/lwt"; - src_repo_browser = - Some "http://ocsigen.org/darcsweb/?r=lwt;a=summary"; - src_repo_module = None; - src_repo_branch = None; - src_repo_tag = None; - src_repo_subdir = None; - }); - Flag - ({ - cs_name = "preemptive"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "Preemptive threads support"; - flag_default = [(OASISExpr.EBool true, true)]; - }); - Library - ({ - cs_name = "lwt-simple-top"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), - true) - ]; - bs_path = "src/simple_top"; - bs_compiled_object = Best; - bs_build_depends = - [InternalLibrary "lwt"; InternalLibrary "lwt-unix"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = []; - lib_internal_modules = ["Lwt_simple_top"]; - lib_findlib_parent = Some "lwt"; - lib_findlib_name = Some "simple-top"; - lib_findlib_containers = []; - }); - Flag - ({ - cs_name = "glib"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "Glib integration"; - flag_default = [(OASISExpr.EBool true, false)]; - }); - Test - ({ - cs_name = "unix"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - test_type = (`Test, "custom", Some "0.2"); - test_command = - [(OASISExpr.EBool true, ("$test_unix", []))]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), - true) - ]; - test_tools = - [ - ExternalTool "ocamlbuild"; - InternalExecutable "test_unix" - ]; - }); - Flag - ({ - cs_name = "unix"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "Unix support"; - flag_default = [(OASISExpr.EBool true, true)]; - }); - Flag - ({ - cs_name = "text"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "Text mode utilities"; - flag_default = [(OASISExpr.EBool true, false)]; - }); - Doc - ({ - cs_name = "lwt-api"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.2"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - doc_build = [(OASISExpr.EBool true, true)]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$htmldir/api"; - doc_title = "API reference for Lwt"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = [("utils/style.css", None)]; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; - }); - Library - ({ - cs_name = "lwt-glib"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "glib", OASISExpr.EFlag "all"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "glib", OASISExpr.EFlag "all"), - true) - ]; - bs_path = "src/glib"; - bs_compiled_object = Best; - bs_build_depends = - [InternalLibrary "lwt"; InternalLibrary "lwt-unix"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = ["lwt_glib_stubs.c"]; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Lwt_glib"]; - lib_internal_modules = []; - lib_findlib_parent = Some "lwt"; - lib_findlib_name = Some "glib"; - lib_findlib_containers = []; - }); - Flag - ({ - cs_name = "all"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "build and install everything"; - flag_default = [(OASISExpr.EBool true, false)]; - }); - Executable - ({ - cs_name = "relay"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "unix", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "examples/unix"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "lwt-unix"; - InternalLibrary "lwt-syntax" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = false; exec_main_is = "relay.ml"; }); - Executable - ({ - cs_name = "logging"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "unix", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "examples/unix"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "lwt-unix"; - InternalLibrary "lwt-syntax" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = false; exec_main_is = "logging.ml"; }); - Test - ({ - cs_name = "react"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - test_type = (`Test, "custom", Some "0.2"); - test_command = - [(OASISExpr.EBool true, ("$test_react", []))]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EAnd - (OASISExpr.EFlag "unix", - OASISExpr.EFlag "react"), - OASISExpr.EFlag "all"), - true) - ]; - test_tools = - [ - ExternalTool "ocamlbuild"; - InternalExecutable "test_react" - ]; - }); - Library - ({ - cs_name = "lwt-syntax-log"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "syntax"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("camlp4.lib", None); - FindlibPackage ("camlp4.quotations.o", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Pa_lwt_log"]; - lib_internal_modules = []; - lib_findlib_parent = Some "lwt-syntax"; - lib_findlib_name = Some "log"; - lib_findlib_containers = []; - }); - Flag - ({ - cs_name = "react"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "React helpers"; - flag_default = [(OASISExpr.EBool true, false)]; - }); - Flag - ({ - cs_name = "ssl"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "SSL support"; - flag_default = [(OASISExpr.EBool true, false)]; - }); - Test - ({ - cs_name = "core"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - test_type = (`Test, "custom", Some "0.2"); - test_command = - [(OASISExpr.EBool true, ("$test_core", []))]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), - true) - ]; - test_tools = - [ - ExternalTool "ocamlbuild"; - InternalExecutable "test_core" - ]; - }); - Executable - ({ - cs_name = "lwt-toplevel"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "toplevel", - OASISExpr.EFlag "all"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "toplevel", - OASISExpr.EFlag "all"), - true) - ]; - bs_path = "src/top"; - bs_compiled_object = Byte; - bs_build_depends = - [ - InternalLibrary "lwt"; - InternalLibrary "lwt-top"; - InternalLibrary "lwt-text"; - InternalLibrary "lwt-react"; - FindlibPackage ("text", None); - FindlibPackage ("findlib", None); - FindlibPackage ("unix", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = false; exec_main_is = "lwt_toplevel.ml"; }); - Flag - ({ - cs_name = "toplevel"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "Enhanced toplevel"; - flag_default = [(OASISExpr.EBool true, false)]; - }); - Executable - ({ - cs_name = "parallelize"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "unix", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "examples/unix"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "lwt-unix"; - InternalLibrary "lwt-syntax" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = false; exec_main_is = "parallelize.ml"; }); - Library - ({ - cs_name = "lwt-extra"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "extra", - OASISExpr.EFlag "all"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "extra", - OASISExpr.EFlag "all"), - true) - ]; - bs_path = "src/extra"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "lwt"; - InternalLibrary "lwt-preemptive" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Lwt_lib"]; - lib_internal_modules = []; - lib_findlib_parent = Some "lwt"; - lib_findlib_name = Some "extra"; - lib_findlib_containers = []; - }); - Library - ({ - cs_name = "optcomp"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "syntax"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("camlp4.lib", None); - FindlibPackage ("camlp4.quotations.o", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Pa_optcomp"]; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_containers = []; - }); - Library - ({ - cs_name = "lwt-syntax-options"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "syntax"; - bs_compiled_object = Best; - bs_build_depends = - [FindlibPackage ("camlp4.lib", None)]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = []; - lib_internal_modules = ["Pa_lwt_options"]; - lib_findlib_parent = Some "lwt-syntax"; - lib_findlib_name = Some "options"; - lib_findlib_containers = []; - }); - Library - ({ - cs_name = "lwt-ssl"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "ssl", OASISExpr.EFlag "all"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EOr - (OASISExpr.EFlag "ssl", OASISExpr.EFlag "all"), - true) - ]; - bs_path = "src/ssl"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("ssl", None); - InternalLibrary "lwt-unix" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - { - lib_modules = ["Lwt_ssl"]; - lib_internal_modules = []; - lib_findlib_parent = Some "lwt"; - lib_findlib_name = Some "ssl"; - lib_findlib_containers = []; - }); - Doc - ({ - cs_name = "lwt-manual"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - doc_type = (`Doc, "custom", Some "0.2"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - doc_build = [(OASISExpr.EBool true, true)]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$pdfdir"; - doc_title = "Lwt user manual"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = [("manual/manual.pdf", None)]; - doc_build_tools = [ExternalTool "ocamlbuild"]; - }); - Flag - ({ - cs_name = "libev"; - cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, - { - flag_description = Some "Compile with libev support"; - flag_default = - [ - (OASISExpr.EBool true, false); - (OASISExpr.ENot - (OASISExpr.ETest ("os_type", "Win32")), - true) - ]; - }) - ]; - plugins = - [(`Extra, "DevFiles", Some "0.2"); (`Extra, "META", Some "0.2")]; - schema_data = PropList.Data.create (); - plugin_data = []; - }; - version = "0.2.0"; - };; - -let setup () = BaseSetup.setup setup_t;; - -(* OASIS_STOP *) - -let () = - InternalInstallPlugin.lib_hook := - fun (cs, bs, lib) -> - match lib.OASISTypes.lib_findlib_name with - | Some "unix" -> - (cs, bs, lib, ["src/unix/lwt_config.ml"; "src/unix/lwt_config.h"; "src/unix/lwt_unix.h"]) - | _ -> - (cs, bs, lib, []) -;; - -let () = setup ();; diff --git a/server/thirdparty/lwt-2.3.2/src/core/META b/server/thirdparty/lwt-2.3.2/src/core/META deleted file mode 100644 index fa397b8..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/META +++ /dev/null @@ -1,115 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 92360f3460ecb78dca24ff748f6650bd) -version = "2.3.2" -description = "Lightweight thread library for OCaml (core library)" -archive(byte) = "lwt.cma" -archive(native) = "lwt.cmxa" -exists_if = "lwt.cma" -package "ssl" ( - version = "2.3.2" - description = "SSL support for Lwt" - requires = "ssl lwt.unix" - archive(byte) = "lwt-ssl.cma" - archive(native) = "lwt-ssl.cmxa" - exists_if = "lwt-ssl.cma" -) - -package "extra" ( - version = "2.3.2" - description = "Unix functions for Lwt using Lwt_preemptive" - requires = "lwt lwt.preemptive" - archive(byte) = "lwt-extra.cma" - archive(native) = "lwt-extra.cmxa" - exists_if = "lwt-extra.cma" -) - -package "glib" ( - version = "2.3.2" - description = "Glib integration" - requires = "lwt lwt.unix" - archive(byte) = "lwt-glib.cma" - archive(native) = "lwt-glib.cmxa" - exists_if = "lwt-glib.cma" -) - -package "simple-top" ( - version = "2.3.2" - description = "Unix support for lwt" - requires = "lwt lwt.unix" - archive(byte) = "lwt-simple-top.cma" - archive(native) = "lwt-simple-top.cmxa" - exists_if = "lwt-simple-top.cma" -) - -package "preemptive" ( - version = "2.3.2" - description = "Preemptive threads support for Lwt" - requires = "lwt lwt.unix threads" - archive(byte) = "lwt-preemptive.cma" - archive(native) = "lwt-preemptive.cmxa" - exists_if = "lwt-preemptive.cma" -) - -package "top" ( - version = "2.3.2" - description = "Line-editing in the toplevel" - requires = "lwt lwt.text findlib" - archive(byte) = "lwt-top.cma" - archive(native) = "lwt-top.cmxa" - exists_if = "lwt-top.cma" -) - -package "syntax" ( - version = "2.3.2" - description = "Syntactic sugars for Lwt" - requires = "camlp4 lwt.syntax.options" - archive(syntax,preprocessor) = "lwt-syntax.cma" - archive(syntax,toploop) = "lwt-syntax.cma" - exists_if = "lwt-syntax.cma" - package "options" ( - version = "2.3.2" - description = "Options for syntax extensions" - requires = "camlp4" - archive(syntax,preprocessor) = "lwt-syntax-options.cma" - archive(syntax,toploop) = "lwt-syntax-options.cma" - exists_if = "lwt-syntax-options.cma" - ) - - package "log" ( - version = "2.3.2" - description = "Syntactic sugars for logging" - requires = "camlp4 lwt.syntax.options" - archive(syntax,preprocessor) = "lwt-syntax-log.cma" - archive(syntax,toploop) = "lwt-syntax-log.cma" - exists_if = "lwt-syntax-log.cma" - ) -) - -package "text" ( - version = "2.3.2" - description = "Text mode utilities" - requires = "lwt lwt.unix lwt.react text text.bigarray" - archive(byte) = "lwt-text.cma" - archive(native) = "lwt-text.cmxa" - exists_if = "lwt-text.cma" -) - -package "react" ( - version = "2.3.2" - description = "Reactive programming helpers" - requires = "lwt react" - archive(byte) = "lwt-react.cma" - archive(native) = "lwt-react.cmxa" - exists_if = "lwt-react.cma" -) - -package "unix" ( - version = "2.3.2" - description = "Unix support for lwt" - requires = "lwt unix bigarray" - archive(byte) = "lwt-unix.cma" - archive(native) = "lwt-unix.cmxa" - exists_if = "lwt-unix.cma" -) -# OASIS_STOP - diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt.ml deleted file mode 100644 index 926d817..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt.ml +++ /dev/null @@ -1,1060 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * 2009 Jrmie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(* +-----------------------------------------------------------------+ - | Types | - +-----------------------------------------------------------------+ *) - -exception Canceled - -module Int_map = Map.Make(struct type t = int let compare = compare end) - -type data = (unit -> unit) Int_map.t - (* Type of data carried by threads *) - -type +'a t -type -'a u - -type 'a thread_state = - | Return of 'a - (* [Return v] a terminated thread which has successfully - terminated with the value [v] *) - | Fail of exn - (* [Fail exn] a terminated thread which has failed with the - exception [exn] *) - | Sleep of 'a sleeper - (* [Sleep sleeper] is a sleeping thread *) - | Repr of 'a thread_repr - (* [Repr t] a thread which behaves the same as [t] *) - -and 'a thread_repr = { - mutable state : 'a thread_state; - (* The state of the thread *) -} - -and 'a sleeper = { - cancel : cancel ref; - (* The canceler for this thread *) - mutable waiters : 'a waiter_set; - (* All thunk functions *) - mutable removed : int; - (* Number of waiter that have been disabled. When this number - reaches [max_removed], they are effectively removed from - [waiters]. *) -} - -(* Type of set of waiters: *) -and 'a waiter_set = - | Empty - | Removable of ('a thread_state -> unit) option ref - | Immutable of ('a thread_state -> unit) - | Append of 'a waiter_set * 'a waiter_set - -and cancel = - | Cancel_func of (unit -> unit) - (* A cancel function. *) - | Cancel_repr of cancel ref - (* Behave has this canceler. *) - -external thread_repr : 'a t -> 'a thread_repr = "%identity" -external thread : 'a thread_repr -> 'a t = "%identity" -external wakener : 'a thread_repr -> 'a u = "%identity" -external wakener_repr : 'a u -> 'a thread_repr = "%identity" - -(* Maximum number of disabled waiters a waiter set can contains before - being cleaned: *) -let max_removed = 42 - -(* +-----------------------------------------------------------------+ - | Local storage | - +-----------------------------------------------------------------+ *) - -type 'a key = { - id : int; - mutable store : 'a option; -} - -let next_key_id = ref 0 - -let new_key () = - let id = !next_key_id in - next_key_id := id + 1; - { id = id; store = None } - -let current_data = ref Int_map.empty - -let get key = - try - Int_map.find key.id !current_data (); - let value = key.store in - key.store <- None; - value - with Not_found -> - None - -(* +-----------------------------------------------------------------+ - | Restarting/connecting threads | - +-----------------------------------------------------------------+ *) - -(* Returns the representative of a thread, updating non-direct references: *) -let rec repr_rec t = - match t.state with - | Repr t' -> let t'' = repr_rec t' in if t'' != t' then t.state <- Repr t''; t'' - | _ -> t -let repr t = repr_rec (thread_repr t) - -let rec run_waiters_rec state ws rem = - match ws, rem with - | Empty, [] -> - () - | Empty, ws :: rem -> - run_waiters_rec state ws rem - | Immutable f, [] -> - f state - | Immutable f, ws :: rem -> - f state; - run_waiters_rec state ws rem - | Removable{ contents = None }, [] -> - () - | Removable{ contents = None }, ws :: rem -> - run_waiters_rec state ws rem - | Removable{ contents = Some f }, [] -> - f state - | Removable{ contents = Some f }, ws :: rem -> - f state; - run_waiters_rec state ws rem - | Append(ws1, ws2), _ -> - run_waiters_rec state ws1 (ws2 :: rem) - -(* Run all waiters waiting on [t]: *) -let run_waiters waiters state = - let save = !current_data in - run_waiters_rec state waiters []; - current_data := save - -let wakeup t v = - let t = repr_rec (wakener_repr t) in - match t.state with - | Sleep{ waiters = waiters } -> - let state = Return v in - t.state <- state; - run_waiters waiters state - | Fail Canceled -> - (* Do not fail if the thread has been canceled: *) - () - | _ -> - invalid_arg "Lwt.wakeup" - -let wakeup_exn t e = - let t = repr_rec (wakener_repr t) in - match t.state with - | Sleep{ waiters = waiters } -> - let state = Fail e in - t.state <- state; - run_waiters waiters state - | Fail Canceled -> - () - | _ -> - invalid_arg "Lwt.wakeup_exn" - -(* Same as [wakeup] but do not raise [Invalid_argument]. *) -let ignore_wakeup t v = - let t = repr_rec (wakener_repr t) in - match t.state with - | Sleep{ waiters = waiters } -> - let state = Return v in - t.state <- state; - run_waiters waiters state - | _ -> - () - -(* Same as [wakeup_exn] but do not raise [Invalid_argument]. *) -let ignore_wakeup_exn t e = - let t = repr_rec (wakener_repr t) in - match t.state with - | Sleep{ waiters = waiters } -> - let state = Fail e in - t.state <- state; - run_waiters waiters state - | _ -> - () - -let wakeuping = ref false -let to_wakeup = Queue.create () - -let wakeup_all () = - while not (Queue.is_empty to_wakeup) do - Queue.pop to_wakeup () - done; - wakeuping := false - -let wakeup_later t v = - if !wakeuping then - Queue.push (fun () -> ignore_wakeup t v) to_wakeup - else begin - wakeuping := true; - ignore_wakeup t v; - wakeup_all () - end - -let wakeup_later_exn t v = - if !wakeuping then - Queue.push (fun () -> ignore_wakeup_exn t v) to_wakeup - else begin - wakeuping := true; - ignore_wakeup_exn t v; - wakeup_all () - end - -let restart_cancel t = - let t = repr_rec (wakener_repr t) in - match t.state with - | Sleep{ waiters = waiters } -> - let state = Fail Canceled in - t.state <- state; - run_waiters waiters state - | _ -> - () - -let cancel_none = Cancel_func ignore - -let rec get_cancel = function - | Cancel_func f -> f - | Cancel_repr r -> let c = !r in r := cancel_none; get_cancel c - -let cancel t = - match (repr t).state with - | Sleep{ cancel = cancel } -> - let f = get_cancel !cancel in - cancel := cancel_none; - let save = !current_data in - f (); - current_data := save - | _ -> - () - -let append l1 l2 = - match l1, l2 with - | Empty, _ -> l2 - | _, Empty -> l1 - | _ -> Append(l1, l2) - -(* Remove all disbaled waiters of a waiter set: *) -let rec cleanup = function - | Removable{ contents = None } -> - Empty - | Append(l1, l2) -> - append (cleanup l1) (cleanup l2) - | ws -> - ws - -(* Connects the two processes [t1] and [t2] when [t2] finishes up, - where [t1] must be a sleeping thread. - - Connecting means running all the waiters for [t2] and assigning the - state of [t1] to [t2]. -*) -let connect t1 t2 = - let t1 = repr t1 and t2 = repr t2 in - match t1.state with - | Sleep sleeper1 -> - if t1 == t2 then - (* Do nothing if the two threads already have the same - representation *) - () - else begin - match t2.state with - | Sleep sleeper2 -> - (* If [t2] is sleeping, then makes it behave as [t1]: *) - t2.state <- Repr t1; - (* Note that the order is important: the user have no - access to [t2] but may keep a reference to [t1]. If - we inverse the order, i.e. we do: - - [t1.state <- Repr t2] - - then we have a possible leak. For example: - - {[ - let rec loop ()== - lwt () = Lwt_unix.yield () in - loop () - - lwt () = - let t = loop () in - ... - ]} - - Here, after [n] iterations, [t] will contains: - - [ref(Repr(ref(Repr(ref(Repr ... ref Sleep)))))] - \-------------[n]--------------/ - *) - - (* However, since [t1] is a temporary thread created - for a thread that is now terminated, its cancel - function is meaningless. Only the one of [t2] is - now important: *) - sleeper1.cancel := Cancel_repr sleeper2.cancel; - - (* Merge the two sets of waiters: *) - let waiters = append sleeper1.waiters sleeper2.waiters - and removed = sleeper1.removed + sleeper2.removed in - if removed > max_removed then begin - (* Remove disabled threads *) - sleeper1.removed <- 0; - sleeper1.waiters <- cleanup waiters - end else begin - sleeper1.removed <- removed; - sleeper1.waiters <- waiters - end - | state2 -> - (* [t2] is already terminated, assing its state to [t1]: *) - t1.state <- state2; - (* and run all the waiters of [t1]: *) - run_waiters sleeper1.waiters state2 - end - | _ -> - (* [t1] is not asleep: *) - invalid_arg "Lwt.connect" - -(* Same as [connect] except that we know that [t2] has terminated: *) -let fast_connect t state = - let t = repr t in - match t.state with - | Sleep{ waiters = waiters } -> - t.state <- state; - run_waiters waiters state - | _ -> - invalid_arg "Lwt.fast_connect" - -(* +-----------------------------------------------------------------+ - | Threads conctruction and combining | - +-----------------------------------------------------------------+ *) - -let return v = - thread { state = Return v } - -let fail e = - thread { state = Fail e } - -let temp r = - thread { - state = Sleep{ cancel = r; - waiters = Empty; - removed = 0 } - } - -let wait () = - let t = { - state = Sleep{ cancel = ref cancel_none; - waiters = Empty; - removed = 0 }; - } in - (thread t, wakener t) - -let task () = - let rec t = { - state = Sleep{ cancel = ref (Cancel_func(fun () -> restart_cancel (wakener t))); - waiters = Empty; - removed = 0 }; - } in - (thread t, wakener t) - -let waiter_of_wakener wakener = thread (wakener_repr wakener) - -(* apply function, reifying explicit exceptions into the thread type - apply: ('a -(exn)-> 'b t) -> ('a -(n)-> 'b t) - semantically a natural transformation TE -> T, where T is the thread - monad, which is layered over exception monad E. -*) -let apply f x = try f x with e -> fail e - -let wrap f = try return (f ()) with exn -> fail exn - -let wrap1 f x1 = try return (f x1) with exn -> fail exn -let wrap2 f x1 x2 = try return (f x1 x2) with exn -> fail exn -let wrap3 f x1 x2 x3 = try return (f x1 x2 x3) with exn -> fail exn -let wrap4 f x1 x2 x3 x4 = try return (f x1 x2 x3 x4) with exn -> fail exn -let wrap5 f x1 x2 x3 x4 x5 = try return (f x1 x2 x3 x4 x5) with exn -> fail exn -let wrap6 f x1 x2 x3 x4 x5 x6 = try return (f x1 x2 x3 x4 x5 x6) with exn -> fail exn -let wrap7 f x1 x2 x3 x4 x5 x6 x7 = try return (f x1 x2 x3 x4 x5 x6 x7) with exn -> fail exn - -let add_immutable_waiter sleeper waiter = - sleeper.waiters <- (match sleeper.waiters with - | Empty -> Immutable waiter - | _ -> Append(Immutable waiter, sleeper.waiters)) - -let add_removable_waiter sleeper waiter = - sleeper.waiters <- (match sleeper.waiters with - | Empty -> Removable waiter - | _ -> Append(Removable waiter, sleeper.waiters)) - -let on_cancel t f = - match (repr t).state with - | Sleep sleeper -> - let data = !current_data in - add_immutable_waiter sleeper - (function - | Fail Canceled -> current_data := data; (try f () with _ -> ()) - | _ -> ()) - | Fail Canceled -> - f () - | _ -> - () - -let bind t f = - match (repr t).state with - | Return v -> - f v - | Fail exn -> - fail exn - | Sleep sleeper -> - let res = temp sleeper.cancel in - let data = !current_data in - add_immutable_waiter sleeper - (function - | Return v -> current_data := data; connect res (try f v with exn -> fail exn) - | Fail exn -> fast_connect res (Fail exn) - | _ -> assert false); - res - | Repr _ -> - assert false - -let on_success t f = - match (repr t).state with - | Return v -> - f v - | Fail exn -> - raise exn - | Sleep sleeper -> - let data = !current_data in - add_immutable_waiter sleeper - (function - | Return v -> current_data := data; f v - | Fail exn -> raise exn - | _ -> assert false) - | Repr _ -> - assert false - -let (>>=) t f = bind t f -let (=<<) f t = bind t f - -let map f t = - match (repr t).state with - | Return v -> - return (f v) - | Fail e -> - thread { state = Fail e } - | Sleep sleeper -> - let res = temp sleeper.cancel in - let data = !current_data in - add_immutable_waiter sleeper - (function - | Return v -> current_data := data; fast_connect res (try Return(f v) with exn -> Fail exn) - | Fail exn -> fast_connect res (Fail exn) - | _ -> assert false); - res - | Repr _ -> - assert false - -let (>|=) t f = map f t -let (=|<) f t = map f t - -let catch x f = - let t = try x () with exn -> fail exn in - match (repr t).state with - | Return _ -> - t - | Fail exn -> - f exn - | Sleep sleeper -> - let res = temp sleeper.cancel in - let data = !current_data in - add_immutable_waiter sleeper - (function - | Return _ as state -> fast_connect res state - | Fail exn -> current_data := data; connect res (try f exn with exn -> fail exn) - | _ -> assert false); - res - | Repr _ -> - assert false - -let on_failure t f = - match (repr t).state with - | Return v -> - () - | Fail exn -> - f exn - | Sleep sleeper -> - let data = !current_data in - add_immutable_waiter sleeper - (function - | Return v -> () - | Fail exn -> current_data := data; f exn - | _ -> assert false) - | Repr _ -> - assert false - -let on_termination t f = - match (repr t).state with - | Return v -> - f () - | Fail exn -> - f () - | Sleep sleeper -> - let data = !current_data in - add_immutable_waiter sleeper - (function - | Return v -> current_data := data; f () - | Fail exn -> current_data := data; f () - | _ -> assert false) - | Repr _ -> - assert false - -let try_bind x f g = - let t = try x () with exn -> fail exn in - match (repr t).state with - | Return v -> - f v - | Fail exn -> - g exn - | Sleep sleeper -> - let res = temp sleeper.cancel in - let data = !current_data in - add_immutable_waiter sleeper - (function - | Return v -> current_data := data; connect res (try f v with exn -> fail exn) - | Fail exn -> current_data := data; connect res (try g exn with exn -> fail exn) - | _ -> assert false); - res - | Repr _ -> - assert false - -let poll t = - match (repr t).state with - | Fail e -> raise e - | Return v -> Some v - | Sleep _ -> None - | Repr _ -> assert false - -let rec ignore_result t = - match (repr t).state with - | Return _ -> - () - | Fail e -> - raise e - | Sleep sleeper -> - add_immutable_waiter sleeper - (function - | Return _ -> () - | Fail exn -> raise exn - | _ -> assert false) - | Repr _ -> - assert false - -let protected t = - match (repr t).state with - | Sleep sleeper -> - let waiter, wakener = task () in - add_immutable_waiter sleeper - (fun state -> - try - match state with - | Return v -> wakeup wakener v - | Fail exn -> wakeup_exn wakener exn - | _ -> assert false - with Invalid_argument _ -> - ()); - waiter - | Return _ | Fail _ -> - t - | Repr _ -> - assert false - -let rec nth_ready l n = - match l with - | [] -> - assert false - | t :: l -> - match (repr t).state with - | Sleep _ -> - nth_ready l n - | _ when n > 0 -> - nth_ready l (n - 1) - | state -> - state - -let ready_count l = - List.fold_left (fun acc x -> match (repr x).state with Sleep _ -> acc | _ -> acc + 1) 0 l - -let remove_waiters l = - List.iter - (fun t -> - match (repr t).state with - | Sleep sleeper -> - let removed = sleeper.removed + 1 in - if removed > max_removed then begin - sleeper.removed <- 0; - sleeper.waiters <- cleanup sleeper.waiters - end else - sleeper.removed <- removed - | _ -> - ()) - l - -(* The PRNG state is initialized with a constant to make non-IO-based - programs deterministic. *) -let random_state = Random.State.make [||] - -let choose l = - let ready = ready_count l in - if ready > 0 then - if ready = 1 then - (* Optimisation for the common case: *) - thread { state = nth_ready l 0 } - else - thread { state = nth_ready l (Random.State.int random_state ready) } - else begin - let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) in - let waiter = ref None in - let handle_result state = - (* Disable the waiter now: *) - waiter := None; - (* Removes all waiters so we do not leak memory: *) - remove_waiters l; - (* This will not fail because it is called at most one time, - since all other waiters have been removed: *) - fast_connect res state - in - waiter := (Some handle_result); - List.iter - (fun t -> - match (repr t).state with - | Sleep sleeper -> - (* The data passed here will never be used because - [handle_result] only calls [fast_connect] which - calls [run_waiters] which ignore the current data *) - add_removable_waiter sleeper waiter; - | _ -> - assert false) - l; - res - end - -let rec nchoose_terminate res acc = function - | [] -> - fast_connect res (Return(List.rev acc)) - | t :: l -> - match (repr t).state with - | Return x -> - nchoose_terminate res (x :: acc) l - | Fail e -> - fast_connect res (Fail e) - | _ -> - nchoose_terminate res acc l - -let nchoose_sleep l = - let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) in - let rec waiter = ref (Some handle_result) - and handle_result state = - waiter := None; - remove_waiters l; - nchoose_terminate res [] l - in - List.iter - (fun t -> - match (repr t).state with - | Sleep sleeper -> - add_removable_waiter sleeper waiter; - | _ -> - assert false) - l; - res - -let nchoose l = - let rec init = function - | [] -> - nchoose_sleep l - | t :: l -> - match (repr t).state with - | Return x -> - collect [x] l - | Fail exn -> - fail exn - | _ -> - init l - and collect acc = function - | [] -> - return (List.rev acc) - | t :: l -> - match (repr t).state with - | Return x -> - collect (x :: acc) l - | Fail exn -> - fail exn - | _ -> - collect acc l - in - init l - -let rec nchoose_split_terminate res acc_terminated acc_sleeping = function - | [] -> - fast_connect res (Return(List.rev acc_terminated, List.rev acc_sleeping)) - | t :: l -> - match (repr t).state with - | Return x -> - nchoose_split_terminate res (x :: acc_terminated) acc_sleeping l - | Fail e -> - fast_connect res (Fail e) - | _ -> - nchoose_split_terminate res acc_terminated (t :: acc_sleeping) l - -let nchoose_split_sleep l = - let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) in - let rec waiter = ref (Some handle_result) - and handle_result state = - waiter := None; - remove_waiters l; - nchoose_split_terminate res [] [] l - in - List.iter - (fun t -> - match (repr t).state with - | Sleep sleeper -> - add_removable_waiter sleeper waiter; - | _ -> - assert false) - l; - res - -let nchoose_split l = - let rec init acc_sleeping = function - | [] -> - nchoose_split_sleep l - | t :: l -> - match (repr t).state with - | Return x -> - collect [x] acc_sleeping l - | Fail exn -> - fail exn - | _ -> - init (t :: acc_sleeping) l - and collect acc_terminated acc_sleeping = function - | [] -> - return (List.rev acc_terminated, acc_sleeping) - | t :: l -> - match (repr t).state with - | Return x -> - collect (x :: acc_terminated) acc_sleeping l - | Fail exn -> - fail exn - | _ -> - collect acc_terminated (t :: acc_sleeping) l - in - init [] l - -(* Return the nth ready thread, and cancel all others *) -let rec cancel_and_nth_ready l n = - match l with - | [] -> - assert false - | t :: l -> - match (repr t).state with - | Sleep _ -> - cancel t; - cancel_and_nth_ready l n - | _ when n > 0 -> - cancel_and_nth_ready l (n - 1) - | state -> - List.iter cancel l; - state - -let pick l = - let ready = ready_count l in - if ready > 0 then - if ready = 1 then - (* Optimisation for the common case: *) - thread { state = cancel_and_nth_ready l 0 } - else - thread { state = cancel_and_nth_ready l (Random.State.int random_state ready) } - else begin - let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) in - let rec waiter = ref (Some handle_result) - and handle_result state = - waiter := None; - remove_waiters l; - (* Cancel all other threads: *) - List.iter cancel l; - fast_connect res state - in - List.iter - (fun t -> - match (repr t).state with - | Sleep sleeper -> - add_removable_waiter sleeper waiter; - | _ -> - assert false) - l; - res - end - -let npick_sleep l = - let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) in - let rec waiter = ref (Some handle_result) - and handle_result state = - waiter := None; - remove_waiters l; - List.iter cancel l; - nchoose_terminate res [] l - in - List.iter - (fun t -> - match (repr t).state with - | Sleep sleeper -> - add_removable_waiter sleeper waiter; - | _ -> - assert false) - l; - res - -let npick threads = - let rec init = function - | [] -> - npick_sleep threads - | t :: l -> - match (repr t).state with - | Return x -> - collect [x] l - | Fail exn -> - List.iter cancel threads; - fail exn - | _ -> - init l - and collect acc = function - | [] -> - List.iter cancel threads; - return (List.rev acc) - | t :: l -> - match (repr t).state with - | Return x -> - collect (x :: acc) l - | Fail exn -> - List.iter cancel threads; - fail exn - | _ -> - collect acc l - in - init threads - -let join l = - let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) - (* Number of threads still sleeping: *) - and sleeping = ref 0 - (* The state that must be returned: *) - and return_state = ref (Return ()) in - let rec waiter = ref (Some handle_result) - and handle_result state = - begin - match !return_state, state with - | Return _, Fail exn -> return_state := state - | _ -> () - end; - decr sleeping; - (* All threads are terminated, we can wakeup the result: *) - if !sleeping = 0 then begin - waiter := None; - fast_connect res !return_state - end - in - let rec init = function - | [] -> - if !sleeping = 0 then - (* No thread is sleeping, returns immediately: *) - thread { state = !return_state } - else - res - | t :: rest -> - match (repr t).state with - | Sleep sleeper -> - incr sleeping; - add_removable_waiter sleeper waiter; - init rest - | Fail _ as state -> begin - match !return_state with - | Return _ -> - return_state := state; - init rest - | _ -> - init rest - end - | _ -> - init rest - in - init l - -let ( ) t1 t2 = choose [t1; t2] -let ( <&> ) t1 t2 = join [t1; t2] - -let finalize f g = - try_bind f - (fun x -> g () >>= fun () -> return x) - (fun e -> g () >>= fun () -> fail e) - -let update_data key = function - | Some _ as value -> - current_data := Int_map.add key.id (fun () -> key.store <- value) !current_data - | None -> - current_data := Int_map.remove key.id !current_data - -let with_value key value f = - let save = !current_data in - let data = - match value with - | Some _ -> - Int_map.add key.id (fun () -> key.store <- value) save - | None -> - Int_map.remove key.id save - in - current_data := data; - try - let result = f () in - current_data := save; - result - with exn -> - current_data := save; - raise exn - -(* +-----------------------------------------------------------------+ - | Paused threads | - +-----------------------------------------------------------------+ *) - -let pause_hook = ref ignore - -let paused = Lwt_sequence.create () -let paused_count = ref 0 - -let pause () = - let waiter, wakener = task () in - let node = Lwt_sequence.add_r wakener paused in - on_cancel waiter (fun () -> Lwt_sequence.remove node); - incr paused_count; - !pause_hook !paused_count; - waiter - -let wakeup_paused () = - if not (Lwt_sequence.is_empty paused) then begin - let tmp = Lwt_sequence.create () in - Lwt_sequence.transfer_r paused tmp; - paused_count := 0; - Lwt_sequence.iter_l (fun wakener -> wakeup wakener ()) tmp - end - -let register_pause_notifier f = pause_hook := f - -let paused_count () = !paused_count - -(* +-----------------------------------------------------------------+ - | Bakctrace support | - +-----------------------------------------------------------------+ *) - -let backtrace_bind add_loc t f = - match (repr t).state with - | Return v -> - f v - | Fail exn -> - thread { state = Fail(add_loc exn) } - | Sleep sleeper -> - let res = temp sleeper.cancel in - let data = !current_data in - add_immutable_waiter sleeper - (function - | Return v -> current_data := data; connect res (try f v with exn -> fail (add_loc exn)) - | Fail exn -> fast_connect res (Fail(add_loc exn)) - | _ -> assert false); - res - | Repr _ -> - assert false - -let backtrace_catch add_loc x f = - let t = try x () with exn -> fail exn in - match (repr t).state with - | Return _ -> - t - | Fail exn -> - f (add_loc exn) - | Sleep sleeper -> - let res = temp sleeper.cancel in - let data = !current_data in - add_immutable_waiter sleeper - (function - | Return _ as state -> fast_connect res state - | Fail exn -> current_data := data; connect res (try f exn with exn -> fail (add_loc exn)) - | _ -> assert false); - res - | Repr _ -> - assert false - -let backtrace_try_bind add_loc x f g = - let t = try x () with exn -> fail exn in - match (repr t).state with - | Return v -> - f v - | Fail exn -> - g (add_loc exn) - | Sleep sleeper -> - let res = temp sleeper.cancel in - let data = !current_data in - add_immutable_waiter sleeper - (function - | Return v -> current_data := data; connect res (try f v with exn -> fail (add_loc exn)) - | Fail exn -> current_data := data; connect res (try g exn with exn -> fail (add_loc exn)) - | _ -> assert false); - res - | Repr _ -> - assert false - -let backtrace_finalize add_loc f g = - backtrace_try_bind add_loc f - (fun x -> g () >>= fun () -> return x) - (fun e -> g () >>= fun () -> fail (add_loc e)) - -(* +-----------------------------------------------------------------+ - | Threads state query | - +-----------------------------------------------------------------+ *) - -module State = struct - type 'a state = - | Return of 'a - | Fail of exn - | Sleep -end - -let state t = match (repr t).state with - | Return v -> State.Return v - | Fail exn -> State.Fail exn - | Sleep _ -> State.Sleep - | Repr _ -> assert false - -include State diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt.mli deleted file mode 100644 index 576684b..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt.mli +++ /dev/null @@ -1,396 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Module [Lwt]: cooperative light-weight threads. *) - -(** This module defines {e cooperative light-weight threads} with - their primitives. A {e light-weight thread} represent a - computation that may be not terminated, for example because it is - waiting for some event to happen. - - Lwt threads are cooperative in the sense that switching to another - thread is awlays explicit (with {!wakeup} or {!wekup_exn}). When a - thread is running, it executes as much as possible, and then - returns (a value or an eror) or sleeps. - - Note that inside a Lwt thread, exceptions must be raised with - {!fail} instead of [raise]. Also the [try ... with ...] - construction will not catch Lwt errors. You must use {!catch} - instead. You can also use {!wrap} for functions that may raise - normal exception. - - Lwt also provides the syntax extension {!Pa_lwt} to make code - using Lwt more readable. -*) - -(** {6 Definitions and basics} *) - -type +'a t - (** The type of threads returning a result of type ['a]. *) - -val return : 'a -> 'a t - (** [return e] is a thread whose return value is the value of the - expression [e]. *) - -val fail : exn -> 'a t - (** [fail e] is a thread that fails with the exception [e]. *) - -val bind : 'a t -> ('a -> 'b t) -> 'b t - (** [bind t f] is a thread which first waits for the thread [t] to - terminate and then, if the thread succeeds, behaves as the - application of function [f] to the return value of [t]. If the - thread [t] fails, [bind t f] also fails, with the same - exception. - - The expression [bind t (fun x -> t')] can intuitively be read as - [let x = t in t'], and if you use the {e lwt.syntax} syntax - extension, you can write a bind operation like that: [lwt x = t in t']. - - Note that [bind] is also often used just for synchronization - purpose: [t'] will not execute before [t] is terminated. - - The result of a thread can be bound several time. *) - -val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - (** [t >>= f] is an alternative notation for [bind t f]. *) - -val (=<<) : ('a -> 'b t) -> 'a t -> 'b t - (** [f =<< t] is [t >>= f] *) - -val map : ('a -> 'b) -> 'a t -> 'b t - (** [map f m] map the result of a thread. This is the same as [bind - m (fun x -> return (f x))] *) - -val (>|=) : 'a t -> ('a -> 'b) -> 'b t - (** [m >|= f] is [map f m] *) - -val (=|<) : ('a -> 'b) -> 'a t -> 'b t - (** [f =|< m] is [map f m] *) - -(** {6 Thread storage} *) - -type 'a key - (** Type of a key. Keys are used to store local values into - threads *) - -val new_key : unit -> 'a key - (** [new_key ()] creates a new key. *) - -val get : 'a key -> 'a option - (** [get key] returns the value associated with [key] in the current - thread. *) - -val with_value : 'a key -> 'a option -> (unit -> 'b) -> 'b - (** [with_value key value f] executes [f] with [value] associated to - [key]. The previous value associated to [key] is restored after - [f] terminates. *) - -(** {6 Exceptions handling} *) - -val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t - (** [catch t f] is a thread that behaves as the thread [t ()] if - this thread succeeds. If the thread [t ()] fails with some - exception, [catch t f] behaves as the application of [f] to this - exception. *) - -val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t - (** [try_bind t f g] behaves as [bind (t ()) f] if [t] does not - fail. Otherwise, it behaves as the application of [g] to the - exception associated to [t ()]. *) - -val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t - (** [finalize f g] returns the same result as [f ()] whether it - fails or not. In both cases, [g ()] is executed after [f]. *) - -val wrap : (unit -> 'a) -> 'a t - (** [wrap f] calls [f] and transform the result into a monad. If [f] - raise an exception, it is catched by Lwt. - - This is actually the same as: - - {[ - try - return (f ()) - with exn -> - fail exn - ]} - *) - -val wrap1 : ('a -> 'b) -> 'a -> 'b t - (** [wrap1 f x] applies [f] on [x] and returns the result as a - thread. If the application of [f] to [x] raise an exception it - is catched and a thread is returned. - - Note that you must use {!wrap} instead of {!wrap1} if the - evaluation of [x] may raise an exception. - - for example the following code is not ok: - - {[ - wrap1 f (Hashtbl.find table key) - ]} - - you should write instead: - - {[ - wrap (fun () -> f (Hashtbl.find table key)) - ]} - *) - -val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t -val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t -val wrap4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e t -val wrap5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f t -val wrap6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g t -val wrap7 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h t - -(** {6 Multi-threads composition} *) - -val choose : 'a t list -> 'a t - (** [choose l] behaves as the first thread in [l] to terminate. If - several threads are already terminated, one is choosen at - random. - - Note: {!choose} leaves the local values of the current thread - unchanged. *) - -val nchoose : 'a t list -> 'a list t - (** [nchoose l] returns the value of all that have succcessfully - terminated. If all threads are sleeping, it waits for at least - one to terminates. If one the threads of [l] fails, [nchoose] - fails with the same exception. - - Note: {!nchoose} leaves the local values of the current thread - unchanged. *) - -val nchoose_split : 'a t list -> ('a list * 'a t list) t - (** [nchoose_split l] does the same as {!nchoose} but also retrurns - the list of threads that have not yet terminated. *) - -val join : unit t list -> unit t - (** [join l] waits for all threads in [l] to terminate. If one of - the threads fails, then [join l] will fails with the same - exception as the first one to terminate. - - Note: {!join} leaves the local values of the current thread - unchanged. *) - -val ( ) : 'a t -> 'a t -> 'a t - (** [t t'] is the same as [choose [t; t']] *) - -val ( <&> ) : unit t -> unit t -> unit t - (** [t <&> t'] is the same as [join [t; t']] *) - -val ignore_result : 'a t -> unit - (** [ignore_result t] start the thread [t] and ignores its result - value if the thread terminates sucessfully. However, if the - thread [t] fails, the exception is raised instead of being - ignored. - - You should use this function if you want to start a thread and - don't care what its return value is, nor when it terminates (for - instance, because it is looping). Note that if the thread [t] - yields and later fails, the exception will not be raised at this - point in the program. *) - -(** {6 Sleeping and resuming} *) - -type 'a u - (** The type of thread wakeners. *) - -val wait : unit -> 'a t * 'a u - (** [wait ()] is a pair of a thread which sleeps forever (unless it - is resumed by one of the functions [wakeup], [wakeup_exn] below) - and the corresponding wakener. This thread does not block the - execution of the remainder of the program (except of course, if - another thread tries to wait for its termination). *) - -val wakeup : 'a u -> 'a -> unit - (** [wakeup t e] makes the sleeping thread [t] terminate and return - the value of the expression [e]. *) - -val wakeup_exn : 'a u -> exn -> unit - (** [wakeup_exn t e] makes the sleeping thread [t] fail with the - exception [e]. *) - -val wakeup_later : 'a u -> 'a -> unit - (** Same as {!wakeup} but it is not guaranteed that the thread will - be wakeup immediately. *) - -val wakeup_later_exn : 'a u -> exn -> unit - (** Same as {!wakeup_exn} but it is not guaranteed that the thread - will be wakeup immediately. *) - -val waiter_of_wakener : 'a u -> 'a t - (** Returns the thread associated to a wakener. *) - -(** {6 Threads state} *) - -(** State of a thread *) -type 'a state = - | Return of 'a - (** The thread which has successfully terminated *) - | Fail of exn - (** The thread raised an exception *) - | Sleep - (** The thread is sleeping *) - -val state : 'a t -> 'a state - (** [state t] returns the state of a thread *) - -(** {6 Cancelable threads} *) - -(** Cancelable threads are the same as regular threads except that - they can be canceled. *) - -exception Canceled - (** Canceled threads fails with this exception *) - -val task : unit -> 'a t * 'a u - (** [task ()] is the same as [wait ()] except that threads created - with [task] can be canceled. *) - -val on_cancel : 'a t -> (unit -> unit) -> unit - (** [on_cancel t f] executes [f] when [t] is canceled. This is the - same as catching [Canceled]. *) - -val cancel : 'a t -> unit - (** [cancel t] cancels the threads [t]. This means that the deepest - sleeping thread created with [task] and connected to [t] is - woken up with the exception {!Canceled}. - - For example, in the following code: - - {[ - let waiter, wakener = task () in - cancel (waiter >> printl "plop") - ]} - - [waiter] will be woken up with {!Canceled}. - *) - -val pick : 'a t list -> 'a t - (** [pick l] is the same as {!choose}, except that it cancels all - sleeping threads when one terminates. - - Note: {!pick} leaves the local values of the current thread - unchanged. *) - -val npick : 'a t list -> 'a list t - (** [npick l] is the same as {!nchoose}, except that it cancels all - sleeping threads when one terminates. - - Note: {!npick} leaves the local values of the current thread - unchanged. *) - -val protected : 'a t -> 'a t - (** [protected thread] creates a new cancelable thread which behave - as [thread] except that cancelling it does not cancel - [thread]. *) - -(** {6 Pause} *) - -val pause : unit -> unit t - (** [pause ()] is a sleeping thread which is wake up on the next - call to {!wakeup_paused}. A thread created with [pause] can be - canceled. *) - -val wakeup_paused : unit -> unit - (** [wakeup_paused ()] wakes up all threads which suspended - themselves with {!pause}. - - This function is called by the scheduler, before entering the - main loop. You usually do not have to call it directly, except - if you are writing a custom scheduler. - - Note that if a paused thread resume and pause again, it will not - be wakeup at this point. *) - -val paused_count : unit -> int - (** [paused_count ()] returns the number of thread currently - paused. *) - -val register_pause_notifier : (int -> unit) -> unit - (** [register_pause_notifier f] register a function [f] that will be - called each time pause is called. The parameter passed to [f] is - the new number of threads paused. It is usefull to be able to - call {!wakeup_paused} when there is no scheduler *) - -(** {6 Misc} *) - -val on_success : 'a t -> ('a -> unit) -> unit - (** [on_success t f] executes [f] when [t] terminates without - failing. This is the same as: - - {[ - ignore_result (bind t (fun x -> f x; return ())) - ]} - - but a bit more efficient. - *) - -val on_failure : 'a t -> (exn -> unit) -> unit - (** [on_failure t f] executes [f] when [t] terminates and - fails. This is the same as: - - {[ - ignore_result (catch t (fun e -> f e; return ())) - ]} - - but a bit more efficient. - *) - -val on_termination : 'a t -> (unit -> unit) -> unit - (** [on_termination t f] executes [f] when [t] terminates. This is - the same as: - - {[ - ignore_result (finalize (fun () -> t) (fun () -> f (); return ())) - ]} - - but a bit more efficient. - *) - -(**/**) - -(* The functions below are probably not useful for the casual user. - They provide the basic primitives on which can be built multi- - threaded libraries such as Lwt_unix. *) - -val poll : 'a t -> 'a option - (* [poll e] returns [Some v] if the thread [e] is terminated and - returned the value [v]. If the thread failed with some - exception, this exception is raised. If the thread is still - running, [poll e] returns [None] without blocking. *) - -val apply : ('a -> 'b t) -> 'a -> 'b t - (* [apply f e] apply the function [f] to the expression [e]. If - an exception is raised during this application, it is caught - and the resulting thread fails with this exception. *) -(* Q: Could be called 'glue' or 'trap' or something? *) - -val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t -val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t -val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t -val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t - diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt.mllib b/server/thirdparty/lwt-2.3.2/src/core/lwt.mllib deleted file mode 100644 index f9ddffb..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt.mllib +++ /dev/null @@ -1,14 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: ecdfab02163af2abad730a4cf20c2630) -Lwt_condition -Lwt_list -Lwt -Lwt_mutex -Lwt_mvar -Lwt_pool -Lwt_sequence -Lwt_stream -Lwt_switch -Lwt_util -Lwt_pqueue -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_condition.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt_condition.ml deleted file mode 100644 index 179d6d1..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_condition.ml +++ /dev/null @@ -1,63 +0,0 @@ -(******************************************************************************) -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_condition - ****************************************************************************** - * Copyright (c) 2009, Metaweb Technologies, Inc. - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * * Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * * Redistributions in binary form must reproduce the above - * copyright notice, this list of conditions and the following - * disclaimer in the documentation and/or other materials provided - * with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR - * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE - * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN - * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - ******************************************************************************) - -open Lwt - -type 'a t = 'a Lwt.u Lwt_sequence.t - -let create = Lwt_sequence.create - -let wait ?mutex cvar = - let waiter, wakener = Lwt.task () in - let node = Lwt_sequence.add_r wakener cvar in - on_cancel waiter (fun () -> Lwt_sequence.remove node); - let () = - match mutex with - | Some m -> Lwt_mutex.unlock m - | None -> () - in - try_lwt - waiter - finally - match mutex with - | Some m -> Lwt_mutex.lock m - | None -> return () - -let signal cvar arg = - try - wakeup_later (Lwt_sequence.take_l cvar) arg - with Lwt_sequence.Empty -> - () - -let broadcast cvar arg = - let wakeners = Lwt_sequence.fold_r (fun x l -> x :: l) cvar [] in - Lwt_sequence.iter_node_l Lwt_sequence.remove cvar; - List.iter (fun wakener -> wakeup_later wakener arg) wakeners diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_condition.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt_condition.mli deleted file mode 100644 index 8e011de..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_condition.mli +++ /dev/null @@ -1,65 +0,0 @@ -(******************************************************************************) -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_condition - ****************************************************************************** - * Copyright (c) 2009, Metaweb Technologies, Inc. - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * * Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * * Redistributions in binary form must reproduce the above - * copyright notice, this list of conditions and the following - * disclaimer in the documentation and/or other materials provided - * with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR - * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE - * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN - * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - ******************************************************************************) - -(** Conditions *) - -(** Condition variables to synchronize between threads. *) - -type 'a t - (** Condition variable type. The type parameter denotes the type of - value propagated from notifier to waiter. *) - -val create : unit -> 'a t - (** [create ()] creates a new condition variable. *) - -val wait : ?mutex:Lwt_mutex.t -> 'a t -> 'a Lwt.t - (** [wait mutex condvar] will cause the current thread to block, - awaiting notification for a condition variable, [condvar]. If - provided, the [mutex] must have been previously locked (within - the scope of [Lwt_mutex.with_lock], for example) and is - temporarily unlocked until the condition is notified. Upon - notification, [mutex] is re-locked before [wait] returns and - the thread's activity is resumed. When the awaited condition - is notified, the value parameter passed to [notify] is - returned. *) - -val signal : 'a t -> 'a -> unit - (** [signal condvar value] notifies that a condition is ready. A - single waiting thread will be awoken and will receive the - notification value which will be returned from [wait]. Note - that condition notification is not "sticky", i.e. if there is - no waiter when [notify] is called, the notification will be - missed and the value discarded. *) - -val broadcast : 'a t -> 'a -> unit - (** [broadcast condvar value] notifies all waiting threads. Each - will be awoken in turn and will receive the same notification - value. *) diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_list.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt_list.ml deleted file mode 100644 index 2b0fba2..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_list.ml +++ /dev/null @@ -1,189 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_list - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt - -let rec iter_s f l = - match l with - | [] -> - return () - | x :: l -> - lwt () = f x in - iter_s f l - -let rec iter_p f l = - match l with - | [] -> - return () - | x :: l -> - let t = f x and lt = iter_p f l in - lwt () = t in - lt - -let rec map_s f l = - match l with - | [] -> - return [] - | x :: l -> - lwt x = f x in - lwt l = map_s f l in - return (x :: l) - -let rec map_p f l = - match l with - | [] -> - return [] - | x :: l -> - lwt x = f x and l = map_p f l in - return (x :: l) - -let rec rev_map_append_s acc f l = - match l with - | [] -> - return acc - | x :: l -> - lwt x = f x in - rev_map_append_s (x :: acc) f l - -let rev_map_s f l = - rev_map_append_s [] f l - -let rec rev_map_append_p acc f l = - match l with - | [] -> - acc - | x :: l -> - rev_map_append_p (lwt x = f x and l = acc in return (x :: l)) f l - -let rev_map_p f l = - rev_map_append_p (return []) f l - -let rec fold_left_s f acc l = - match l with - | [] -> - return acc - | x :: l -> - lwt acc = f acc x in - fold_left_s f acc l - -let rec fold_right_s f l acc = - match l with - | [] -> - return acc - | x :: l -> - lwt acc = fold_right_s f l acc in - f x acc - -let rec for_all_s f l = - match l with - | [] -> - return true - | x :: l -> - f x >>= function - | true -> - for_all_s f l - | false -> - return false - -let rec for_all_p f l = - match l with - | [] -> - return true - | x :: l -> - lwt bx = f x and bl = for_all_p f l in - return (bx && bl) - -let rec exists_s f l = - match l with - | [] -> - return false - | x :: l -> - f x >>= function - | true -> - return true - | false -> - exists_s f l - -let rec exists_p f l = - match l with - | [] -> - return false - | x :: l -> - lwt bx = f x and bl = exists_p f l in - return (bx || bl) - -let rec find_s f l = - match l with - | [] -> - raise_lwt Not_found - | x :: l -> - f x >>= function - | true -> - return x - | false -> - find_s f l - -let rec filter_s f l = - match l with - | [] -> - return [] - | x :: l -> - f x >>= function - | true -> - lwt l = filter_s f l in - return (x :: l) - | false -> - filter_s f l - -let rec filter_p f l = - match l with - | [] -> - return [] - | x :: l -> - lwt bx = f x and l = filter_p f l in - if bx then - return (x :: l) - else - return l - -let rec partition_s f l = - match l with - | [] -> - return ([], []) - | x :: l -> - lwt bx = f x in - lwt l_l, l_r = partition_s f l in - if bx then - return (x :: l_l, l_r) - else - return (l_l, x :: l_r) - -let rec partition_p f l = - match l with - | [] -> - return ([], []) - | x :: l -> - lwt bx = f x and l_l, l_r = partition_p f l in - if bx then - return (x :: l_l, l_r) - else - return (l_l, x :: l_r) diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_list.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt_list.mli deleted file mode 100644 index ff4e30c..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_list.mli +++ /dev/null @@ -1,59 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_list - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** List helpers *) - -(** Note: this module use the same naming convention as - {!Lwt_stream}. *) - -(** {6 List iterators} *) - -val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t -val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t - -val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t -val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - -val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t -val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - -val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t - -val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t - -(** {6 List scanning} *) - -val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t -val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t - -val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t -val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t - -(** {6 List searching} *) - -val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a Lwt.t - -val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t -val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t - -val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t -val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_mutex.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt_mutex.ml deleted file mode 100644 index 86d5211..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_mutex.ml +++ /dev/null @@ -1,60 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_mutex - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt - -type t = { mutable locked : bool; mutable waiters : unit Lwt.u Lwt_sequence.t } - -let create () = { locked = false; waiters = Lwt_sequence.create () } - -let rec lock m = - if m.locked then begin - let (res, w) = Lwt.task () in - let node = Lwt_sequence.add_r w m.waiters in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - res - end else begin - m.locked <- true; - Lwt.return () - end - -let unlock m = - if m.locked then begin - if Lwt_sequence.is_empty m.waiters then - m.locked <- false - else - (* We do not use [Lwt.wakeup] here to avoid a stack overflow - when unlocking a lot of threads. *) - Lwt.wakeup_later (Lwt_sequence.take_l m.waiters) () - end - -let with_lock m f = - lwt () = lock m in - try_lwt - f () - finally - unlock m; - return () - -let is_locked m = m.locked -let is_empty m = Lwt_sequence.is_empty m.waiters diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_mutex.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt_mutex.mli deleted file mode 100644 index afbd483..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_mutex.mli +++ /dev/null @@ -1,62 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_mutex - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Cooperative locks for mutual exclusion *) - -type t - (** Type of Lwt mutexes *) - -val create : unit -> t - (** [create ()] creates a new mutex, which is initially unlocked *) - -val lock : t -> unit Lwt.t - (** [lock mutex] lockcs the mutex, that is: - - - if the mutex is unlocked, then it is marked as locked and - {!lock} returns immediatly - - - if it is locked, then {!lock} waits for all threads waiting on - the mutex to terminate, then it resumes when the last one - unlocks the mutex - - Note: threads are wake up is the same order they try to lock the - mutex *) - -val unlock : t -> unit - (** [unlock mutex] unlock the mutex if no threads is waiting on - it. Otherwise it will eventually removes the first one and - resumes it. *) - -val is_locked : t -> bool - (** [locked mutex] returns whether [mutex] is currently locked *) - -val is_empty : t -> bool - (** [is_empty mutex] returns [true] if they are no thread waiting on - the mutex, and [false] otherwise *) - -val with_lock : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t - (** [with_lock lock f] is used to lock a mutex within a block scope. - The function [f ()] is called with the mutex locked, and its - result is returned from the call to {with_lock}. If an exception - is raised from f, the mutex is also unlocked before the scope of - {with_lock} is exited. *) diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_mvar.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt_mvar.ml deleted file mode 100644 index 0666e35..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_mvar.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* -*- Mode: Caml; indent-tabs-mode: nil -*- *) -(******************************************************************************) -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_mon - ****************************************************************************** - * Copyright (c) 2009, Metaweb Technologies, Inc. - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * * Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * * Redistributions in binary form must reproduce the above - * copyright notice, this list of conditions and the following - * disclaimer in the documentation and/or other materials provided - * with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR - * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE - * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN - * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - ******************************************************************************) - -let return_unit = Lwt.return () - -type 'a t = { - mutable contents : 'a option; - (* Current contents *) - - mutable writers : ('a * unit Lwt.u) Lwt_sequence.t; - (* Threads waiting to put a value *) - - mutable readers : 'a Lwt.u Lwt_sequence.t; - (* Threads waiting for a value *) -} - -let create_empty () = - { contents = None; - writers = Lwt_sequence.create (); - readers = Lwt_sequence.create () } - -let create v = - { contents = Some v; - writers = Lwt_sequence.create (); - readers = Lwt_sequence.create () } - -let put mvar v = - match mvar.contents with - | None -> - begin match Lwt_sequence.take_opt_l mvar.readers with - | None -> - mvar.contents <- Some v - | Some w -> - Lwt.wakeup_later w v - end; - return_unit - | Some _ -> - let (res, w) = Lwt.task () in - let node = Lwt_sequence.add_r (v, w) mvar.writers in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - res - -let take mvar = - match mvar.contents with - | Some v -> - begin match Lwt_sequence.take_opt_l mvar.writers with - | Some(v', w) -> - mvar.contents <- Some v'; - Lwt.wakeup_later w () - | None -> - mvar.contents <- None - end; - Lwt.return v - | None -> - let (res, w) = Lwt.task () in - let node = Lwt_sequence.add_r w mvar.readers in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - res diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_mvar.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt_mvar.mli deleted file mode 100644 index 17b825e..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_mvar.mli +++ /dev/null @@ -1,63 +0,0 @@ -(* -*- Mode: Caml; indent-tabs-mode: nil -*- *) -(******************************************************************************) -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_mon - ****************************************************************************** - * Copyright (c) 2009, Metaweb Technologies, Inc. - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * * Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * * Redistributions in binary form must reproduce the above - * copyright notice, this list of conditions and the following - * disclaimer in the documentation and/or other materials provided - * with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY - * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR - * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE - * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN - * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - ******************************************************************************) - -(** Mailbox variables *) - -(** "Mailbox" variables implement a synchronising variable, used for - communication between concurrent threads. - - This code adapted from - {{:http://eigenclass.org/hiki.rb?cmd=view&p=lightweight-threads-with-lwt}Comparing lightweight threads (eigenclass.org)} *) - -type 'a t - (** The type of a mailbox variable. Mailbox variables are used to - communicate values between threads in a synchronous way. The - type parameter specifies the type of the value propagated from - [put] to [take]. *) - -val create : 'a -> 'a t - (** [create v] creates a new mailbox variable containing value [v]. *) - -val create_empty : unit -> 'a t - (** [create ()] creates a new empty mailbox variable. *) - -val put : 'a t -> 'a -> unit Lwt.t - (** [put mvar value] puts a value into a mailbox variable. This - value will remain in the mailbox until [take] is called to - remove it. If the mailbox is not empty, the current thread will - block until it is emptied. *) - -val take : 'a t -> 'a Lwt.t - (** [take mvar] will take any currently available value from the - mailbox variable. If no value is currently available, the - current thread will block, awaiting a value to be [put] by - another thread. *) diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_pool.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt_pool.ml deleted file mode 100644 index 489418a..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_pool.ml +++ /dev/null @@ -1,93 +0,0 @@ -(* Lwt - * http://www.ocsigen.org - * Copyright (C) 2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later version. - * See COPYING file for details. - * - * 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -open Lwt - -(* -XXX Close after some timeout -... -*) - -type 'a t = - { create : unit -> 'a Lwt.t; - check : 'a -> (bool -> unit) -> unit; - max : int; - mutable count : int; - list : 'a Queue.t; - waiters : 'a Lwt.u Lwt_sequence.t } - -let create m ?(check = fun _ f -> f true) create = - { max = m; - create = create; - check = check; - count = 0; - list = Queue.create (); - waiters = Lwt_sequence.create () } - -let create_member p = - try_lwt - p.count <- p.count + 1; (* must be done before p.create *) - lwt mem = p.create () in - return mem - with exn -> - (* create failed, so don't increment count *) - p.count <- p.count - 1; - raise_lwt exn - -let acquire p = - try - return (Queue.take p.list) - with Queue.Empty -> - if p.count < p.max then - create_member p - else begin - let waiter, wakener = task () in - let node = Lwt_sequence.add_r wakener p.waiters in - on_cancel waiter (fun () -> Lwt_sequence.remove node); - waiter - end - -let release p c = - try - wakeup_later (Lwt_sequence.take_l p.waiters) c - with Lwt_sequence.Empty -> - Queue.push c p.list - -let checked_release p c = - p.check c begin fun ok -> - if ok then - release p c - else - ignore (p.count <- p.count - 1; - lwt c = create_member p in - release p c; - return ()) - end - -let use p f = - lwt c = acquire p in - try_lwt - lwt r = f c in - release p c; - return r - with e -> - checked_release p c; - raise_lwt e diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_pool.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt_pool.mli deleted file mode 100644 index 26ceda1..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_pool.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Lwt - * http://www.ocsigen.org - * Copyright (C) 2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later version. - * See COPYING file for details. - * - * 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -(** Creating pools (for example pools of connections to a database). *) - -(** Instead of creating a new connection each time you need one, - keep a pool of opened connections and reuse opened connections - that are free. - *) - -(** Type of pools *) -type 'a t - -(** [create n f] creates a new pool with at most [n] members. - [f] is the function to use to create a new pool member. *) -val create : - int -> ?check:('a -> (bool -> unit) -> unit) -> (unit -> 'a Lwt.t) -> 'a t - -(** [use p f] takes one free member of the pool [p] and gives it to the function - [f]. - *) -val use : 'a t -> ('a -> 'b Lwt.t) -> 'b Lwt.t diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.ml deleted file mode 100644 index 2c966a8..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.ml +++ /dev/null @@ -1,108 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_pqueue - * Copyright (C) 1999-2004 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -module type OrderedType = - sig - type t - val compare: t -> t -> int - end - -module type S = - sig - type elt - type t - val empty: t - val is_empty: t -> bool - val add: elt -> t -> t - val union: t -> t -> t - val find_min: t -> elt - val lookup_min: t -> elt option - val remove_min: t -> t - val size: t -> int - end - -module Make(Ord: OrderedType) : (S with type elt = Ord.t) = - struct - type elt = Ord.t - - type t = tree list - and tree = Node of elt * int * tree list - - let root (Node (x, _, _)) = x - let rank (Node (_, r, _)) = r - let link (Node (x1, r1, c1) as t1) (Node (x2, r2, c2) as t2) = - let c = Ord.compare x1 x2 in - if c <= 0 then Node (x1, r1 + 1, t2::c1) else Node(x2, r2 + 1, t1::c2) - let rec ins t = - function - [] -> - [t] - | (t'::_) as ts when rank t < rank t' -> - t::ts - | t'::ts -> - ins (link t t') ts - - let empty = [] - let is_empty ts = ts = [] - let add x ts = ins (Node (x, 0, [])) ts - let rec union ts ts' = - match ts, ts' with - ([], _) -> ts' - | (_, []) -> ts - | (t1::ts1, t2::ts2) -> - if rank t1 < rank t2 then t1 :: union ts1 (t2::ts2) - else if rank t2 < rank t1 then t2 :: union (t1::ts1) ts2 - else ins (link t1 t2) (union ts1 ts2) - - let rec find_min = - function - [] -> raise Not_found - | [t] -> root t - | t::ts -> - let x = find_min ts in - let c = Ord.compare (root t) x in - if c < 0 then root t else x - - let lookup_min t = - try Some(find_min t) with Not_found -> None - - let rec get_min = - function - [] -> assert false - | [t] -> (t, []) - | t::ts -> - let (t', ts') = get_min ts in - let c = Ord.compare (root t) (root t') in - if c < 0 then (t, ts) else (t', t::ts') - - let remove_min = - function - [] -> raise Not_found - | ts -> - let (Node (x, r, c), ts) = get_min ts in - union (List.rev c) ts - - let rec size l = - let rec sizetree (Node (_,_,tl)) = 1 + size tl in - List.fold_left (fun s t -> s + sizetree t) 0 l - end diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.mli deleted file mode 100644 index 0fc86f1..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_pqueue - * Copyright (C) 1999-2004 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -module type OrderedType = - sig - type t - val compare: t -> t -> int - end - -module type S = - sig - type elt - type t - val empty: t - val is_empty: t -> bool - val add: elt -> t -> t - val union: t -> t -> t - val find_min: t -> elt - val lookup_min: t -> elt option - val remove_min: t -> t - val size: t -> int - end - -module Make(Ord: OrderedType) : S with type elt = Ord.t diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_sequence.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt_sequence.ml deleted file mode 100644 index e2dbc89..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_sequence.ml +++ /dev/null @@ -1,209 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_sequence - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -exception Empty - -type 'a t = { - mutable prev : 'a t; - mutable next : 'a t; -} - -type 'a node = { - mutable node_prev : 'a t; - mutable node_next : 'a t; - mutable node_data : 'a; - mutable node_active : bool; -} - -external seq_of_node : 'a node -> 'a t = "%identity" -external node_of_seq : 'a t -> 'a node = "%identity" - -(* +-----------------------------------------------------------------+ - | Operations on nodes | - +-----------------------------------------------------------------+ *) - -let get node = - node.node_data - -let set node data = - node.node_data <- data - -let remove node = - if node.node_active then begin - node.node_active <- false; - let seq = seq_of_node node in - seq.prev.next <- seq.next; - seq.next.prev <- seq.prev - end - -(* +-----------------------------------------------------------------+ - | Operations on sequences | - +-----------------------------------------------------------------+ *) - -let create () = - let rec seq = { prev = seq; next = seq } in - seq - -let is_empty seq = seq.next == seq - -let length seq = - let rec loop curr len = - if curr == seq then - len - else - let node = node_of_seq curr in - if node.node_active then - loop node.node_next (len + 1) - else - loop node.node_next len - in - loop seq.next 0 - -let add_l data seq = - let node = { node_prev = seq; node_next = seq.next; node_data = data; node_active = true } in - seq.next.prev <- seq_of_node node; - seq.next <- seq_of_node node; - node - -let add_r data seq = - let node = { node_prev = seq.prev; node_next = seq; node_data = data; node_active = true } in - seq.prev.next <- seq_of_node node; - seq.prev <- seq_of_node node; - node - -let take_l seq = - if is_empty seq then - raise Empty - else begin - let node = node_of_seq seq.next in - remove node; - node.node_data - end - -let take_r seq = - if is_empty seq then - raise Empty - else begin - let node = node_of_seq seq.prev in - remove node; - node.node_data - end - -let take_opt_l seq = - if is_empty seq then - None - else begin - let node = node_of_seq seq.next in - remove node; - Some node.node_data - end - -let take_opt_r seq = - if is_empty seq then - None - else begin - let node = node_of_seq seq.prev in - remove node; - Some node.node_data - end - -let transfer_l s1 s2 = - s2.next.prev <- s1.prev; - s1.prev.next <- s2.next; - s2.next <- s1.next; - s1.next.prev <- s2; - s1.prev <- s1; - s1.next <- s1 - -let transfer_r s1 s2 = - s2.prev.next <- s1.next; - s1.next.prev <- s2.prev; - s2.prev <- s1.prev; - s1.prev.next <- s2; - s1.prev <- s1; - s1.next <- s1 - -let iter_l f seq = - let rec loop curr = - if curr != seq then begin - let node = node_of_seq curr in - if node.node_active then f node.node_data; - loop node.node_next - end - in - loop seq.next - -let iter_r f seq = - let rec loop curr = - if curr != seq then begin - let node = node_of_seq curr in - if node.node_active then f node.node_data; - loop node.node_prev - end - in - loop seq.prev - -let iter_node_l f seq = - let rec loop curr = - if curr != seq then begin - let node = node_of_seq curr in - if node.node_active then f node; - loop node.node_next - end - in - loop seq.next - -let iter_node_r f seq = - let rec loop curr = - if curr != seq then begin - let node = node_of_seq curr in - if node.node_active then f node; - loop node.node_prev - end - in - loop seq.prev - -let fold_l f seq acc = - let rec loop curr acc = - if curr == seq then - acc - else - let node = node_of_seq curr in - if node.node_active then - loop node.node_next (f node.node_data acc) - else - loop node.node_next acc - in - loop seq.next acc - -let fold_r f seq acc = - let rec loop curr acc = - if curr == seq then - acc - else - let node = node_of_seq curr in - if node.node_active then - loop node.node_prev (f node.node_data acc) - else - loop node.node_next acc - in - loop seq.prev acc diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_sequence.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt_sequence.mli deleted file mode 100644 index 7e60dc0..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_sequence.mli +++ /dev/null @@ -1,137 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_sequence - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Mutable sequence of elements *) - -(** A sequence is an object holding a list of elements which support - the following operations: - - - adding an element to the left or the right in time and space O(1) - - taking an element from the left or the right in time and space O(1) - - removing a previously added element from a sequence in time and space O(1) - - removing an element while the sequence is being transversed. -*) - -type 'a t - (** Type of a sequence holding values of type ['a] *) - -type 'a node - (** Type of a node holding one value of type ['a] in a sequence *) - -(** {6 Operation on nodes} *) - -val get : 'a node -> 'a - (** Returns the contents of a node *) - -val set : 'a node -> 'a -> unit - (** Change the contents of a node *) - -val remove : 'a node -> unit - (** Removes a node from the sequence it is part of. It does nothing - if the node has already been removed. *) - -(** {6 Operations on sequence} *) - -val create : unit -> 'a t - (** [create ()] creates a new empty sequence *) - -val is_empty : 'a t -> bool - (** Returns [true] iff the given sequence is empty *) - -val length : 'a t -> int - (** Returns the number of elemenets in the given sequence. This is a - O(n) operation where [n] is the number of elements in the - sequence. *) - -val add_l : 'a -> 'a t -> 'a node - (** [add_l x s] adds [x] to the left of the sequence [s] *) - -val add_r : 'a -> 'a t -> 'a node - (** [add_l x s] adds [x] to the right of the sequence [s] *) - -exception Empty - (** Exception raised by [take_l] and [tale_s] and when the sequence - is empty *) - -val take_l : 'a t -> 'a - (** [take_l x s] remove and returns the leftmost element of [s] - - @raise Empty if the sequence is empty *) - -val take_r : 'a t -> 'a - (** [take_l x s] remove and returns the rightmost element of [s] - - @raise Empty if the sequence is empty *) - -val take_opt_l : 'a t -> 'a option - (** [take_opt_l x s] remove and returns [Some x] where [x] is the - leftmost element of [s] or [None] if [s] is empty *) - -val take_opt_r : 'a t -> 'a option - (** [take_opt_l x s] remove and returns [Some x] where [x] is the - rightmost element of [s] or [None] if [s] is empty *) - -val transfer_l : 'a t -> 'a t -> unit - (** [transfer_l s1 s2] removes all elements of [s1] and add them at - the left of [s2]. This operation runs in constant time and - space. *) - -val transfer_r : 'a t -> 'a t -> unit - (** [transfer_r s1 s2] removes all elements of [s1] and add them at - the right of [s2]. This operation runs in constant time and - space. *) - -(** {6 Sequence iterators} *) - -(** Note: it is OK to remove a node while traversing a sequence *) - -val iter_l : ('a -> unit) -> 'a t -> unit - (** [iter_l f s] applies [f] on all elements of [s] starting from - the left *) - -val iter_r : ('a -> unit) -> 'a t -> unit - (** [iter_l f s] applies [f] on all elements of [s] starting from - the right *) - -val iter_node_l : ('a node -> unit) -> 'a t -> unit - (** [iter_l f s] applies [f] on all nodes of [s] starting from - the left *) - -val iter_node_r : ('a node -> unit) -> 'a t -> unit - (** [iter_l f s] applies [f] on all nodes of [s] starting from - the right *) - -val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** [fold_l f s] is: - {[ - fold_l f s x = f en (... (f e2 (f e1 x))) - ]} - where [e1], [e2], ..., [en] are the elements of [s] - *) - -val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** [fold_r f s] is: - {[ - fold_r f s x = f e1 (f e2 (... (f en x))) - ]} - where [e1], [e2], ..., [en] are the elements of [s] - *) diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_stream.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt_stream.ml deleted file mode 100644 index 270d529..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_stream.ml +++ /dev/null @@ -1,759 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_stream - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt - -exception Empty - -type 'a t = { - next : unit -> 'a option Lwt.t; - (* The source of the stream *) - queue : 'a option Queue.t; - (* Queue of pending elements, which are not yet consumed *) - clones : 'a option Queue.t Weak.t ref; - (* List of queues of all clones of this event (including this - event) *) - mutex : Lwt_mutex.t; - (* Mutex to prevent concurrent access to [next] *) -} - -let add_clone wa q = - let len = Weak.length !wa in - (* loop search for a free cell in [wa] and fill it with [q]: *) - let rec loop i = - if i = len then begin - (* Growing *) - let clones = Weak.create (len + 1) in - Weak.blit !wa 0 clones 0 len; - wa := clones; - Weak.set clones len (Some q) - end else if Weak.check !wa i then - loop (i + 1) - else - Weak.set !wa i (Some q) - in - loop 0 - -let clone s = - let s' = { - next = s.next; - queue = Queue.copy s.queue; - clones = s.clones; - mutex = s.mutex; - } in - add_clone s'.clones s'.queue; - s' - -let from f = - let s = { - next = f; - queue = Queue.create (); - clones = ref(Weak.create 1); - mutex = Lwt_mutex.create (); - } in - Weak.set !(s.clones) 0 (Some s.queue); - s - -let of_list l = - let l = ref l in - from (fun () -> - match !l with - | [] -> return None - | x :: l' -> l := l'; return (Some x)) - -let of_array a = - let len = Array.length a and i = ref 0 in - from (fun () -> - if !i = len then - return None - else begin - let c = Array.unsafe_get a !i in - incr i; - return (Some c) - end) - -let of_string s = - let len = String.length s and i = ref 0 in - from (fun () -> - if !i = len then - return None - else begin - let c = String.unsafe_get s !i in - incr i; - return (Some c) - end) - -module EQueue : -sig - type 'a t - val create : unit -> 'a t * ('a option -> unit) - val pop : 'a t -> 'a option Lwt.t -end = -struct - type 'a state = - | No_mail - | Waiting of 'a option Lwt.u - | Full of 'a option Queue.t - - type 'a t = { - mutable state : 'a state; - } - - let create () = - let box = { state = No_mail } in - let weak_box = Weak.create 1 in - Weak.set weak_box 0 (Some box); - let push v = - match Weak.get weak_box 0 with - | None -> () - | Some box -> - match box.state with - | No_mail -> - let q = Queue.create () in - Queue.push v q; - box.state <- Full q - | Waiting wakener -> - box.state <- No_mail; - wakeup_later wakener v - | Full q -> - Queue.push v q - in - (box, push) - - let pop b = match b.state with - | No_mail -> - let waiter, wakener = task () in - Lwt.on_cancel waiter (fun () -> b.state <- No_mail); - b.state <- Waiting wakener; - waiter - | Waiting _ -> - (* Calls to next are serialized, so this case will never - happened *) - assert false - | Full q -> - let v = Queue.take q in - if Queue.is_empty q then b.state <- No_mail; - return v -end - -let create () = - let box, push = EQueue.create () in - (from (fun () -> EQueue.pop box), push) - -let push_clones wa x = - for i = 0 to Weak.length wa - 1 do - match Weak.get wa i with - | Some q -> - Queue.push x q - | None -> - () - done - -let peek s = - if Queue.is_empty s.queue then - Lwt_mutex.with_lock s.mutex begin fun () -> - if Queue.is_empty s.queue then begin - lwt result = s.next () in - push_clones !(s.clones) result; - return result - end else - return (Queue.top s.queue) - end - else - return (Queue.top s.queue) - -let rec force n s = - if Queue.length s.queue >= n then - return () - else - Lwt_mutex.with_lock s.mutex begin fun () -> - if Queue.length s.queue >= n then - return false - else begin - lwt result = s.next () in - push_clones !(s.clones) result; - if result = None then - return false - else - return true - end - end >>= function - | true -> - force n s - | false -> - return () - -let npeek n s = - lwt () = force n s in - let l, _ = - Queue.fold - (fun (l, n) x -> - if n > 0 then - match x with - | Some x -> (x :: l, n - 1) - | None -> (l, n) - else - (l, n)) - ([], n) s.queue - in - return (List.rev l) - -let rec get s = - if Queue.is_empty s.queue then - Lwt_mutex.with_lock s.mutex begin fun () -> - if Queue.is_empty s.queue then begin - lwt x = s.next () in - (* This prevent from calling s.next when the stream has - terminated: *) - if x = None then Queue.push None s.queue; - let wa = !(s.clones) in - for i = 0 to Weak.length wa - 1 do - match Weak.get wa i with - | Some q when q != s.queue -> - Queue.push x q - | _ -> - () - done; - return x - end else begin - let x = Queue.take s.queue in - if x = None then Queue.push None s.queue; - return x - end - end - else begin - let x = Queue.take s.queue in - if x = None then Queue.push None s.queue; - return x - end - -let nget n s = - let rec loop n = - if n <= 0 then - return [] - else - get s >>= function - | Some x -> - lwt l = loop (n - 1) in - return (x :: l) - | None -> - return [] - in - loop n - -let get_while f s = - let rec loop () = - peek s >>= function - | Some x -> - let test = f x in - if test then begin - ignore (Queue.take s.queue); - lwt l = loop () in - return (x :: l) - end else - return [] - | None -> - return [] - in - loop () - -let get_while_s f s = - let rec loop () = - peek s >>= function - | Some x -> - lwt test = f x in - if test then begin - ignore (Queue.take s.queue); - lwt l = loop () in - return (x :: l) - end else - return [] - | None -> - return [] - in - loop () - -let next s = get s >>= function - | Some x -> return x - | None -> raise_lwt Empty - -let last_new s = - match Lwt.state (peek s) with - | Return None -> - raise_lwt Empty - | Sleep -> - next s - | Fail exn -> - raise_lwt exn - | Return(Some x) -> - let _ = Queue.take s.queue in - let rec loop last = - match Lwt.state (peek s) with - | Sleep | Return None -> - return last - | Return(Some x) -> - let _ = Queue.take s.queue in - loop x - | Fail exn -> - raise_lwt exn - in - loop x - -let to_list s = - let rec loop () = - get s >>= function - | Some x -> - lwt l = loop () in - return (x :: l) - | None -> - return [] - in - loop () - -let to_string s = - let buf = Buffer.create 42 in - let rec loop () = - get s >>= function - | Some x -> - Buffer.add_char buf x; - loop () - | None -> - return (Buffer.contents buf) - in - loop () - -let junk s = - lwt _ = get s in - return () - -let njunk n s = - let rec loop n = - if n <= 0 then - return () - else - lwt _ = get s in - loop (n - 1) - in - loop n - -let junk_while f s = - let rec loop () = - peek s >>= function - | Some x -> - let test = f x in - if test then begin - ignore (Queue.take s.queue); - loop () - end else - return () - | None -> - return () - in - loop () - -let junk_while_s f s = - let rec loop () = - peek s >>= function - | Some x -> - lwt test = f x in - if test then begin - ignore (Queue.take s.queue); - loop () - end else - return () - | None -> - return () - in - loop () - -let junk_old s = - let rec loop () = - match Lwt.state (peek s) with - | Sleep -> - return () - | _ -> - ignore (Queue.take s.queue); - loop () - in - loop () - -let get_available s = - let rec loop () = - match Lwt.state (peek s) with - | Sleep | Return None -> - [] - | Return(Some x) -> - ignore (Queue.take s.queue); - x :: loop () - | Fail exn -> - raise exn - in - loop () - -let get_available_up_to n s = - let rec loop = function - | 0 -> - [] - | n -> - match Lwt.state (peek s) with - | Sleep | Return None -> - [] - | Return(Some x) -> - ignore (Queue.take s.queue); - x :: loop (n - 1) - | Fail exn -> - raise exn - in - loop n - -let is_empty s = peek s >|= fun x -> x = None - -let map f s = - from (fun () -> get s >>= function - | Some x -> - let x = f x in - return (Some x) - | None -> - return None) - -let map_s f s = - from (fun () -> get s >>= function - | Some x -> - lwt x = f x in - return (Some x) - | None -> - return None) - -let filter f s = - let rec next () = - get s >>= function - | Some x as result -> - let test = f x in - if test then - return result - else - next () - | None -> - return None - in - from next - -let filter_s f s = - let rec next () = - get s >>= function - | Some x as result -> - lwt test = f x in - if test then - return result - else - next () - | None -> - return None - in - from next - -let filter_map f s = - let rec next () = - get s >>= function - | Some x -> - let x = f x in - (match x with - | Some _ -> - return x - | None -> - next ()) - | None -> - return None - in - from next - -let filter_map_s f s = - let rec next () = - get s >>= function - | Some x -> - lwt x = f x in - (match x with - | Some _ -> - return x - | None -> - next ()) - | None -> - return None - in - from next - -let map_list f s = - let pendings = ref [] in - let rec next () = - match !pendings with - | [] -> - get s >>= (function - | Some x -> - let l = f x in - pendings := l; - next () - | None -> - return None) - | x :: l -> - pendings := l; - return (Some x) - in - from next - -let map_list_s f s = - let pendings = ref [] in - let rec next () = - match !pendings with - | [] -> - get s >>= (function - | Some x -> - lwt l = f x in - pendings := l; - next () - | None -> - return None) - | x :: l -> - pendings := l; - return (Some x) - in - from next - -let flatten s = - map_list (fun l -> l) s - -let fold f s acc = - let rec loop acc = - get s >>= function - | Some x -> - let acc = f x acc in - loop acc - | None -> - return acc - in - loop acc - -let fold_s f s acc = - let rec loop acc = - get s >>= function - | Some x -> - lwt acc = f x acc in - loop acc - | None -> - return acc - in - loop acc - -let iter f s = - let rec loop () = - get s >>= function - | Some x -> - let () = f x in - loop () - | None -> - return () - in - loop () - -let iter_s f s = - let rec loop () = - get s >>= function - | Some x -> - lwt () = f x in - loop () - | None -> - return () - in - loop () - -let iter_p f s = - let rec loop () = - get s >>= function - | Some x -> - f x <&> loop () - | None -> - return () - in - loop () - -let find f s = - let rec loop () = - get s >>= function - | Some x as result -> - let test = f x in - if test then - return result - else - loop () - | None -> - return None - in - loop () - -let find_s f s = - let rec loop () = - get s >>= function - | Some x as result -> - lwt test = f x in - if test then - return result - else - loop () - | None -> - return None - in - loop () - -let rec find_map f s = - let rec loop () = - get s >>= function - | Some x -> - let x = f x in - (match x with - | Some _ -> - return x - | None -> - loop ()) - | None -> - return None - in - loop () - -let rec find_map_s f s = - let rec loop () = - get s >>= function - | Some x -> - lwt x = f x in - (match x with - | Some _ -> - return x - | None -> - loop ()) - | None -> - return None - in - loop () - -let rec combine s1 s2 = - let next () = - lwt n1 = get s1 and n2 = get s2 in - match n1, n2 with - | Some x1, Some x2 -> - return (Some(x1, x2)) - | _ -> - return None - in - from next - -let append s1 s2 = - let current_s = ref s1 and s1_finished = ref false in - let rec next () = - get !current_s >>= function - | Some _ as result -> - return result - | None -> - if !s1_finished then - return None - else begin - s1_finished := true; - current_s := s2; - next () - end - in - from next - -let concat s_top = - let current_s = ref(from(fun () -> return None)) in - let rec next () = - get !current_s >>= function - | Some _ as result -> - return result - | None -> - get s_top >>= function - | Some s -> - current_s := s; - next () - | None -> - return None - in - from next - -let choose streams = - let source s = (s, peek s >|= fun x -> (s, x)) in - let streams = ref (List.rev_map source streams) in - let rec next () = - match !streams with - | [] -> - return None - | l -> - lwt s, x = Lwt.choose (List.map snd l) in - let l = List.remove_assq s l in - match x with - | Some _ -> - lwt () = junk s in - streams := source s :: l; - return x - | None -> - next () - in - from next - -let parse s f = - let s' = clone s in - try_lwt - f s - with exn -> - Queue.clear s.queue; - Queue.transfer s'.queue s.queue; - raise_lwt exn - -let hexdump stream = - let buf = Buffer.create 80 and num = ref 0 in - from begin fun _ -> - nget 16 stream >>= function - | [] -> - return None - | l -> - Buffer.clear buf; - Printf.bprintf buf "%08x| " !num; - num := !num + 16; - let rec bytes pos = function - | [] -> - blanks pos - | x :: l -> - if pos = 8 then Buffer.add_char buf ' '; - Printf.bprintf buf "%02x " (Char.code x); - bytes (pos + 1) l - and blanks pos = - if pos < 16 then begin - if pos = 8 then - Buffer.add_string buf " " - else - Buffer.add_string buf " "; - blanks (pos + 1) - end - in - bytes 0 l; - Buffer.add_string buf " |"; - List.iter (fun ch -> Buffer.add_char buf (if ch >= '\x20' && ch <= '\x7e' then ch else '.')) l; - Buffer.add_char buf '|'; - return (Some(Buffer.contents buf)) - end diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_stream.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt_stream.mli deleted file mode 100644 index dfefbf4..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_stream.mli +++ /dev/null @@ -1,242 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_stream - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Data streams *) - -type 'a t - (** Type of a stream holding values of type ['a] *) - -(** Naming convention: in this module all function taking a function - which is applied to all element of the streams are suffixed by: - - - [_s] when the function returns a thread and calls are serialised - - [_p] when the function returns a thread and calls are parallelised -*) - -(** {6 Construction} *) - -val from : (unit -> 'a option Lwt.t) -> 'a t - (** [from f] creates an stream from the given input function. [f] is - called each time more input is needed, and the stream ends when - [f] returns [None]. *) - -val create : unit -> 'a t * ('a option -> unit) - (** [create ()] returns a new stream and a push function *) - -val of_list : 'a list -> 'a t - (** [of_list l] creates a stream returning all elements of [l] *) - -val of_array : 'a array -> 'a t - (** [of_array a] creates a stream returning all elements of [a] *) - -val of_string : string -> char t - (** [of_string str] creates a stream returning all characters of - [str] *) - -val clone : 'a t -> 'a t - (** [clone st] clone the given stream. Operations on each stream - will not affect the other. - - For example: - - {[ - # let st1 = Lwt_stream.of_list [1; 2; 3];; - val st1 : int Lwt_stream.t = - # let st2 = Lwt_stream.clone st1;; - val st2 : int Lwt_stream.t = - # lwt x = Lwt_stream.next st1;; - val x : int = 1 - # lwt y = Lwt_stream.next st2;; - val y : int = 1 - ]} - *) - -(** {6 Destruction} *) - -val to_list : 'a t -> 'a list Lwt.t - (** Returns the list of elements of the given stream *) - -val to_string : char t -> string Lwt.t - (** Returns the word composed of all characters of the given - stream *) - -(** {6 Data retreival} *) - -exception Empty - (** Exception raised when trying to retreive data from an empty - stream. *) - -val peek : 'a t -> 'a option Lwt.t - (** [peek st] returns the first element of the stream, if any, - without removing it. *) - -val npeek : int -> 'a t -> 'a list Lwt.t - (** [npeek n st] returns at most the first [n] elements of [st], - without removing them. *) - -val get : 'a t -> 'a option Lwt.t - (** [get st] remove and returns the first element of the stream, if - any. *) - -val nget : int -> 'a t -> 'a list Lwt.t - (** [nget n st] remove and returns at most the first [n] elements of - [st]. *) - -val get_while : ('a -> bool) -> 'a t -> 'a list Lwt.t -val get_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a list Lwt.t - (** [get_while f st] returns the longest prefix of [st] where all - elements satisfy [f]. *) - -val next : 'a t -> 'a Lwt.t - (** [next st] remove and returns the next element of the stream, of - fail with {!Empty} if the stream is empty. *) - -val last_new : 'a t -> 'a Lwt.t - (** [next_new st] if no element are available on [st] without - sleeping, then it is the same as [next st]. Otherwise it removes - all elements of [st] that are ready except the last one, and - return it. - - If fails with {!Empty} if the stream has no more elements *) - -val junk : 'a t -> unit Lwt.t - (** [junk st] remove the first element of [st]. *) - -val njunk : int -> 'a t -> unit Lwt.t - (** [njunk n st] removes at most the first [n] elements of the - stream. *) - -val junk_while : ('a -> bool) -> 'a t -> unit Lwt.t -val junk_while_s : ('a -> bool Lwt.t) -> 'a t -> unit Lwt.t - (** [junk_while f st] removes all elements at the beginning of the - streams which satisfy [f]. *) - -val junk_old : 'a t -> unit Lwt.t - (** [junk_old st] removes all elements that are ready to be read - without yeilding from [st]. - - For example the [read_password] function of [Lwt_read_line] use - that to junk key previously typed by the user. - *) - -val get_available : 'a t -> 'a list - (** [get_available l] returns all available elements of [l] without - blocking *) - -val get_available_up_to : int -> 'a t -> 'a list - (** [get_available_up_to l n] returns up to [n] elements of [l] - without blocking *) - -val is_empty : 'a t -> bool Lwt.t - (** [is_empty enum] returns wether the given stream is empty *) - -(** {6 Stream transversal} *) - -(** Note: all the following functions are destructive. - - For example: - - {[ - # let st1 = Lwt_stream.of_list [1; 2; 3];; - val st1 : int Lwt_stream.t = - # let st2 = Lwt_stream.map string_of_int st1;; - val st2 : string Lwt_stream.t = - # lwt x = Lwt_stream.next st1;; - val x : int = 1 - # lwt y = Lwt_stream.next st2;; - val y : string = "2" - ]} -*) - -val choose : 'a t list -> 'a t - (** [choose l] creates an stream from a list of streams. The - resulting stream will returns elements returned by any stream of - [l] in an unspecified order. *) - -val map : ('a -> 'b) -> 'a t -> 'b t -val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t - (** [map f st] maps the value returned by [st] with [f] *) - -val filter : ('a -> bool) -> 'a t -> 'a t -val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t - (** [filter f st] keeps only value [x] such that [f x] is [true] *) - -val filter_map : ('a -> 'b option) -> 'a t -> 'b t -val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t - (** [filter_map f st] filter and map [st] at the same time *) - -val map_list : ('a -> 'b list) -> 'a t -> 'b t -val map_list_s : ('a -> 'b list Lwt.t) -> 'a t -> 'b t - (** [map_list f st] applies [f] on each element of [st] and flattens - the lists returned *) - -val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b Lwt.t -val fold_s : ('a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t - (** [fold f s x] fold_like function for streams. *) - -val iter : ('a -> unit) -> 'a t -> unit Lwt.t -val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t -val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - (** [iter f s] iterates over all elements of the stream *) - -val find : ('a -> bool) -> 'a t -> 'a option Lwt.t -val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t - (** [find f s] find an element in a stream. *) - -val find_map : ('a -> 'b option) -> 'a t -> 'b option Lwt.t -val find_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b option Lwt.t - (** [find f s] find and map at the same time. *) - -val combine : 'a t -> 'b t -> ('a * 'b) t - (** [combine s1 s2] combine two streams. The stream will ends when - the first stream ends. *) - -val append : 'a t -> 'a t -> 'a t - (** [append s1 s2] returns a stream which returns all elements of - [s1], then all elements of [s2] *) - -val concat : 'a t t -> 'a t - (** [concat st] returns the concatenation of all streams of [st]. *) - -val flatten : 'a list t -> 'a t - (** [flatten st = map_list (fun l -> l) st] *) - -(** {6 Parsing} *) - -val parse : 'a t -> ('a t -> 'b Lwt.t) -> 'b Lwt.t - (** [parse st f] parses [st] with [f]. If [f] raise an exception, - [st] is restored to its previous state. *) - -(** {6 Misc} *) - -val hexdump : char t -> string t - (** [hexdump byte_stream] returns a stream which is the same as the - output of [hexdump -C]. - - Basically, here is a simple implementation of [hexdump -C]: - - {[ - open Lwt - open Lwt_io - let () = Lwt_main.run (write_lines stdout (Lwt_stream.hexdump (read_lines stdin))) - ]} - *) diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_switch.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt_switch.ml deleted file mode 100644 index 150ed11..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_switch.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_switch - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt - -exception Off - -type on_switch = { - mutable hooks : (unit -> unit Lwt.t) list; -} - -type state = - | St_on of on_switch - | St_off - -type t = { mutable state : state } - -let create () = { state = St_on { hooks = [] } } - -let is_on switch = - match switch.state with - | St_on _ -> true - | St_off -> false - -let check = function - | Some{ state = St_off } -> raise Off - | _ -> () - -let add_hook switch hook = - match switch with - | Some{ state = St_on os } -> - os.hooks <- hook :: os.hooks - | Some{ state = St_off } -> - raise Off - | None -> - () - -let add_hook_or_exec switch hook = - match switch with - | Some{ state = St_on os } -> - os.hooks <- hook :: os.hooks; - return () - | Some{ state = St_off } -> - hook () - | None -> - return () - -let turn_off switch = - match switch.state with - | St_on { hooks = hooks } -> - switch.state <- St_off; - Lwt_list.iter_p (fun hook -> apply hook ()) hooks - | St_off -> - return () diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_switch.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt_switch.mli deleted file mode 100644 index 8a8431c..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_switch.mli +++ /dev/null @@ -1,111 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_switch - * Copyright (C) 2010 Jérémiem Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Lwt switches *) - -(** Switch have two goals: - - - being able to free multiple resources at the same time, - - offer a better alternative than always returning an id to free - some resource. - - For example, considers the following interface: - - {[ - type id - - val free : id -> unit Lwt.t - - val f : unit -> id Lwt.t - val g : unit -> id Lwt.t - val h : unit -> id Lwt.t - ]} - - Now you want to calls [f], [g] and [h] in parallel. You can - simply do: - - {[ - lwt idf = f () and idg = g () and idh = h () in - ... - ]} - - However, one may wants to handle possible failures of [f ()], [g - ()] and [h ()], and disable all allocated resources if one of - these three threads fails. This may be hard since you have to - remember which one failed and which one returned correctly. - - Now we change a little bit the interface: - - {[ - val f : ?switch : Lwt_switch.t -> unit -> id Lwt.t - val g : ?switch : Lwt_switch.t -> unit -> id Lwt.t - val h : ?switch : Lwt_switch.t -> unit -> id Lwt.t - ]} - - and the code becomes: - - {[ - let switch = Lwt_switch.create () in - try_lwt - lwt idf = f ~switch () and idg = g ~switch () and idh = h ~switch () in - ... - with exn -> - lwt () = Lwt_switch.turn_off switch in - raise_lwt exn - ]} -*) - -type t - (** Type of switches. *) - -val create : unit -> t - (** [create ()] creates a new switch. *) - -val is_on : t -> bool - (** [is_on switch] returns [true] if the switch is currently on, and - [false] otherwise. *) - -val turn_off : t -> unit Lwt.t - (** [turn_off switch] turns off the switch. It calls all registered - hooks, waits for all of them to terminates, and the returns. If - one of the hook failed, then it will fail with one of the - exception raised by hooks. If the switch is already off, then it - does nothing. *) - -exception Off - (** Exception raised when trying to add a hook to a switch that is - already off. *) - -val check : t option -> unit - (** [check switch] does nothing if [switch] is [None] or contains an - switch that is currently on, and raise {!Off} otherwise. *) - -val add_hook : t option -> (unit -> unit Lwt.t) -> unit - (** [add_hook switch f] registers [f] so it will be called when - {!turn_off} is invoked. It does nothing if [switch] is - [None]. If [switch] contains an switch that is already off then - {!Off} is raised. *) - -val add_hook_or_exec : t option -> (unit -> unit Lwt.t) -> unit Lwt.t - (** [add_hook_or_exec switch f] is the same as {!add_hook} except - that if the switch is already off, then [f] is called - immediatly. *) diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_util.ml b/server/thirdparty/lwt-2.3.2/src/core/lwt_util.ml deleted file mode 100644 index 5669755..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_util.ml +++ /dev/null @@ -1,117 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_util - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt - -let rec iter f l = - let l = List.fold_left (fun acc a -> f a :: acc) [] l in - let l = List.rev l in - List.fold_left (fun rt t -> t >>= fun () -> rt) (Lwt.return ()) l - -let rec iter_serial f l = - match l with - [] -> return () - | a :: r -> f a >>= (fun () -> iter_serial f r) - -let rec map f l = - match l with - [] -> - return [] - | v :: r -> - let t = f v in - let rt = map f r in - t >>= (fun v' -> - rt >>= (fun l' -> - return (v' :: l'))) - -let map_with_waiting_action f wa l = - let rec loop l = - match l with - [] -> - return [] - | v :: r -> - let t = f v in - let rt = loop r in - t >>= (fun v' -> - (* Perform the specified "waiting action" for the next *) - (* item in the list. *) - if r <> [] then - wa (List.hd r) - else - (); - rt >>= (fun l' -> - return (v' :: l'))) - in - if l <> [] then - wa (List.hd l) - else - (); - loop l - -let rec map_serial f l = - match l with - [] -> - return [] - | v :: r -> - f v >>= (fun v' -> - map_serial f r >>= (fun l' -> - return (v' :: l'))) - -let rec fold_left f a = function - | [] -> return a - | b::l -> f a b >>= fun v -> fold_left f v l - -let join = Lwt.join - -type region = - { mutable size : int; - mutable count : int; - waiters : (unit Lwt.u * int) Queue.t } - -let make_region count = { size = count; count = 0; waiters = Queue.create () } - -let resize_region reg sz = reg.size <- sz - -let leave_region reg sz = - try - if reg.count - sz >= reg.size then raise Queue.Empty; - let (w, sz') = Queue.take reg.waiters in - reg.count <- reg.count - sz + sz'; - Lwt.wakeup_later w () - with Queue.Empty -> - reg.count <- reg.count - sz - -let run_in_region_1 reg sz thr = - (catch - (fun () -> thr () >>= (fun v -> leave_region reg sz; return v)) - (fun e -> leave_region reg sz; raise_lwt e)) - -let run_in_region reg sz thr = - if reg.count >= reg.size then begin - let (res, w) = wait () in - Queue.add (w, sz) reg.waiters; - res >>= (fun () -> run_in_region_1 reg sz thr) - end else begin - reg.count <- reg.count + sz; - run_in_region_1 reg sz thr - end diff --git a/server/thirdparty/lwt-2.3.2/src/core/lwt_util.mli b/server/thirdparty/lwt-2.3.2/src/core/lwt_util.mli deleted file mode 100644 index e296a4c..0000000 --- a/server/thirdparty/lwt-2.3.2/src/core/lwt_util.mli +++ /dev/null @@ -1,80 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_util - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Note: This lodule is deprecated. Use {!Lwt_list} and {!Lwt_pool} - instead. *) - -(** {2 Lists iterators} *) - -val iter : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t - (** [iter f l] start a thread for each element in [l]. The threads - are started according to the list order, but then can run - concurrently. It terminates when all the threads are - terminated, if all threads are successful. It fails if any of - the threads fail. *) - -val iter_serial : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t - (** Similar to [iter] but wait for one thread to terminate before - starting the next one. *) - -val map : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - (** [map f l] apply [f] to each element in [l] and collect the - results of the threads thus created. The threads are started - according to the list order, but then can run concurrently. - [map f l] fails if any of the threads fail. *) - -val map_with_waiting_action : - ('a -> 'b Lwt.t) -> ('a -> unit) -> 'a list -> 'b list Lwt.t - (** [map_with_waiting_action f wa l] apply [f] to each element - in [l] and collect the results of the threads thus created. - The threads are started according to the list order, but - then can run concurrently. The difference with [map f l] is - that function wa will be called on the element that the - function is waiting for its termination. *) - -val map_serial : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - (** Similar to [map] but wait for one thread to terminate before - starting the next one. *) - -val fold_left : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t - (** Similar to [List.fold_left]. *) - -(****) - -(** {2 Regions} *) - -type region - -val make_region : int -> region - (** [make_region sz] create a region of size [sz]. *) -val resize_region : region -> int -> unit - (** [resize_region reg sz] resize the region [reg] to size [sz]. *) -val run_in_region : region -> int -> (unit -> 'a Lwt.t) -> 'a Lwt.t - (** [run_in_region reg size f] execute the thread produced by the - function [f] in the region [reg]. The thread is not started - before some room is available in the region. *) - -(**/**) - -val join : unit Lwt.t list -> unit Lwt.t - (** Same as [Lwt.join] *) diff --git a/server/thirdparty/lwt-2.3.2/src/extra/lwt-extra.mllib b/server/thirdparty/lwt-2.3.2/src/extra/lwt-extra.mllib deleted file mode 100644 index 8171343..0000000 --- a/server/thirdparty/lwt-2.3.2/src/extra/lwt-extra.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 73d5d5d814da6fce812bc449a2dcd20c) -Lwt_lib -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/extra/lwt_lib.ml b/server/thirdparty/lwt-2.3.2/src/extra/lwt_lib.ml deleted file mode 100644 index ae30526..0000000 --- a/server/thirdparty/lwt-2.3.2/src/extra/lwt_lib.ml +++ /dev/null @@ -1,134 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * lwt_lib.ml Copyright (C) 2007 Pierre Clairambault - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later version. - * See COPYING file for details. - * - * 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -open Weak -open Unix -open Lwt - -let switch_time = 30. - -exception Not_in_table -(* We use a specific Not_in_table exception, because since we're caching - * threads, we can't for the moment behave differently whether a request - * is not found in the table or not found as a host.*) - - -module WeakHashtbl = Make( - struct - type t = string * (Unix.host_entry Lwt.t) * float - let equal = (fun (a,b,c) -> fun (a',b',c') -> a=a') - let hash = fun (a,b,c) -> Hashtbl.hash a - end -) - -open WeakHashtbl - -let keeper : (((string*(Unix.host_entry Lwt.t)*float) list) * - ((string*(Unix.host_entry Lwt.t)*float) list)) ref = ref ([],[]) -let cache = create 0 -let dummy_addr : Unix.host_entry = - {h_name="dummy"; - h_aliases=[||]; - h_addrtype=Unix.PF_INET; - h_addr_list = [||]} - -let cache_find d = try - match (find cache (d,return dummy_addr,0.)) with (_,h,t) -> (h,t) - with - |Not_found -> raise Not_in_table - |e -> raise e - -let gethostbyname d = - Lwt.catch - (fun _ -> - let (h,t) = cache_find d - and t' = Unix.time () in - match (t'>t+.60.) with - | true -> - (remove cache) (d,h,t); - raise_lwt Not_in_table - | false -> h) - (function - | Not_in_table -> - let t = Unix.time() and - h = Lwt_preemptive.detach Unix.gethostbyname d in - let entry = (d,h,t) in - add cache entry; - (match !keeper with (a,b) -> keeper:= (entry::a,b)); - h - | e -> raise_lwt e) -(* Begin getaddrinfo caching *) - - -module WeakAddrInfo = Make( - struct - type t = string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float - let equal = (fun (h,s,o,i,t) -> fun (h',s',o',i',t') -> (h,s,o)=(h',s',o')) - let hash = fun (h,s,o,i,t) -> Hashtbl.hash (h,s,o) - end -) - -let keeper6 : (((string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float) list) * - ((string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float) list)) ref = ref - ([],[]) - -let switch_thread : unit Lwt.t= - let rec switch_worker () = - Lwt_unix.sleep switch_time >>= fun () -> - (match !keeper with (a,b) -> keeper:=([],a)); - (match !keeper6 with (a,b) -> keeper6:=([],a)); - switch_worker () - in - switch_worker() - -let cache6 = WeakAddrInfo.create 0 - -let cache_find6 d s o = try - match (WeakAddrInfo.find cache6 (d,s,o,return [],0.)) with (_,_,_,i,t) -> (i,t) - with - |Not_found -> raise Not_in_table - |e -> raise e - - -let getaddrinfo d s o = - Lwt.catch - (fun _ -> - let (i,t) = cache_find6 d s o - and t' = Unix.time() in - match (t'>t+.60.) with - | true -> - WeakAddrInfo.remove cache6 (d,s,o,i,t); - raise_lwt Not_in_table - | false -> i) - (function - | Not_in_table -> - let t = Unix.time () and - i = Lwt_preemptive.detach (Unix.getaddrinfo d s) o in - let entry = (d,s,o,i,t) in - WeakAddrInfo.add cache6 entry; - (match !keeper6 with (a,b) -> keeper6 := (entry::a,b)); - i - | e -> raise_lwt e) - - -let getnameinfo s l = - (*VVV implmenter !!! *) - Lwt_preemptive.detach (Unix.getnameinfo s) l diff --git a/server/thirdparty/lwt-2.3.2/src/extra/lwt_lib.mli b/server/thirdparty/lwt-2.3.2/src/extra/lwt_lib.mli deleted file mode 100644 index 7f48007..0000000 --- a/server/thirdparty/lwt-2.3.2/src/extra/lwt_lib.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * lwt_lib.mli Copyright (C) 2007 Pierre Clairambault - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later version. - * See COPYING file for details. - * - * 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -(** Cooperative unix system calls *) - -(** This module transform non-cooperative functions of the standard - library into cooperative ones by launching them into system - threads. - - Indeed, lots of functions of the [Unix] modules, corresponding to - functions of the standard C library may take times to - complete. For example [gethostbyname] may use DNS resolution, - users informations may be stored in a ldap database, ... - - Since these functions are implemented (in the standard C library) - using blocking IOs, if you use them directly, you program may - hang. *) - -val getaddrinfo : string -> string -> Unix.getaddrinfo_option list -> Unix.addr_info list Lwt.t - (** Cooperative getaddrinfo with cache (using Lwt_preemptive.detach) *) - -val gethostbyname : string -> Unix.host_entry Lwt.t - (** Cooperative gethostbyname with cache (using Lwt_preemptive.detach) *) - -val getnameinfo : Unix.sockaddr -> Unix.getnameinfo_option list -> Unix.name_info Lwt.t - (** Cooperative getnameinfo with cache (using Lwt_preemptive.detach) *) diff --git a/server/thirdparty/lwt-2.3.2/src/glib/liblwt-glib.clib b/server/thirdparty/lwt-2.3.2/src/glib/liblwt-glib.clib deleted file mode 100644 index d26011b..0000000 --- a/server/thirdparty/lwt-2.3.2/src/glib/liblwt-glib.clib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 905c14a6abfdc3cc49bbc233df66ff99) -lwt_glib_stubs.o -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/glib/lwt-glib.mllib b/server/thirdparty/lwt-2.3.2/src/glib/lwt-glib.mllib deleted file mode 100644 index f99b29f..0000000 --- a/server/thirdparty/lwt-2.3.2/src/glib/lwt-glib.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: dfe8b7bfa132aa66ad19dbdbf3bcbaaa) -Lwt_glib -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/glib/lwt_glib.ml b/server/thirdparty/lwt-2.3.2/src/glib/lwt_glib.ml deleted file mode 100644 index 0196e29..0000000 --- a/server/thirdparty/lwt-2.3.2/src/glib/lwt_glib.ml +++ /dev/null @@ -1,132 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module glib - * Copyright (C) 2009-2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -type source = { - fd : Unix.file_descr; - check_readable : bool; - check_writable : bool; -} - -external glib_init : unit -> unit = "lwt_glib_init" -external glib_stop : unit -> unit = "lwt_glib_stop" - -type state = - | State_none - | State_glib_into_lwt of (unit -> unit) Lwt_sequence.node * (unit -> unit) Lwt_sequence.node - | State_lwt_into_glib of Lwt_engine.t - -let state = ref State_none - -(* +-----------------------------------------------------------------+ - | Glib-based engine | - +-----------------------------------------------------------------+ *) - -external glib_poll : (Unix.file_descr * bool * bool) list -> int -> int -> (Unix.file_descr * bool * bool) list = "lwt_glib_poll" - -class engine = object - inherit Lwt_engine.poll_based - method private poll fds timeout = glib_poll fds (List.length fds) (truncate (timeout *. 1000.)) -end - -(* +-----------------------------------------------------------------+ - | Glib --> Lwt based integration | - +-----------------------------------------------------------------+ *) - -external glib_get_sources : unit -> source array * float = "lwt_glib_get_sources" -external glib_check : unit -> unit = "lwt_glib_check" -external glib_mark_readable : int -> unit = "lwt_glib_mark_readable" "noalloc" -external glib_mark_writable : int -> unit = "lwt_glib_mark_readable" "noalloc" - -let events = ref [] -let check = ref true - -let enter () = - if !check then begin - check := false; - let engine = Lwt_engine.get () in - assert (!events = []); - let sources, timeout = glib_get_sources () in - for i = 0 to Array.length sources - 1 do - let src = sources.(i) in - if src.check_readable then - events := engine#on_readable src.fd (fun _ -> glib_mark_readable i) :: !events; - if src.check_writable then - events := engine#on_writable src.fd (fun _ -> glib_mark_writable i) :: !events - done; - if timeout = 0. then - ignore (Lwt_main.yield ()) - else if timeout > 0. then - events := engine#on_timer timeout false ignore :: !events - end - -let leave () = - if not !check then begin - check := true; - List.iter Lwt_engine.stop_event !events; - events := []; - glib_check () - end - -(* +-----------------------------------------------------------------+ - | Installation/removal | - +-----------------------------------------------------------------+ *) - -let install ?mode () = - match !state with - | State_lwt_into_glib _ | State_glib_into_lwt _ -> - () - | State_none -> - let mode = - match mode with - | Some mode -> mode - | None -> if Lwt_sys.windows then `lwt_into_glib else `glib_into_lwt - in - glib_init (); - match mode with - | `glib_into_lwt -> - state := State_glib_into_lwt(Lwt_sequence.add_l enter Lwt_main.enter_iter_hooks, - Lwt_sequence.add_l leave Lwt_main.leave_iter_hooks) - | `lwt_into_glib -> - let engine = Lwt_engine.get () in - Lwt_engine.set ~destroy:false (new engine); - state := State_lwt_into_glib engine - -let remove () = - match !state with - | State_none -> - () - | State_glib_into_lwt(node_enter, node_leave) -> - state := State_none; - Lwt_sequence.remove node_enter; - Lwt_sequence.remove node_leave; - List.iter Lwt_engine.stop_event !events; - events := []; - glib_stop () - | State_lwt_into_glib engine -> - Lwt_engine.set engine - -(* +-----------------------------------------------------------------+ - | Misc | - +-----------------------------------------------------------------+ *) - -external iter : bool -> unit = "lwt_glib_iter" -external wakeup : unit -> unit = "lwt_glib_wakeup" diff --git a/server/thirdparty/lwt-2.3.2/src/glib/lwt_glib.mli b/server/thirdparty/lwt-2.3.2/src/glib/lwt_glib.mli deleted file mode 100644 index 5d97b09..0000000 --- a/server/thirdparty/lwt-2.3.2/src/glib/lwt_glib.mli +++ /dev/null @@ -1,103 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_glib - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Glib integration *) - -(** This module allow to use Lwt in GTK applications. - - Here is what you have to do to make Lwt and GTK work together: - - call {!install} at the beginning of your program (before or - after GMain.init, it does not matter) - - do not call GMain.main, write your application as a normal Lwt - application instead. - - For example: - - {[ - let () = Lwt_main.run ( - (* Initializes GTK. *) - ignore (GMain.init ()); - - (* Install Lwt<->Glib integration. *) - Lwt_glib.install (); - - (* Thread which is wakeup when the main window is closed. *) - let waiter, wakener = Lwt.wait () in - - (* Create a window. *) - let window = GWindow.window () in - - (* Display something inside the window. *) - ignore (GMisc.label ~text:"Hello, world!" ~packing:window#add ()); - - (* Quit when the window is closed. *) - ignore (window#connect#destroy (Lwt.wakeup wakener)); - - (* Show the window. *) - window#show (); - - (* Wait for it to be closed. *) - waiter - ) - ]} - *) - -val install : ?mode : [ `glib_into_lwt | `lwt_into_glib ] -> unit -> unit - (** Install the Glib<->Lwt integration. - - If [mode] is [`glib_into_lwt] then glib will use the Lwt main - loop, and if [mode] is [`lwt_into_glib] then Lwt will use the - Glib main loop. - - The first mode is better but for some unknown reason it does not - work under Windows, so the second is used as default on Windows - while the first one is used as default on Unix. - - If the integration is already active, this function does - nothing. *) - -val remove : unit -> unit - (** Remove the Glib<->Lwt integration. *) - -val iter : bool -> unit - (** This function is not related to Lwt. [iter may_block] does the - same as [Glib.Main.iteration may_block] but can safely be called - in a multi-threaded program, it will not block the whole - program. - - For example: - - {[ - let main () = - while true do - Lwt_glib.iter true - done - - let thread = Thread.create main () - ]} - - Note: you can call this function only from one thread at a time, - otherwise it will raise [Failure]. *) - -val wakeup : unit -> unit - (** If one thread is blocking on {!iter}, then [wakeup ()] make - {!iter} to return immediatly. *) diff --git a/server/thirdparty/lwt-2.3.2/src/glib/lwt_glib_stubs.c b/server/thirdparty/lwt-2.3.2/src/glib/lwt_glib_stubs.c deleted file mode 100644 index d6318cb..0000000 --- a/server/thirdparty/lwt-2.3.2/src/glib/lwt_glib_stubs.c +++ /dev/null @@ -1,275 +0,0 @@ -/* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_glib_stubs - * Copyright (C) 2009-2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - */ - -#include -#include -#include -#include -#include -#include -#include -#include - -#include "../unix/lwt_unix.h" - -GMainContext *gc; -GPollFD *gpollfds = NULL; -gint fds_count = 0; -gint n_fds; -gint max_priority; - -/* +-----------------------------------------------------------------+ - | Polling | - +-----------------------------------------------------------------+ */ - -CAMLprim value lwt_glib_poll(value val_fds, value val_count, value val_timeout) -{ - gint timeout, lwt_timeout; - long count; - int i; - GPollFD *gpollfd; - gint events, revents; - - CAMLparam3(val_fds, val_count, val_timeout); - CAMLlocal5(node, src, node_result, src_result, tmp); - - count = Long_val(val_count); - - g_main_context_dispatch(gc); - g_main_context_prepare(gc, &max_priority); - - while (fds_count < count + (n_fds = g_main_context_query(gc, max_priority, &timeout, gpollfds, fds_count))) { - free(gpollfds); - fds_count = n_fds + count; - gpollfds = lwt_unix_malloc(fds_count * sizeof (GPollFD)); - } - - /* Clear all revents fields. */ - for (i = 0; i < n_fds + count; i++) gpollfds[i].revents = 0; - - /* Add all Lwt fds. */ - for (i = n_fds, node = val_fds; i < n_fds + count; i++, node = Field(node, 1)) { - src = Field(node, 0); - gpollfd = gpollfds + i; -#if defined(LWT_ON_WINDOWS) - gpollfd->fd = Handle_val(Field(src, 0)); -#else - gpollfd->fd = Int_val(Field(src, 0)); -#endif - events = 0; - if (Bool_val(Field(src, 1))) events |= G_IO_IN; - if (Bool_val(Field(src, 2))) events |= G_IO_OUT; - gpollfd->events = events; - } - - lwt_timeout = Int_val(val_timeout); - if (timeout < 0 || (lwt_timeout >= 0 && lwt_timeout < timeout)) - timeout = lwt_timeout; - - /* Do the blocking call. */ - g_main_context_get_poll_func(gc)(gpollfds, n_fds + count, timeout); - g_main_context_check(gc, max_priority, gpollfds, n_fds); - - /* Build the result. */ - node_result = Val_int(0); - for (i = n_fds, node = val_fds; i < n_fds + count; i++, node = Field(node, 1)) { - src_result = caml_alloc_tuple(3); - src = Field(node, 0); - Field(src_result, 0) = Field(src, 0); - revents = gpollfds[i].revents; - Field(src_result, 1) = Val_bool(revents & G_IO_IN); - Field(src_result, 2) = Val_bool(revents & G_IO_OUT); - tmp = caml_alloc_tuple(2); - Field(tmp, 0) = src_result; - Field(tmp, 1) = node_result; - node_result = tmp; - } - - CAMLreturn(node_result); -} - -/* +-----------------------------------------------------------------+ - | Get sources | - +-----------------------------------------------------------------+ */ - -#if defined(LWT_ON_WINDOWS) - -static value alloc_fd(HANDLE handle) -{ - value res = win_alloc_handle(handle); - int opt; - int optlen = sizeof(opt); - if (getsockopt((SOCKET)handle, SOL_SOCKET, SO_TYPE, (char *)&opt, &optlen) == 0) - Descr_kind_val(res) = KIND_SOCKET; - return res; -} - -#endif - -CAMLprim value lwt_glib_get_sources() -{ - gint timeout; - int i; - GPollFD *gpollfd; - - CAMLparam0(); - CAMLlocal4(fd, fds, src, result); - - g_main_context_dispatch(gc); - g_main_context_prepare(gc, &max_priority); - - while (fds_count < (n_fds = g_main_context_query(gc, max_priority, &timeout, gpollfds, fds_count))) { - free(gpollfds); - fds_count = n_fds; - gpollfds = lwt_unix_malloc(fds_count * sizeof (GPollFD)); - } - - fds = caml_alloc_tuple(n_fds); - for (i = 0; i < n_fds; i++) { - gpollfd = gpollfds + i; - gpollfd->revents = 0; - -#if defined(LWT_ON_WINDOWS) - /* On windows, glib file descriptors are handles */ - fd = alloc_fd((HANDLE)gpollfd->fd); -#else - fd = Val_int(gpollfd->fd); -#endif - - src = caml_alloc_tuple(3); - Field(src, 0) = fd; - Field(src, 1) = Val_bool(gpollfd->events & G_IO_IN); - Field(src, 2) = Val_bool(gpollfd->events & G_IO_OUT); - - Field(fds, i) = src; - } - - result = caml_alloc_tuple(2); - Store_field(result, 0, fds); - Store_field(result, 1, caml_copy_double(timeout * 1e-3)); - - CAMLreturn(result); -} - -/* +-----------------------------------------------------------------+ - | Marking | - +-----------------------------------------------------------------+ */ - -CAMLprim value lwt_glib_mark_readable(value i) -{ - gpollfds[Int_val(i)].revents |= G_IO_IN; - return Val_unit; -} - -CAMLprim value lwt_glib_mark_writable(value i) -{ - gpollfds[Int_val(i)].revents |= G_IO_OUT; - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | Check | - +-----------------------------------------------------------------+ */ - -CAMLprim value lwt_glib_check() -{ - g_main_context_check(gc, max_priority, gpollfds, n_fds); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | Initialization/stopping | - +-----------------------------------------------------------------+ */ - -CAMLprim value lwt_glib_init() -{ - gc = g_main_context_default(); - g_main_context_ref(gc); - return Val_unit; -} - -CAMLprim value lwt_glib_stop() -{ - g_main_context_unref(gc); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | Misc | - +-----------------------------------------------------------------+ */ - -CAMLprim value lwt_glib_iter(value may_block) -{ - GMainContext *gc; - gint max_priority, timeout; - GPollFD *pollfds = NULL; - gint pollfds_size = 0; - gint nfds; - gint i; - - /* Get the main context. */ - gc = g_main_context_default(); - - /* Try to acquire it. */ - if (!g_main_context_acquire(gc)) - caml_failwith("Lwt_glib.iter"); - - /* Dispatch pending events. */ - g_main_context_dispatch(gc); - - /* Prepare the context for polling. */ - g_main_context_prepare(gc, &max_priority); - - /* Get all file descriptors to poll. */ - while (pollfds_size < (nfds = g_main_context_query(gc, max_priority, &timeout, pollfds, pollfds_size))) { - free(pollfds); - pollfds_size = nfds; - pollfds = lwt_unix_malloc(pollfds_size * sizeof (GPollFD)); - } - - /* Clear all revents fields. */ - for (i = 0; i < nfds; i++) pollfds[i].revents = 0; - - /* Set the timeout to 0 if we do not want to block. */ - if (!Bool_val(may_block)) timeout = 0; - - /* Do the blocking call. */ - caml_enter_blocking_section(); - g_main_context_get_poll_func(gc)(pollfds, nfds, timeout); - caml_leave_blocking_section(); - - /* Let glib parse the result. */ - g_main_context_check(gc, max_priority, pollfds, nfds); - - /* Release the context. */ - g_main_context_release(gc); - - free(pollfds); - - return Val_unit; -} - -CAMLprim value lwt_glib_wakeup() -{ - g_main_context_wakeup(g_main_context_default()); - return Val_unit; -} diff --git a/server/thirdparty/lwt-2.3.2/src/preemptive/lwt-preemptive.mllib b/server/thirdparty/lwt-2.3.2/src/preemptive/lwt-preemptive.mllib deleted file mode 100644 index 25230f1..0000000 --- a/server/thirdparty/lwt-2.3.2/src/preemptive/lwt-preemptive.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 7a98b43f4d640061bceed7638c0c7efd) -Lwt_preemptive -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.ml b/server/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.ml deleted file mode 100644 index 8d25623..0000000 --- a/server/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.ml +++ /dev/null @@ -1,195 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * Module lwt_preemptive.ml - * Copyright (C) 2005 Nataliya Guts, Vincent Balat, Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * 2009 Jrmie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later version. - * See COPYING file for details. - * - * 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -let section = Lwt_log.Section.make "lwt(preemptive)" - -open Lwt -open Lwt_io - -(* +-----------------------------------------------------------------+ - | Parameters | - +-----------------------------------------------------------------+ *) - -(* Minimum number of preemptive threads: *) -let min_threads : int ref = ref 0 - -(* Maximum number of preemptive threads: *) -let max_threads : int ref = ref 0 - -(* Size of the waiting queue: *) -let max_thread_queued = ref 1000 - -let get_max_number_of_threads_queued _ = - !max_thread_queued - -let set_max_number_of_threads_queued n = - if n < 0 then invalid_arg "Lwt_preemptive.set_max_number_of_threads_queued"; - max_thread_queued := n - -(* The function for logging errors: *) -let error_log = ref (fun msg -> ignore (Lwt_log.error ~section msg)) - -(* The total number of preemptive threads currently running: *) -let threads_count = ref 0 - -(* +-----------------------------------------------------------------+ - | Preemptive threads management | - +-----------------------------------------------------------------+ *) - -type thread = { - task_channel: (int * (unit -> unit)) Event.channel; - (* Channel used to communicate notification id and tasks to the - worker thread. *) - - mutable thread : Thread.t; - (* The worker thread. *) - - mutable reuse : bool; - (* Whether the thread must be readded to the pool when the work is - done. *) -} - -(* Pool of worker threads: *) -let workers : thread Queue.t = Queue.create () - -(* Queue of clients waiting for a worker to be available: *) -let waiters : thread Lwt.u Lwt_sequence.t = Lwt_sequence.create () - -(* Code executed by a worker: *) -let rec worker_loop worker = - let id, task = Event.sync (Event.receive worker.task_channel) in - task (); - (* If there is too much threads, exit. This can happen if the user - decreased the maximum: *) - if !threads_count > !max_threads then worker.reuse <- false; - (* Tell the main thread that work is done: *) - Lwt_unix.send_notification id; - if worker.reuse then worker_loop worker - -(* create a new worker: *) -let make_worker _ = - incr threads_count; - let worker = { - task_channel = Event.new_channel (); - thread = Thread.self (); - reuse = true; - } in - worker.thread <- Thread.create worker_loop worker; - worker - -(* Add a worker to the pool: *) -let add_worker worker = - match Lwt_sequence.take_opt_l waiters with - | None -> - Queue.add worker workers - | Some w -> - wakeup w worker - -(* Wait for worker to be available, then return it: *) -let rec get_worker _ = - if not (Queue.is_empty workers) then - return (Queue.take workers) - else if !threads_count < !max_threads then - return (make_worker ()) - else begin - let (res, w) = Lwt.task () in - let node = Lwt_sequence.add_r w waiters in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - res - end - -(* +-----------------------------------------------------------------+ - | Initialisation, and dynamic parameters reset | - +-----------------------------------------------------------------+ *) - -let get_bounds _ = (!min_threads, !max_threads) - -let set_bounds (min, max) = - if min < 0 || max < min then invalid_arg "Lwt_preemptive.set_bounds"; - let diff = min - !threads_count in - min_threads := min; - max_threads := max; - (* Launch new workers: *) - for i = 1 to diff do - add_worker (make_worker ()) - done - -let initialized = ref false - -let init min max errlog = - initialized := true; - error_log := errlog; - set_bounds (min, max) - -let simple_init _ = - if not !initialized then begin - initialized := true; - set_bounds (0, 4) - end - -let nbthreads _ = !threads_count -let nbthreadsqueued _ = Lwt_sequence.fold_l (fun _ x -> x + 1) waiters 0 -let nbthreadsbusy _ = !threads_count - Queue.length workers - -(* +-----------------------------------------------------------------+ - | Detaching | - +-----------------------------------------------------------------+ *) - -let detach f args = - simple_init (); - let result = ref `Nothing in - (* The task for the worker thread: *) - let task () = - try - result := `Success(f args) - with exn -> - result := `Failure exn - in - lwt worker = get_worker () in - let waiter, wakener = wait () in - let id = - Lwt_unix.make_notification ~once:true - (fun () -> - match !result with - | `Nothing -> - wakeup_exn wakener (Failure "Lwt_preemptive.detach") - | `Success value -> - wakeup wakener value - | `Failure exn -> - wakeup_exn wakener exn) - in - try_lwt - (* Send the id and the task to the worker: *) - Event.sync (Event.send worker.task_channel (id, task)); - waiter - finally - if worker.reuse then - (* Put back the worker to the pool: *) - add_worker worker - else begin - decr threads_count; - (* Or wait for the thread to terminates, to free its associated - resources: *) - Thread.join worker.thread - end; - return () diff --git a/server/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.mli b/server/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.mli deleted file mode 100644 index 625d4fb..0000000 --- a/server/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.mli +++ /dev/null @@ -1,70 +0,0 @@ -(* Ocsigen - * http://www.ocsigen.org - * Module lwt_preemptive.ml - * Copyright (C) 2005 Nataliya Guts, Vincent Balat, Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * 2009 Jrmie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later version. - * See COPYING file for details. - * - * 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - -(** This module allows to mix preemptive threads with [Lwt] - cooperative threads. It maintains an extensible pool of preemptive - threads to with you can detach computations. *) - -val detach : ('a -> 'b) -> 'a -> 'b Lwt.t - (** detaches a computation to a preemptive thread. *) - -val init : int -> int -> (string -> unit) -> unit - (** [init min max log] initialises this module. i.e. it launches the - minimum number of preemptive threads and starts the {b - dispatcher}. - - @param min is the minimum number of threads - @param max is the maximum number of threads - @param log is used to log error messages - - If {!Lwt_preemptive} has already been initialised, this call - only modify bounds and the log function, and return the - dispatcher thread. *) - -val simple_init : unit -> unit - (** [simple_init ()] does a {i simple initialization}. i.e. with - default parameters if the library is not yet initialised. - - Note: this function is automatically called {!detach}. *) - -val get_bounds : unit -> int * int - (** [get_bounds ()] returns the minimum and the maximum number of - preemptive threads. *) - -val set_bounds : int * int -> unit - (** [set_bounds (min, max)] set the minimum and the maximum number - of preemptive threads. *) - -val set_max_number_of_threads_queued : int -> unit - (** Sets the size of the waiting queue, if no more preemptive - threads are available. When the queue is full, {!detach} will - sleep until a thread is available. *) - -val get_max_number_of_threads_queued : unit -> int - (** Returns the size of the waiting queue, if no more threads are - available *) - -(**/**) -val nbthreads : unit -> int -val nbthreadsbusy : unit -> int -val nbthreadsqueued : unit -> int diff --git a/server/thirdparty/lwt-2.3.2/src/react/lwt-react.mllib b/server/thirdparty/lwt-2.3.2/src/react/lwt-react.mllib deleted file mode 100644 index f614f68..0000000 --- a/server/thirdparty/lwt-2.3.2/src/react/lwt-react.mllib +++ /dev/null @@ -1,6 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 8916665f5b5252b5a633514708d91e4b) -Lwt_event -Lwt_signal -Lwt_react -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/react/lwt_event.ml b/server/thirdparty/lwt-2.3.2/src/react/lwt_event.ml deleted file mode 100644 index fc7d969..0000000 --- a/server/thirdparty/lwt-2.3.2/src/react/lwt_event.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_event - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -include Lwt_react.E - -(* +-----------------------------------------------------------------+ - | Notifiers | - +-----------------------------------------------------------------+ *) - -type notifier = unit React.event Lwt_sequence.node - -let notifiers = Lwt_sequence.create () - -let disable n = - Lwt_sequence.remove n; - React.E.stop (Lwt_sequence.get n) - -let notify f event = - Lwt_sequence.add_l (React.E.map f event) notifiers - -let notify_p f event = - Lwt_sequence.add_l (React.E.map (fun x -> Lwt.ignore_result (f x)) event) notifiers - -let notify_s f event = - let mutex = Lwt_mutex.create () in - Lwt_sequence.add_l (React.E.map (fun x -> Lwt.ignore_result (Lwt_mutex.with_lock mutex (fun () -> f x))) event) notifiers - -let always_notify f event = - ignore (notify f event) - -let always_notify_p f event = - ignore (notify_p f event) - -let always_notify_s f event = - ignore (notify_s f event) diff --git a/server/thirdparty/lwt-2.3.2/src/react/lwt_event.mli b/server/thirdparty/lwt-2.3.2/src/react/lwt_event.mli deleted file mode 100644 index 9d45f20..0000000 --- a/server/thirdparty/lwt-2.3.2/src/react/lwt_event.mli +++ /dev/null @@ -1,58 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_event - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Events utilities *) - -(** This module is deprecated, you should use {!Lwt_react.E} - instead. *) - -open React - -val with_finaliser : (unit -> unit) -> 'a event -> 'a event -val next : 'a event -> 'a Lwt.t -val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event -val from : (unit -> 'a Lwt.t) -> 'a event -val to_stream : 'a event -> 'a Lwt_stream.t -val of_stream : 'a Lwt_stream.t -> 'a event -val delay : 'a event Lwt.t -> 'a event -val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event -val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event -val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event -val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event -val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event -val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event -val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event -val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event -val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event -val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event -val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event -val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event -val run_s : 'a Lwt.t event -> 'a event -val run_p : 'a Lwt.t event -> 'a event -type notifier -val disable : notifier -> unit -val notify : ('a -> unit) -> 'a event -> notifier -val notify_p : ('a -> unit Lwt.t) -> 'a event -> notifier -val notify_s : ('a -> unit Lwt.t) -> 'a event -> notifier -val always_notify : ('a -> unit) -> 'a event -> unit -val always_notify_p : ('a -> unit Lwt.t) -> 'a event -> unit -val always_notify_s : ('a -> unit Lwt.t) -> 'a event -> unit diff --git a/server/thirdparty/lwt-2.3.2/src/react/lwt_react.ml b/server/thirdparty/lwt-2.3.2/src/react/lwt_react.ml deleted file mode 100644 index 7e79e4b..0000000 --- a/server/thirdparty/lwt-2.3.2/src/react/lwt_react.ml +++ /dev/null @@ -1,461 +0,0 @@ -(* - * lwt_react.ml - * ------------ - * Copyright : (c) 2011, Jeremie Dimino - * Licence : BSD3 - * - * This file is a part of lwt. - *) - -open Lwt - -type 'a event = 'a React.event -type 'a signal = 'a React.signal - -module E = struct - include React.E - - (* +---------------------------------------------------------------+ - | Lwt-specific utilities | - +---------------------------------------------------------------+ *) - - let finalise f _ = f () - - let with_finaliser f event = - let r = ref () in - Gc.finalise (finalise f) r; - map (fun x -> ignore r; x) event - - let next ev = - let waiter, wakener = Lwt.task () in - let ev = map (fun x -> Lwt.wakeup wakener x) (once ev) in - Lwt.on_cancel waiter (fun () -> stop ev); - waiter - - let limit f e = - (* Thread which prevent [e] to occur while it is sleeping *) - let limiter = ref (return ()) in - - (* The occurence that is delayed until the limiter returns. *) - let delayed = ref None in - - (* The resulting event. *) - let event, push = create () in - - let iter = - fmap - (fun x -> - if state !limiter = Sleep then begin - (* The limiter is sleeping, we queue the event for later - delivering. *) - match !delayed with - | Some cell -> - (* An occurence is alreayd queued, replace it. *) - cell := x; - None - | None -> - let cell = ref x in - delayed := Some cell; - on_success !limiter (fun () -> push !cell); - None - end else begin - (* Set the limiter for future events. *) - limiter := f (); - (* Send the occurence now. *) - push x; - None - end) - e - in - - select [iter; event] - - let stop_from wakener () = - wakeup wakener None - - let from f = - let event, push = create () in - let abort_waiter, abort_wakener = Lwt.wait () in - let rec loop () = - pick [f () >|= (fun x -> Some x); abort_waiter] >>= function - | Some v -> - push v; - loop () - | None -> - stop event; - return () - in - ignore_result (pause () >>= loop); - with_finaliser (stop_from abort_wakener) event - - module EQueue : - sig - type 'a t - val create : 'a React.event -> 'a t - val pop : 'a t -> 'a option Lwt.t - end = - struct - - type 'a state = - | No_mail - | Waiting of 'a option Lwt.u - | Full of 'a Queue.t - - type 'a t = { - mutable state : 'a state; - mutable event : unit React.event; - (* field used to prevent garbage collection *) - } - - let create event = - let box = { state = No_mail; event = never } in - let push v = - match box.state with - | No_mail -> - let q = Queue.create () in - Queue.push v q; - box.state <- Full q - | Waiting wakener -> - box.state <- No_mail; - wakeup_later wakener (Some v) - | Full q -> - Queue.push v q - in - box.event <- map push event; - box - - let pop b = match b.state with - | No_mail -> - let waiter, wakener = task () in - Lwt.on_cancel waiter (fun () -> b.state <- No_mail); - b.state <- Waiting wakener; - waiter - | Waiting _ -> - (* Calls to next are serialized, so this case will never - happened *) - assert false - | Full q -> - let v = Queue.take q in - if Queue.is_empty q then b.state <- No_mail; - return (Some v) - end - - let to_stream event = - let box = EQueue.create event in - Lwt_stream.from (fun () -> EQueue.pop box) - - let stop_stream wakener () = - wakeup wakener None - - let of_stream stream = - let event, push = create () in - let abort_waiter, abort_wakener = Lwt.wait () in - let rec loop () = - pick [Lwt_stream.get stream; abort_waiter] >>= function - | Some value -> - push value; - loop () - | None -> - stop event; - return () - in - ignore_result (pause () >>= loop); - with_finaliser (stop_stream abort_wakener) event - - let delay thread = - match poll thread with - | Some e -> - e - | None -> - let event, send = create () in - on_success thread (fun e -> send e; stop event); - switch never event - - let keeped = ref [] - - let keep e = - keeped := map ignore e :: !keeped - - (* +---------------------------------------------------------------+ - | Event transofrmations | - +---------------------------------------------------------------+ *) - - let run_p e = - let event, push = create () in - let iter = fmap (fun t -> on_success t push; None) e in - select [iter; event] - - let run_s e = - let event, push = create () in - let mutex = Lwt_mutex.create () in - let iter = fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) e in - select [iter; event] - - let map_p f e = - let event, push = create () in - let iter = fmap (fun x -> on_success (f x) push; None) e in - select [iter; event] - - let map_s f e = - let event, push = create () in - let mutex = Lwt_mutex.create () in - let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) e in - select [iter; event] - - let app_p ef e = - let event, push = create () in - let iter = fmap (fun (f, x) -> on_success (f x) push; None) (app (map (fun f x -> (f, x)) ef) e) in - select [iter; event] - - let app_s ef e = - let event, push = create () in - let mutex = Lwt_mutex.create () in - let iter = fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (app (map (fun f x -> (f, x)) ef) e) in - select [iter; event] - - let filter_p f e = - let event, push = create () in - let iter = fmap (fun x -> on_success (f x) (function true -> push x | false -> ()); None) e in - select [iter; event] - - let filter_s f e = - let event, push = create () in - let mutex = Lwt_mutex.create () in - let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) e in - select [iter; event] - - let fmap_p f e = - let event, push = create () in - let iter = fmap (fun x -> on_success (f x) (function Some x -> push x | None -> ()); None) e in - select [iter; event] - - let fmap_s f e = - let event, push = create () in - let mutex = Lwt_mutex.create () in - let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) e in - select [iter; event] - - let diff_s f e = - let previous = ref None in - let event, push = create () in - let mutex = Lwt_mutex.create () in - let iter = - fmap - (fun x -> - match !previous with - | None -> - previous := Some x; - None - | Some y -> - previous := Some x; - on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push; - None) - e - in - select [iter; event] - - let accum_s ef acc = - let acc = ref acc in - let event, push = create () in - let mutex = Lwt_mutex.create () in - let iter = fmap (fun f -> on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc)) (fun x -> acc := x; push x); None) ef in - select [iter; event] - - let fold_s f acc e = - let acc = ref acc in - let event, push = create () in - let mutex = Lwt_mutex.create () in - let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc x)) (fun x -> acc := x; push x); None) e in - select [iter; event] - - let rec rev_fold f acc = function - | [] -> - return acc - | x :: l -> - lwt acc = rev_fold f acc l in - f acc x - - let merge_s f acc el = - let event, push = create () in - let mutex = Lwt_mutex.create () in - let iter = fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (merge (fun acc x -> x :: acc) [] el) in - select [iter; event] -end - -module S = struct - include React.S - - (* +---------------------------------------------------------------+ - | Lwt-specific utilities | - +---------------------------------------------------------------+ *) - - let finalise f _ = f () - - let with_finaliser f signal = - let r = ref () in - Gc.finalise (finalise f) r; - map (fun x -> ignore r; x) signal - - let limit ?eq f s = - (* Thread which prevent [s] to changes while it is sleeping *) - let limiter = ref (f ()) in - - (* The occurence that is delayed until the limiter returns. *) - let delayed = ref None in - - (* The resulting event. *) - let event, push = E.create () in - - let iter = - E.fmap - (fun x -> - if state !limiter = Sleep then begin - (* The limiter is sleeping, we queue the event for later - delivering. *) - match !delayed with - | Some cell -> - (* An occurence is alreayd queued, replace it. *) - cell := x; - None - | None -> - let cell = ref x in - delayed := Some cell; - on_success !limiter (fun () -> push !cell); - None - end else begin - (* Set the limiter for future events. *) - limiter := f (); - (* Send the occurence now. *) - push x; - None - end) - (changes s) - in - - hold ?eq (value s) (E.select [iter; event]) - - let keeped = ref [] - - let keep s = - keeped := map ignore s :: !keeped - - (* +---------------------------------------------------------------+ - | Signal transofrmations | - +---------------------------------------------------------------+ *) - - let run_s ?eq s = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in - lwt x = Lwt_mutex.with_lock mutex (fun () -> value s) in - return (hold ?eq x (E.select [iter; event])) - - let map_s ?eq f s = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in - lwt x = Lwt_mutex.with_lock mutex (fun () -> f (value s)) in - return (hold ?eq x (E.select [iter; event])) - - let app_s ?eq sf s = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in - lwt x = Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s)) in - return (hold ?eq x (E.select [iter; event])) - - let filter_s ?eq f i s = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in - let x = value s in - Lwt_mutex.with_lock mutex (fun () -> f x) >>= function - | true -> - return (hold ?eq x (E.select [iter; event])) - | false -> - return (hold ?eq i (E.select [iter; event])) - - let fmap_s ?eq f i s = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in - Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= function - | Some x -> - return (hold ?eq x (E.select [iter; event])) - | None -> - return (hold ?eq i (E.select [iter; event])) - - let diff_s f s = - let previous = ref (value s) in - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = - E.fmap - (fun x -> - let y = !previous in - previous := x; - on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push; - None) - (changes s) - in - E.select [iter; event] - - let sample_s f e s = - E.map_s (fun x -> f x (value s)) e - - let accum_s ?eq ef i = - hold ?eq i (E.accum_s ef i) - - let fold_s ?eq f i e = - hold ?eq i (E.fold_s f i e) - - let rec rev_fold f acc = function - | [] -> - return acc - | x :: l -> - lwt acc = rev_fold f acc l in - f acc x - - let merge_s ?eq f acc sl = - let s = merge (fun acc x -> x :: acc) [] sl in - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in - lwt x = Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s)) in - return (hold ?eq x (E.select [iter; event])) - - let l1_s ?eq f s1 = - map_s ?eq f s1 - - let l2_s ?eq f s1 s2 = - map_s ?eq (fun (x1, x2) -> f x1 x2) (l2 (fun x1 x2 -> (x1, x2)) s1 s2) - - let l3_s ?eq f s1 s2 s3 = - map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) (l3 (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3) - - let l4_s ?eq f s1 s2 s3 s4 = - map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) (l4 (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4) - - let l5_s ?eq f s1 s2 s3 s4 s5 = - map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) (l5 (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5) - - let l6_s ?eq f s1 s2 s3 s4 s5 s6 = - map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) (l6 (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6) - - (* +---------------------------------------------------------------+ - | Monadic interface | - +---------------------------------------------------------------+ *) - - let return = - const - - let bind ?eq s f = - switch ?eq (f (value s)) (E.map f (changes s)) - - let bind_s ?eq s f = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in - lwt x = Lwt_mutex.with_lock mutex (fun () -> f (value s)) in - Lwt.return (switch ?eq x (E.select [iter; event])) -end diff --git a/server/thirdparty/lwt-2.3.2/src/react/lwt_react.mli b/server/thirdparty/lwt-2.3.2/src/react/lwt_react.mli deleted file mode 100644 index b5ef32c..0000000 --- a/server/thirdparty/lwt-2.3.2/src/react/lwt_react.mli +++ /dev/null @@ -1,166 +0,0 @@ -(* - * lwt_react.mli - * ------------- - * Copyright : (c) 2011, Jeremie Dimino - * Licence : BSD3 - * - * This file is a part of lwt. - *) - -(** React utilities *) - -(** This module is a replacement for the React module. You can open it - instead of the React module in order to get all react's functions - plus Lwt ones. *) - -type 'a event = 'a React.event - (** Type of events. *) - -type 'a signal = 'a React.signal - (** Type of signals. *) - -module E : sig - include module type of React.E - - (** {6 Lwt-specific utilities} *) - - val with_finaliser : (unit -> unit) -> 'a event -> 'a event - (** [with_finaliser f e] returns an event [e'] which behave as - [e], except that [f] is called when [e'] is garbage - collected. *) - - val next : 'a event -> 'a Lwt.t - (** [next e] returns the next occurrence of [e] *) - - val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event - (** [limit f e] limits the rate of [e] with [f]. - - For example, to limit the rate of an event to 1 per second you - can use: [limit (fun () -> Lwt_unix.sleep 1.0) event]. *) - - val from : (unit -> 'a Lwt.t) -> 'a event - (** [from f] creates an event which occurs each [f ()] returns a - value. If [f] raises an exception, the event is just - stopped. *) - - val to_stream : 'a event -> 'a Lwt_stream.t - (** Creates a stream holding all values occurring on the given - event *) - - val of_stream : 'a Lwt_stream.t -> 'a event - (** [of_stream stream] creates an event which occurs each time a - value is available on the stream. *) - - val delay : 'a event Lwt.t -> 'a event - (** [delay thread] is an event which does not occurs until - [thread] returns. Then it behaves as the event returned by - [thread]. *) - - val keep : 'a event -> unit - (** [keep e] keeps a reference to [e] so it will never be garbage - collected. *) - - (** {6 Threaded versions of React transformation functions} *) - - (** The following functions behave as their [React] counterpart, - except that they takes functions that may yield. - - As usual the [_s] suffix is used when calls are serialized, and - the [_p] suffix is used when they are not. - - Note that [*_p] functions may not preserve event order. *) - - val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event - val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event - - val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event - val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event - - val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event - val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event - - val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event - val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event - - val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event - - val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event - - val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event - - val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event - - val run_s : 'a Lwt.t event -> 'a event - val run_p : 'a Lwt.t event -> 'a event -end - -module S : sig - include module type of React.S - - (** {6 Monadic interface} *) - - val return : 'a -> 'a signal - (** Same as [const]. *) - - val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal - (** [bind ?eq s f] is initially [f x] where [x] is the current - value of [s]. Each time [s] changes to a new value [y], [bind - signal f] is set to [f y], until the next change of - [signal]. *) - - val bind_s : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal Lwt.t) -> 'b signal Lwt.t - (** Same as {!bind} except that [f] returns a thread. Calls to [f] - are serialized. *) - - (** {6 Lwt-specific utilities} *) - - val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal - (** [with_finaliser f s] returns a signal [s'] which behave as - [s], except that [f] is called when [s'] is garbage - collected. *) - - val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal - (** [limit f s] limits the rate of [s] update with [f]. - - For example, to limit it to 1 per second, you can use: [limit - (fun () -> Lwt_unix.sleep 1.0) s]. *) - - val keep : 'a signal -> unit - (** [keep s] keeps a reference to [s] so it will never be garbage - collected. *) - - (** {6 Threaded versions of React transformation functions} *) - - (** The following functions behave as their [React] counterpart, - except that they takes functions that may yield. - - The [_s] suffix means that calls are serialized. - *) - - val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'a signal -> 'b signal Lwt.t - - val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t - - val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal Lwt.t - - val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal Lwt.t - - val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event - - val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event - - val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal - - val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal - - val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal Lwt.t - - val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t - val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'a signal -> 'b signal -> 'c signal Lwt.t - val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal Lwt.t - val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal Lwt.t - val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal Lwt.t - val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal Lwt.t - - val run_s : ?eq : ('a -> 'a -> bool) -> 'a Lwt.t signal -> 'a signal Lwt.t -end diff --git a/server/thirdparty/lwt-2.3.2/src/react/lwt_signal.ml b/server/thirdparty/lwt-2.3.2/src/react/lwt_signal.ml deleted file mode 100644 index 069b14c..0000000 --- a/server/thirdparty/lwt-2.3.2/src/react/lwt_signal.ml +++ /dev/null @@ -1,175 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_signal - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -include Lwt_react.S - -open Lwt_react -open Lwt - -(* +-----------------------------------------------------------------+ - | Notifiers | - +-----------------------------------------------------------------+ *) - -type notifier = unit React.signal Lwt_sequence.node - -let notifiers = Lwt_sequence.create () - -let disable n = - Lwt_sequence.remove n; - stop (Lwt_sequence.get n) - -let notify f signal = - Lwt_sequence.add_l (S.map f signal) notifiers - -let notify_p f signal = - Lwt_sequence.add_l (S.map (fun x -> Lwt.ignore_result (f x)) signal) notifiers - -let notify_s f signal = - let mutex = Lwt_mutex.create () in - Lwt_sequence.add_l (S.map (fun x -> Lwt.ignore_result (Lwt_mutex.with_lock mutex (fun () -> f x))) signal) notifiers - -let always_notify f signal = - ignore (notify f signal) - -let always_notify_p f signal = - ignore (notify_p f signal) - -let always_notify_s f signal = - ignore (notify_s f signal) - -(* +-----------------------------------------------------------------+ - | Lwt-specific utilities | - +-----------------------------------------------------------------+ *) - -let delay thread = - match poll thread with - | Some signal -> - let event1, send1 = React.E.create () in - let event2, send2 = React.E.create () in - ignore ( - (* If the thread has already terminated, we make a pause to - prevent the first occurence to be lost *) - lwt () = pause () in - send1 (value signal); - send2 (changes signal); - React.E.stop event1; - React.E.stop event2; - return () - ); - React.E.switch event1 event2 - | None -> - let event1, send1 = React.E.create () in - let event2, send2 = React.E.create () in - ignore ( - lwt signal = thread in - send1 (value signal); - send2 (changes signal); - React.E.stop event1; - React.E.stop event2; - return () - ); - React.E.switch event1 event2 - -(* +-----------------------------------------------------------------+ - | Signal transofrmations | - +-----------------------------------------------------------------+ *) - -let run_s ?eq i s = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in - on_success (Lwt_mutex.with_lock mutex (fun () -> value s)) push; - hold ?eq i (E.select [iter; event]) - -let map_s ?eq f i s = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in - on_success (Lwt_mutex.with_lock mutex (fun () -> f (value s))) push; - hold ?eq i (E.select [iter; event]) - -let app_s ?eq sf i s = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in - on_success (Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s))) push; - hold ?eq i (E.select [iter; event]) - -let filter_s ?eq f i s = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in - let x = value s in - on_success - (Lwt_mutex.with_lock mutex (fun () -> f x)) - (function - | true -> - push x - | false -> - ()); - hold ?eq i (E.select [iter; event]) - -let fmap_s ?eq f i s = - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in - on_success - (Lwt_mutex.with_lock mutex (fun () -> f (value s))) - (function - | Some x -> - push x - | None -> - ()); - hold ?eq i (E.select [iter; event]) - -let rec rev_fold f acc = function - | [] -> - return acc - | x :: l -> - lwt acc = rev_fold f acc l in - f acc x - -let merge_s ?eq f acc sl = - let s = merge (fun acc x -> x :: acc) [] sl in - let event, push = E.create () in - let mutex = Lwt_mutex.create () in - let iter = E.fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in - on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s))) push; - hold ?eq acc (E.select [iter; event]) - -let l1_s ?eq f i s1 = - map_s ?eq f i s1 - -let l2_s ?eq f i s1 s2 = - map_s ?eq (fun (x1, x2) -> f x1 x2) i (l2 (fun x1 x2 -> (x1, x2)) s1 s2) - -let l3_s ?eq f i s1 s2 s3 = - map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) i (l3 (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3) - -let l4_s ?eq f i s1 s2 s3 s4 = - map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) i (l4 (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4) - -let l5_s ?eq f i s1 s2 s3 s4 s5 = - map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) i (l5 (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5) - -let l6_s ?eq f i s1 s2 s3 s4 s5 s6 = - map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) i (l6 (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6) diff --git a/server/thirdparty/lwt-2.3.2/src/react/lwt_signal.mli b/server/thirdparty/lwt-2.3.2/src/react/lwt_signal.mli deleted file mode 100644 index 05e18b2..0000000 --- a/server/thirdparty/lwt-2.3.2/src/react/lwt_signal.mli +++ /dev/null @@ -1,57 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_event - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Signals utilities *) - -(** This module is deprecated, you should use {!Lwt_react.S} - instead. *) - -open React -val return : 'a -> 'a signal -val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal -val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal -val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal -val delay : 'a signal Lwt.t -> 'a event -val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'b -> 'a signal -> 'b signal -val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'b -> 'a signal -> 'b signal -val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal -val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal -val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event -val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event -val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal -val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal -val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal -val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'b -> ('a signal -> 'b signal) -val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'c -> ('a signal -> 'b signal -> 'c signal) -val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'd -> ('a signal -> 'b signal -> 'c signal -> 'd signal) -val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'e -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal) -val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'f -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal) -val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'g -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal) -val run_s : ?eq : ('a -> 'a -> bool) -> 'a -> 'a Lwt.t signal -> 'a signal -type notifier -val disable : notifier -> unit -val notify : ('a -> unit) -> 'a signal -> notifier -val notify_p : ('a -> unit Lwt.t) -> 'a signal -> notifier -val notify_s : ('a -> unit Lwt.t) -> 'a signal -> notifier -val always_notify : ('a -> unit) -> 'a signal -> unit -val always_notify_p : ('a -> unit Lwt.t) -> 'a signal -> unit -val always_notify_s : ('a -> unit Lwt.t) -> 'a signal -> unit diff --git a/server/thirdparty/lwt-2.3.2/src/simple_top/lwt-simple-top.mllib b/server/thirdparty/lwt-2.3.2/src/simple_top/lwt-simple-top.mllib deleted file mode 100644 index 0553636..0000000 --- a/server/thirdparty/lwt-2.3.2/src/simple_top/lwt-simple-top.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: de6ce24e129acca71e8908d2344cd786) -Lwt_simple_top -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/simple_top/lwt_simple_top.ml b/server/thirdparty/lwt-2.3.2/src/simple_top/lwt_simple_top.ml deleted file mode 100644 index 8bea865..0000000 --- a/server/thirdparty/lwt-2.3.2/src/simple_top/lwt_simple_top.ml +++ /dev/null @@ -1,47 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_simple_top - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(* Integration with the toplevel for people who do not have the - enhanced toplevel (package lwt.top, which require ocaml-text). *) - -open Lwt -open Lwt_io - -let read_input_non_interactive prompt buffer len = - let rec loop i = - if i = len then - return (i, false) - else - read_char_opt stdin >>= function - | Some c -> - buffer.[i] <- c; - if c = '\n' then - return (i + 1, false) - else - loop (i + 1) - | None -> - return (i, true) - in - Lwt_main.run (write stdout prompt >> loop 0) - -let _ = - Toploop.read_interactive_input := read_input_non_interactive diff --git a/server/thirdparty/lwt-2.3.2/src/ssl/lwt-ssl.mllib b/server/thirdparty/lwt-2.3.2/src/ssl/lwt-ssl.mllib deleted file mode 100644 index 3320232..0000000 --- a/server/thirdparty/lwt-2.3.2/src/ssl/lwt-ssl.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: ab07ef30d9c1dd9dd2a1f2eef22e9d68) -Lwt_ssl -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.ml b/server/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.ml deleted file mode 100644 index 182504e..0000000 --- a/server/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.ml +++ /dev/null @@ -1,175 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_ssl - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -type t = - Plain - | SSL of Ssl.socket - -type socket = Lwt_unix.file_descr * t - -let is_ssl s = - match snd s with - Plain -> false - | _ -> true - -let wrap_call f () = - try - f () - with - (Ssl.Connection_error err | Ssl.Accept_error err | - Ssl.Read_error err | Ssl.Write_error err) as e -> - match err with - Ssl.Error_want_read -> - raise Lwt_unix.Retry_read - | Ssl.Error_want_write -> - raise Lwt_unix.Retry_write - | _ -> - raise e - -let repeat_call fd f = - try - Lwt_unix.check_descriptor fd; - Lwt.return (wrap_call f ()) - with - Lwt_unix.Retry_read -> - Lwt_unix.register_action Lwt_unix.Read fd (wrap_call f) - | Lwt_unix.Retry_write -> - Lwt_unix.register_action Lwt_unix.Write fd (wrap_call f) - | e -> - raise_lwt e - -(****) - -let plain fd = (fd, Plain) - -let embed_socket fd context = (fd, SSL(Ssl.embed_socket (Lwt_unix.unix_file_descr fd) context)) - -let ssl_accept fd ctx = - let socket = Ssl.embed_socket (Lwt_unix.unix_file_descr fd) ctx in - Lwt.bind - (repeat_call fd (fun () -> Ssl.accept socket)) (fun () -> - Lwt.return (fd, SSL socket)) - -let ssl_connect fd ctx = - let socket = Ssl.embed_socket (Lwt_unix.unix_file_descr fd) ctx in - Lwt.bind - (repeat_call fd (fun () -> Ssl.connect socket)) (fun () -> - Lwt.return (fd, SSL socket)) - -let read (fd, s) buf pos len = - match s with - | Plain -> - Lwt_unix.read fd buf pos len - | SSL s -> - if len = 0 then - Lwt.return 0 - else - repeat_call fd - (fun () -> - try - Ssl.read s buf pos len - with Ssl.Read_error Ssl.Error_zero_return -> - 0) - -let read_bytes (fd, s) buf pos len = - match s with - | Plain -> - Lwt_bytes.read fd buf pos len - | SSL s -> - if len = 0 then - Lwt.return 0 - else - repeat_call fd - (fun () -> - try - let str = String.create len in - let n = Ssl.read s str 0 len in - Lwt_bytes.blit_string_bytes str 0 buf pos len; - n - with Ssl.Read_error Ssl.Error_zero_return -> - 0) - -let write (fd, s) buf pos len = - match s with - | Plain -> - Lwt_unix.write fd buf pos len - | SSL s -> - if len = 0 then - Lwt.return 0 - else - repeat_call fd - (fun () -> - Ssl.write s buf pos len) - -let write_bytes (fd, s) buf pos len = - match s with - | Plain -> - Lwt_bytes.write fd buf pos len - | SSL s -> - if len = 0 then - Lwt.return 0 - else - repeat_call fd - (fun () -> - let str = String.create len in - Lwt_bytes.blit_bytes_string buf pos str 0 len; - Ssl.write s str 0 len) - -let wait_read (fd, s) = - match s with - Plain -> Lwt_unix.wait_read fd - | SSL _ -> Lwt_unix.yield () - -let wait_write (fd, s) = - match s with - Plain -> Lwt_unix.wait_write fd - | SSL _ -> Lwt_unix.yield () - -let out_channel_of_descr s = - Lwt_io.make ~mode:Lwt_io.output (fun buf pos len -> write_bytes s buf pos len) - -let in_channel_of_descr s = - Lwt_io.make ~mode:Lwt_io.input (fun buf pos len -> read_bytes s buf pos len) - -let ssl_shutdown (fd, s) = - match s with - Plain -> Lwt.return () - | SSL s -> repeat_call fd (fun () -> Ssl.shutdown s) - -let shutdown (fd, _) cmd = Lwt_unix.shutdown fd cmd - -let close (fd, _) = Lwt_unix.close fd - -let abort (fd, _) = Lwt_unix.abort fd - -let get_fd (fd,socket) = - match socket with - | Plain -> Lwt_unix.unix_file_descr fd - | SSL socket -> (Ssl.file_descr_of_socket socket) - -let getsockname s = - Unix.getsockname (get_fd s) - -let getpeername s = - Unix.getpeername (get_fd s) - diff --git a/server/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.mli b/server/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.mli deleted file mode 100644 index 6b30c78..0000000 --- a/server/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.mli +++ /dev/null @@ -1,58 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_ssl - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** OCaml-SSL integration *) - -type socket - -val ssl_accept : Lwt_unix.file_descr -> Ssl.context -> socket Lwt.t -val ssl_connect : Lwt_unix.file_descr -> Ssl.context -> socket Lwt.t -val plain : Lwt_unix.file_descr -> socket -val embed_socket : Lwt_unix.file_descr -> Ssl.context -> socket - -val read : socket -> string -> int -> int -> int Lwt.t -val write : socket -> string -> int -> int -> int Lwt.t - -val read_bytes : socket -> Lwt_bytes.t -> int -> int -> int Lwt.t -val write_bytes : socket -> Lwt_bytes.t -> int -> int -> int Lwt.t - -(* Really wait on a plain socket, just yield over SSL *) -val wait_read : socket -> unit Lwt.t -val wait_write : socket -> unit Lwt.t - -val shutdown : socket -> Unix.shutdown_command -> unit -val close : socket -> unit Lwt.t - -val out_channel_of_descr : socket -> Lwt_chan.out_channel -val in_channel_of_descr : socket -> Lwt_chan.in_channel - -val ssl_shutdown : socket -> unit Lwt.t - -val abort : socket -> exn -> unit - -(** Are we using an SSL socket? *) -val is_ssl : socket -> bool - -val getsockname : socket -> Unix.sockaddr - -val getpeername : socket -> Unix.sockaddr diff --git a/server/thirdparty/lwt-2.3.2/src/text/liblwt-text.clib b/server/thirdparty/lwt-2.3.2/src/text/liblwt-text.clib deleted file mode 100644 index c80b437..0000000 --- a/server/thirdparty/lwt-2.3.2/src/text/liblwt-text.clib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 49d58712acb378a903b0dfd06803031a) -lwt_text_stubs.o -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/text/lwt-text.mllib b/server/thirdparty/lwt-2.3.2/src/text/lwt-text.mllib deleted file mode 100644 index d643573..0000000 --- a/server/thirdparty/lwt-2.3.2/src/text/lwt-text.mllib +++ /dev/null @@ -1,6 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 445f786e72bdc58b36891d69973effc4) -Lwt_text -Lwt_term -Lwt_read_line -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/text/lwt_read_line.ml b/server/thirdparty/lwt-2.3.2/src/text/lwt_read_line.ml deleted file mode 100644 index 618abd9..0000000 --- a/server/thirdparty/lwt-2.3.2/src/text/lwt_read_line.ml +++ /dev/null @@ -1,1639 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_read_line - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt -open Lwt_text -open Lwt_term - -module TextSet = Set.Make(Text) -type text_set = TextSet.t - -type edition_state = Text.t * Text.t -type history = Text.t list -type prompt = Lwt_term.styled_text -type password_style = [ `empty | `clear | `text of Text.t ] - -class clipboard = - let signal, setter = React.S.create "" in -object - method set text = setter text - method contents = signal -end - -let clipboard = new clipboard - -exception Interrupt - -(* +-----------------------------------------------------------------+ - | Completion | - +-----------------------------------------------------------------+ *) - -type completion_mode = [ `classic | `real_time | `none ] - -type completion_result = { - comp_state : edition_state; - comp_words : text_set; -} - -type completion = edition_state -> completion_result Lwt.t - -let no_completion state = return { - comp_state = state; - comp_words = TextSet.empty; -} - -let common_prefix a b = - let lena = String.length a and lenb = String.length b in - let rec loop i = - if i = lena || i = lenb || (a.[i] <> b.[i]) then - String.sub a 0 i - else - loop (i + 1) - in - loop 0 - -let lookup word words = - let words = TextSet.filter (fun word' -> Text.starts_with word' word) words in - if TextSet.is_empty words then - ("", TextSet.empty) - else - (TextSet.fold common_prefix words (TextSet.choose words), words) - -let complete ?(suffix=" ") before word after words = - let prefix, words = lookup word words in - match TextSet.cardinal words with - | 0 -> - { comp_state = (before ^ word, after); - comp_words = TextSet.empty } - | 1 -> - { comp_state = (before ^ prefix ^ suffix, after); - comp_words = words } - | _ -> - { comp_state = (before ^ prefix, after); - comp_words = words } - -(* +-----------------------------------------------------------------+ - | Commands | - +-----------------------------------------------------------------+ *) - -module Command = -struct - - type t = - | Nop - | Char of Text.t - | Backward_delete_char - | Forward_delete_char - | Beginning_of_line - | End_of_line - | Complete - | Meta_complete - | Kill_line - | Backward_kill_line - | Accept_line - | Backward_delete_word - | Forward_delete_word - | History_next - | History_previous - | Break - | Clear_screen - | Insert - | Refresh - | Backward_char - | Forward_char - | Set_mark - | Paste - | Copy - | Cut - | Uppercase - | Lowercase - | Capitalize - | Backward_word - | Forward_word - | Backward_search - | Complete_left - | Complete_right - | Complete_up - | Complete_down - | Complete_first - | Complete_last - | Undo - | Delete_char_or_list - - let names = [ - (Nop, "nop"); - (Backward_delete_char, "backward-delete-char"); - (Forward_delete_char, "forward-delete-char"); - (Beginning_of_line, "beginning-of-line"); - (End_of_line, "end-of-line"); - (Complete, "complete"); - (Meta_complete, "meta-complete"); - (Kill_line, "kill-line"); - (Backward_kill_line, "backward-kill-line"); - (Accept_line, "accept-line"); - (Backward_delete_word, "backward-delete-word"); - (Forward_delete_word, "forward-delete-word"); - (History_next, "history-next"); - (History_previous, "history-previous"); - (Break, "break"); - (Clear_screen, "clear-screen"); - (Insert, "insert"); - (Refresh, "refresh"); - (Backward_char, "backward-char"); - (Forward_char, "forward-char"); - (Set_mark, "set-mark"); - (Paste, "paste"); - (Copy, "copy"); - (Cut, "cut"); - (Uppercase, "uppercase"); - (Lowercase, "lowercase"); - (Capitalize, "capitalize"); - (Backward_word, "backward-word"); - (Forward_word, "forward-word"); - (Complete_left, "complete-left"); - (Complete_right, "complete-right"); - (Complete_up, "complete-up"); - (Complete_down, "complete-down"); - (Backward_search, "backward-search"); - (Complete_first, "complete-first"); - (Complete_last, "complete-last"); - (Undo, "undo"); - (Delete_char_or_list, "delete-char-or-list"); - ] - - let to_string = function - | Char ch -> - Printf.sprintf "Char %S" ch - | command -> - let rec search = function - | (command', name) :: _ when command = command' -> - name - | _ :: rest -> - search rest - | [] -> - assert false - in - search names - - let of_string name = - let rec search = function - | (command, name') :: _ when name = name' -> - command - | _ :: rest -> - search rest - | [] -> - failwith "Lwt_read_line.Command.of_stirng: cannot convert string to command" - in - search names - - let of_key = function - | Key_up -> History_previous - | Key_down -> History_next - | Key_left -> Backward_char - | Key_right -> Forward_char - | Key_home -> Beginning_of_line - | Key_end -> End_of_line - | Key_insert -> Insert - | Key_delete -> Forward_delete_char - | Key_control '@' -> Set_mark - | Key_control 'a' -> Beginning_of_line - | Key_control 'd' -> Delete_char_or_list - | Key_control 'e' -> End_of_line - | Key_control 'h' -> Backward_delete_word - | Key_control 'i' -> Complete - | Key_control 'j' -> Accept_line - | Key_control 'k' -> Kill_line - | Key_control 'l' -> Clear_screen - | Key_control 'm' -> Accept_line - | Key_control 'n' -> Backward_char - | Key_control 'p' -> Forward_char - | Key_control 'r' -> Backward_search - | Key_control 'u' -> Backward_kill_line - | Key_control 'w' -> Cut - | Key_control 'y' -> Paste - | Key_control '_' -> Undo - | Key_control '?' -> Backward_delete_char - | Key "\027u" -> Uppercase - | Key "\027l" -> Lowercase - | Key "\027c" -> Capitalize - | Key ("\027Oc" | "\027[1;5C") -> Forward_word - | Key ("\027Od" | "\027[1;5D") -> Backward_word - | Key ("\027\027[A" | "\027[1;3A") -> Complete_up - | Key ("\027\027[B" | "\027[1;3B") -> Complete_down - | Key ("\027\027[C" | "\027[1;3C") -> Complete_right - | Key ("\027\027[D" | "\027[1;3D") -> Complete_left - | Key ("\027\027[7~" | "\027[1;3H") -> Complete_first - | Key ("\027\027[8~" | "\027[1;3F") -> Complete_last - | Key ("\027\n" | "\194\141") -> Char "\n" - | Key ("\027\t" | "\194\137") -> Meta_complete - | Key ("\027w" | "\195\183") -> Copy - | Key ("\027[3^" | "\027[3;5~") -> Forward_delete_word - | Key ch when Text.length ch = 1 && Text.is_print ch -> Char ch - | _ -> Nop -end - -(* +-----------------------------------------------------------------+ - | Read-line engine | - +-----------------------------------------------------------------+ *) - -module Engine = -struct - open Command - - type selection_state = { - sel_text : Text.t; - sel_mark : Text.pointer; - sel_cursor : Text.pointer; - } - - type search_state = { - search_word : Text.t; - search_history : history; - search_init_history : history; - } - - type mode = - | Edition of edition_state - | Selection of selection_state - | Search of search_state - - type state = { - mode : mode; - history : history * history; - } - - let init history = { - mode = Edition("", ""); - history = (history, []); - } - - let all_input state = match state.mode with - | Edition(before, after) -> - before ^ after - | Selection sel -> - sel.sel_text - | Search search -> - match search.search_history with - | [] -> - "" - | phrase :: _ -> - phrase - - let edition_state state = match state.mode with - | Edition(before, after) -> - (before, after) - | Selection sel -> - (Text.chunk (Text.pointer_l sel.sel_text) sel.sel_cursor, - Text.chunk sel.sel_cursor (Text.pointer_r sel.sel_text)) - | Search search -> - match search.search_history with - | [] -> - ("", "") - | phrase :: _ -> - (phrase, "") - - (* Reset the mode to the edition mode: *) - let reset state = match state.mode with - | Edition _ -> - state - | Selection sel -> - { state with mode = Edition(Text.chunk (Text.pointer_l sel.sel_text) sel.sel_cursor, - Text.chunk sel.sel_cursor (Text.pointer_r sel.sel_text)) } - | Search search -> - { state with mode = Edition((match search.search_history with - | [] -> - "" - | phrase :: _ -> - phrase), "") } - - let split_first_word text = - let rec find_last ptr = - match Text.next ptr with - | Some(ch, ptr) when Text.is_alnum ch -> - find_last ptr - | _ -> - ptr - in - let rec find_first ptr = - match Text.next ptr with - | Some(ch, ptr') -> - if Text.is_alnum ch then - let ptr' = find_last ptr' in - (Text.chunk (Text.pointer_l text) ptr, - Text.chunk ptr ptr', - Text.chunk ptr' (Text.pointer_r text)) - else - find_first ptr' - | None -> - (text, "", "") - in - find_first (Text.pointer_l text) - - let split_last_word text = - let rec find_first ptr = - match Text.prev ptr with - | Some(ch, ptr) when Text.is_alnum ch -> - find_first ptr - | _ -> - ptr - in - let rec find_last ptr = - match Text.prev ptr with - | Some(ch, ptr') -> - if Text.is_alnum ch then - let ptr' = find_first ptr' in - (Text.chunk (Text.pointer_l text) ptr', - Text.chunk ptr' ptr, - Text.chunk ptr (Text.pointer_r text)) - else - find_last ptr' - | None -> - (text, "", "") - in - find_last (Text.pointer_r text) - - let rec update ~engine_state ?(clipboard=clipboard) ~command () = - (* Helpers for updating the mode state only: *) - let edition st = { engine_state with mode = Edition st } - and selection st = { engine_state with mode = Selection st } - and search st = { engine_state with mode = Search st } in - match engine_state.mode with - | Selection sel -> - (* Change the cursor position: *) - let maybe_set_cursor = function - | Some(_, ptr) -> - selection { sel with sel_cursor = ptr } - | None -> - engine_state - in - - begin match command with - | Nop -> - engine_state - - | Forward_char -> - maybe_set_cursor (Text.next sel.sel_cursor) - - | Backward_char -> - maybe_set_cursor (Text.prev sel.sel_cursor) - - | Forward_word -> - let rec skip ptr = - match Text.next ptr with - | Some(ch, ptr) -> - if Text.is_alnum ch then find ptr else skip ptr - | None -> - ptr - and find ptr = - match Text.next ptr with - | Some(ch, ptr') -> - if Text.is_alnum ch then find ptr' else ptr - | None -> - ptr - in - selection { sel with sel_cursor = skip sel.sel_cursor } - - | Backward_word -> - let rec skip ptr = - match Text.prev ptr with - | Some(ch, ptr) -> - if Text.is_alnum ch then find ptr else skip ptr - | None -> - ptr - and find ptr = - match Text.prev ptr with - | Some(ch, ptr') -> - if Text.is_alnum ch then find ptr' else ptr - | None -> - ptr - in - selection { sel with sel_cursor = skip sel.sel_cursor } - - | Beginning_of_line -> - selection { sel with sel_cursor = Text.pointer_l sel.sel_text } - - | End_of_line -> - selection { sel with sel_cursor = Text.pointer_r sel.sel_text } - - | Copy -> - let a = min sel.sel_cursor sel.sel_mark and b = max sel.sel_cursor sel.sel_mark in - clipboard#set (Text.chunk a b); - edition (Text.chunk (Text.pointer_l sel.sel_text) sel.sel_cursor, - Text.chunk sel.sel_cursor (Text.pointer_r sel.sel_text)) - - | Cut -> - let a = min sel.sel_cursor sel.sel_mark and b = max sel.sel_cursor sel.sel_mark in - clipboard#set (Text.chunk a b); - edition (Text.chunk (Text.pointer_l sel.sel_text) a, - Text.chunk b (Text.pointer_r sel.sel_text)) - - | command -> - (* If the user sent another command, reset the mode to - edition and process the command: *) - update ~engine_state:(reset engine_state) ~clipboard ~command () - end - - | Edition(before, after) -> - begin match command with - | Char ch -> - edition (before ^ ch, after) - - | Set_mark -> - let txt = before ^ after in - let ptr = Text.pointer_at txt (Text.length before) in - selection { sel_text = txt; - sel_mark = ptr; - sel_cursor = ptr } - - | Paste -> - edition (before ^ (React.S.value clipboard#contents), after) - - | Backward_delete_char -> - edition (Text.rchop before, after) - - | Forward_delete_char -> - edition (before, Text.lchop after) - - | Beginning_of_line -> - edition ("", before ^ after) - - | End_of_line -> - edition (before ^ after, "") - - | Kill_line -> - clipboard#set after; - edition (before, "") - - | Backward_kill_line -> - clipboard#set before; - edition ("", after) - - | History_previous -> - begin match engine_state.history with - | ([], _) -> - engine_state - | (line :: hist_before, hist_after) -> - { mode = Edition(line, ""); - history = (hist_before, (before ^ after) :: hist_after) } - end - - | History_next -> - begin match engine_state.history with - | (_, []) -> - engine_state - | (hist_before, line :: hist_after) -> - { mode = Edition(line, ""); - history = ((before ^ after) :: hist_before, hist_after) } - end - - | Backward_char -> - if before = "" then - engine_state - else - edition (Text.rchop before, - Text.get before (-1) ^ after) - - | Forward_char -> - if after = "" then - engine_state - else - edition (before ^ (Text.get after 0), - Text.lchop after) - - | Uppercase -> - let a, b, c = split_first_word after in - edition (before ^ a ^ Text.upper b, c) - - | Lowercase -> - let a, b, c = split_first_word after in - edition (before ^ a ^ Text.lower b, c) - - | Capitalize -> - let a, b, c = split_first_word after in - edition (before ^ a ^ Text.capitalize (Text.lower b), c) - - | Backward_word -> - let a, b, c = split_last_word before in - edition (a, b ^ c ^ after) - - | Forward_word -> - let a, b, c = split_first_word after in - edition (before ^ a ^ b, c) - - | Backward_delete_word -> - let a, b, c = split_last_word before in - edition (a, c ^ after) - - | Forward_delete_word -> - let a, b, c = split_first_word after in - edition (before ^ a, c) - - | Backward_search -> - let hist_before, hist_after = engine_state.history in - let history = List.rev_append hist_after ((before ^ after) :: hist_before) in - search { search_word = ""; - search_history = history; - search_init_history = history } - - | _ -> - engine_state - end - - | Search st -> - let lookup word history = - let rec aux history = match history with - | [] -> - [] - | phrase :: rest -> - if Text.contains phrase word then - history - else - aux rest - in - aux history - in - - begin match command with - | Char ch -> - let word = st.search_word ^ ch in - search { - st with - search_word = word; - search_history = lookup word st.search_history; - } - - | Backward_search -> - search { - st with - search_history = match st.search_history with - | [] -> [] - | _ :: rest -> lookup st.search_word rest - } - - | Backward_delete_char -> - if st.search_word <> "" then - let word = Text.rchop st.search_word in - search { - st with - search_word = word; - search_history = lookup word st.search_init_history; - } - else - search st - - | cmd -> - let phrase = match st.search_history with - | [] -> "" - | phrase :: _ -> phrase - in - edition (phrase, "") - end -end - -(* +-----------------------------------------------------------------+ - | Rendering | - +-----------------------------------------------------------------+ *) - -let rec repeat f n = - if n <= 0 then - return () - else - lwt () = f () in - repeat f (n - 1) - -let print_words oc screen_width words = match List.filter ((<>) "") words with - | [] -> - return () - | words -> - let max_width = List.fold_left (fun x word -> max x (Text.length word)) 0 words + 1 in - let count = List.length words in - let columns = max 1 (screen_width / max_width) in - let lines = - if count < columns then - 1 - else - let l = count / columns in - if columns mod count = 0 then l else l + 1 - in - let column_width = screen_width / columns in - let m = Array.make_matrix lines columns "" in - let rec fill_display line column = function - | [] -> - () - | word :: words -> - m.(line).(column) <- word; - let line = line + 1 in - if line < lines then - fill_display line column words - else - fill_display 0 (column + 1) words - in - fill_display 0 0 words; - for_lwt line = 0 to lines - 1 do - lwt () = - for_lwt column = 0 to columns - 1 do - let word = m.(line).(column) in - lwt () = write oc word in - let len = Text.length word in - if len < column_width then - repeat (fun () -> write_char oc " ") (column_width - len) - else - return () - done - in - write_char oc "\n" - done - -module Terminal = -struct - open Engine - open Command - - type state = { - printed_before : styled_text; - (* The text displayed before the cursor *) - printed_after : styled_text; - (* The text displayed after the cursor *) - box : bool; - (* Tell whether a box is currently displayed *) - display_start : int; - (* For dynamic completion. It is the index of the first displayed word. *) - } - - let init = { printed_before = []; printed_after = []; display_start = 0; box = false } - - type box = - | Box_none - | Box_empty - | Box_words of text_set * int - | Box_message of string - - let make_completion index columns words = - let rec aux ofs idx = function - | [] -> - [Text(Text.repeat (columns - ofs) " ")] - | word :: words -> - let len = Text.length word in - let ofs' = ofs + len in - if ofs' <= columns then - if idx = index then - Inverse :: Text word :: Reset :: - if ofs' + 1 > columns then - [] - else - Text "│" :: aux (ofs' + 1) (idx + 1) words - else - Text word :: - if ofs' + 1 > columns then - [] - else - Text "│" :: aux (ofs' + 1) (idx + 1) words - else - [Text(Text.sub word 0 (columns - ofs))] - in - aux 0 0 words - - let make_bar delimiter columns words = - let buf = Buffer.create (columns * 3) in - let rec aux ofs = function - | [] -> - for i = ofs + 1 to columns do - Buffer.add_string buf "─" - done; - Buffer.contents buf - | word :: words -> - let len = Text.length word in - let ofs' = ofs + len in - if ofs' <= columns then begin - for i = 1 to len do - Buffer.add_string buf "─" - done; - if ofs' + 1 > columns then - Buffer.contents buf - else begin - Buffer.add_string buf delimiter; - aux (ofs' + 1) words - end - end else begin - for i = ofs + 1 to columns do - Buffer.add_string buf "─" - done; - Buffer.contents buf - end - in - aux 0 words - - let rec drop count l = - if count <= 0 then - l - else match l with - | [] -> [] - | e :: l -> drop (count - 1) l - - let rec goto_beginning_of_line = function - | 0 -> - [Text "\r"] - | 1 -> - [Text "\027[F"] - | n -> - Text "\027[F" :: goto_beginning_of_line (n - 1) - - let rec compute_position columns acc = function - | [] -> - acc - | Text txt :: rest -> - let acc = Text.fold (fun ch (column, line) -> - match ch with - | "\n" -> - (0, line + 1) - | _ -> - if column = columns then - (1, line + 1) - else - (column + 1, line)) txt acc in - compute_position columns acc rest - | _ :: rest -> - compute_position columns acc rest - - let _draw columns old_render_state new_render_state = - - let new_width_before, new_height_before = - compute_position columns (0, 0) new_render_state.printed_before - and old_width_before, old_height_before = - compute_position columns (0, 0) old_render_state.printed_before in - - let new_render_state, new_width_before, new_height_before = - (* If we terminates on the right margin, we add a "\n" to ensure - that the cursor will be printed at the beginning of the next - line: *) - if new_width_before = columns then - ({ new_render_state with printed_before = new_render_state.printed_before @ [Text "\n"] }, 0, new_height_before + 1) - else - (new_render_state, new_width_before, new_height_before) - in - - let new_width_total, new_height_total = - compute_position columns (new_width_before, new_height_before) new_render_state.printed_after - and old_width_total, old_height_total = - compute_position columns (old_width_before, old_height_before) old_render_state.printed_after in - - (* Produce a sequence erasing n lines: *) - let rec eraser acc = function - | 0 -> acc - | n -> eraser (Text "\027[K\n" :: acc) (n - 1) - in - - let text = List.flatten [ - (* Go back by the number of rows of the previous text: *) - goto_beginning_of_line old_height_before; - - (* Erase all old contents: *) - eraser [Text "\027[K"] old_height_total; - - (* Go back to the starting point: *) - goto_beginning_of_line old_height_total; - - (* Print all new contents: *) - new_render_state.printed_before; - new_render_state.printed_after; - - (* Go back again to the beginning of printed text: *) - goto_beginning_of_line new_height_total; - - (* Prints again the text before the cursor, to put the cursor at - the right place: *) - new_render_state.printed_before; - ] in - - (text, new_render_state) - - (* Render the current state on the terminal, and returns the new - terminal rendering state: *) - let draw ~columns ?(map_text=fun x -> x) ?(box=Box_none) ~render_state ~engine_state ~prompt () = - match engine_state.mode with - | Search st -> - let printed_before = Reset :: prompt @ [Reset; Text "(reverse-i-search)'"; Text st.search_word] in - let printed_after = match st.search_history with - | [] -> - [Text "'"] - | phrase :: _ -> - let ptr_start = match Text.find phrase st.search_word with - | Some ptr -> - ptr - | None -> - (* The first phrase of st.search_history is a - phrase containing st.search_word, so this - case will never happen *) - assert false - in - let ptr_end = Text.move (Text.length st.search_word) ptr_start in - [Text "': "; - Text(Text.chunk (Text.pointer_l phrase) ptr_start); - Underlined; - Text(Text.chunk ptr_start ptr_end); - Reset; - Text(Text.chunk ptr_end (Text.pointer_r phrase))] - in - _draw columns render_state { render_state with - printed_before = printed_before; - printed_after = printed_after } - - | _ -> - (* Text before and after the cursor, according to the current mode: *) - let before, after = match engine_state.mode with - | Edition(before, after) -> - ([Text(map_text before)], [Text(map_text after)]) - | Selection sel -> - let a = min sel.sel_cursor sel.sel_mark and b = max sel.sel_cursor sel.sel_mark in - let part_before = [Text(map_text (Text.chunk (Text.pointer_l sel.sel_text) a))] - and part_selected = [Underlined; Text(map_text (Text.chunk a b)); Reset] - and part_after = [Text(map_text (Text.chunk (Text.pointer_r sel.sel_text) b))] in - if sel.sel_cursor < sel.sel_mark then - (part_before, part_selected @ part_after) - else - (part_before @ part_selected, part_after) - | Search _ -> - assert false - in - - (* All the text printed before the cursor: *) - let printed_before = List.flatten [[Reset]; prompt; [Reset]; before] in - - match box with - | Box_none -> - _draw columns render_state - { render_state with - printed_before = printed_before; - printed_after = after; - box = false } - - | Box_message message -> - let bar = Text(Text.repeat (columns - 2) "─") in - let message_len = Text.length message in - let message = if message_len + 2 > columns then Text.sub message 0 (columns - 2) else message in - let printed_after = - after @ - [Text "\n"; - Text "┌"; bar; Text "┐\n"; - Text "│"; Text message; Text(String.make (columns - 2 - message_len) ' '); Text "│\n"; - Text "└"; bar; Text "┘"] - in - _draw columns render_state - { render_state with - printed_before = printed_before; - printed_after = printed_after; - box = true } - - | Box_empty -> - let bar = Text(Text.repeat (columns - 2) "─") in - let printed_after = - after @ - [Text "\n"; - Text "┌"; bar; Text "┐\n"; - Text "│"; Text(Text.repeat (columns - 2) " "); Text "│\n"; - Text "└"; bar; Text "┘"] - in - _draw columns render_state - { render_state with - printed_before = printed_before; - printed_after = printed_after; - box = true } - - | Box_words(words, position) -> - let words = TextSet.elements words and count = TextSet.cardinal words in - - (* Sets the index of the first displayed words such - that the cursor is displayed: *) - let display_start = - - (* Given a list of words and an offset, it returns - the index of the last word that can be - dusplayed *) - let rec compute_end offset index words = - match words with - | [] -> - index - 1 - | word :: words -> - let offset = offset + Text.length word in - if offset <= columns - 1 then - compute_end (offset + 1) (index + 1) words - else - index - 1 - in - - if position < render_state.display_start then - (* The cursor is before the left margin *) - let rev_index = count - position - 1 in - count - compute_end 1 rev_index (drop rev_index (List.rev words)) - 1 - else if compute_end 1 render_state.display_start (drop render_state.display_start words) < position then - (* The cursor is after the right margin *) - position - else - (* The cursor points to a word which is - displayed *) - render_state.display_start - in - - let words = drop display_start words in - let printed_after = - List.flatten - [after; - [Text "\n"; - Text "┌"; Text(make_bar "┬" (columns - 2) words); Text "┐\n"; - Text "│"]; - make_completion (position - display_start) (columns - 2) words; - [Text "│\n"; - Text "└"; Text(make_bar "┴" (columns - 2) words); Text "┘"]] - in - - _draw columns render_state - { display_start = display_start; - box = true; - printed_before = printed_before; - printed_after = printed_after } - - let last_draw ~columns ?(map_text=fun x -> x) ~render_state ~engine_state ~prompt () = - let printed = prompt @ [Reset; Text(map_text(all_input engine_state)); Text "\n"] in - fst (_draw columns render_state { render_state with - printed_before = printed; - printed_after = [] }) - - let erase ~columns ~render_state () = - goto_beginning_of_line (snd(compute_position columns (0, 0) render_state.printed_before)) @ [Text "\027[J"] -end - -(* +-----------------------------------------------------------------+ - | Controlling a running instance | - +-----------------------------------------------------------------+ *) - -module Control = -struct - type 'a t = { - result : 'a Lwt.t; - send_command : Command.t -> unit; - hide : unit -> unit Lwt.t; - show : unit -> unit Lwt.t; - } - - type prompt = Engine.state React.signal -> Lwt_term.styled_text React.signal - - let fake w = { result = w; - send_command = ignore; - hide = return; - show = return } - - let result ctrl = ctrl.result - let send_command ctrl command = ctrl.send_command command - let accept ctrl = ctrl.send_command Command.Accept_line - let interrupt ctrl = ctrl.send_command Command.Break - let hide ctrl = ctrl.hide () - let show ctrl = ctrl.show () - - (* +---------------------------------------------------------------+ - | Instance parameters | - +---------------------------------------------------------------+ *) - - open Command - - let set_nth set n = - let module M = struct exception Return of string end in - try - let _ = TextSet.fold (fun x n -> if n = 0 then raise (M.Return x) else n - 1) set n in - invalid_arg "Lwt_read_line.set_nth" - with M.Return x -> - x - - let read_command () = read_key () >|= Command.of_key - - (* State of a read-line instance *) - type state = { - render : Terminal.state; - engine : Engine.state; - box : Terminal.box; - prompt : Lwt_term.styled_text; - visible : bool; - old_states : edition_state list; - } - - type event = - | Ev_command of Command.t - | Ev_prompt of Lwt_term.styled_text - | Ev_box of Terminal.box - | Ev_completion of completion_result - | Ev_screen_size_changed - | Ev_hide of unit Lwt.u - | Ev_show of unit Lwt.u - - let engine_state state = state.engine - let render_state state = state.render - - (* +---------------------------------------------------------------+ - | Read-line generator | - +---------------------------------------------------------------+ *) - - let default_prompt _ = React.S.const [Text "# "] - - let rec truncate_list n l = match n, l with - | 0, l -> - l - | _, [] -> - [] - | n, x :: l -> - if n > 0 then - x :: truncate_list (n - 1) l - else - [] - - let make ?(history=[]) ?(complete=no_completion) ?(clipboard=clipboard) ?(mode=`real_time) - ?(map_text=fun x -> x) ?(filter=fun s c -> return c) ~map_result ?(prompt=default_prompt) () = - (* Signal holding the last engine state before waiting for a new - command: *) - let engine_state, set_engine_state = React.S.create (Engine.init history) in - - let prompt = prompt engine_state in - - (* The thread of the last launched completion *) - let completion_thread = ref (return ()) in - - (*** Events ***) - - (* Thread of the last [read_command]. It is cancelled when - read-line terminates. *) - let last_read_command_thread = ref (raise_lwt Exit) in - - (* Events typed by the user: *) - let user_events = Lwt_stream.from (fun () -> - let t = read_command () in - last_read_command_thread := t; - lwt command = t in - return (Some(Ev_command command))) in - - (* Events sent by the program: *) - let program_events, push_event = Lwt_stream.create () in - let push_event event = push_event (Some event) in - - (* Screan resizing *) - let size_events = Lwt_event.to_stream (React.E.stamp (React.S.changes Lwt_term.size) Ev_screen_size_changed) in - - (* Prompt events *) - let prompt_events = Lwt_event.to_stream (React.E.map (fun prompt -> Ev_prompt prompt) (React.S.changes prompt)) in - - (* All events *) - let events = Lwt_stream.choose [user_events; program_events; size_events; prompt_events] in - - (*** Box for `real_time mode ***) - - (* Contains the last suggested completion: *) - let last_completion = ref None in - - (* If [true], [update_box] will generate an [Ev_completion] when - completion is done, instead of an [Ev_box]. *) - let want_completion = ref false in - - let update_box = - match mode with - | `real_time -> - React.S.map - (function - | { Engine.mode = Engine.Selection _ } -> - push_event (Ev_box(Terminal.Box_message "")) - | { Engine.mode = Engine.Search _ } -> - push_event (Ev_box Terminal.Box_none) - | { Engine.mode = Engine.Edition edition_state } -> - last_completion := None; - want_completion := false; - completion_thread := begin - let thread = complete edition_state >|= fun x -> `Result x in - let start_date = Unix.time () in - (* Animation to make the user happy: *) - let rec loop anim = - pick [thread; Lwt_unix.sleep 0.1 >> return `Timeout] >>= function - | `Result comp -> - last_completion := Some comp.comp_state; - if !want_completion then - push_event (Ev_completion comp) - else - push_event (Ev_box(Terminal.Box_words(comp.comp_words, 0))); - return () - | `Timeout -> - let delta = truncate (Unix.time () -. start_date) in - let seconds = delta mod 60 - and minutes = (delta / 60) mod 60 - and hours = (delta / (60 * 60)) mod 24 - and days = (delta / (60 * 60 * 24)) in - let message = - if days = 0 then - Printf.sprintf "working %s %02d:%02d:%02d" (List.hd anim) hours minutes seconds - else if days = 1 then - Printf.sprintf "working %s 1 day %02d:%02d:%02d" (List.hd anim) hours minutes seconds - else - Printf.sprintf "working %s %d days %02d:%02d:%02d" (List.hd anim) days hours minutes seconds - in - push_event (Ev_box(Terminal.Box_message message)); - loop (List.tl anim) - in - let rec anim = "─" :: "\\" :: "│" :: "/" :: anim in - let thread = loop anim in - Lwt.on_cancel thread (fun () -> push_event (Ev_box Terminal.Box_empty)); - thread - end) - engine_state - | `classic | `none -> - React.S.const () - in - - (*** Main loop ***) - - (* Draw the state on the terminal and update the rendering - state: *) - let draw state = - let text, render_state = - Terminal.draw - ~columns:(React.S.value columns) - ~box:state.box - ~render_state:state.render - ~engine_state:state.engine - ~prompt:state.prompt - ~map_text - () - in - lwt () = printc text in - return { state with render = render_state } - in - - (* - [prev] is the last displayed state - - [state] is the current state *) - let rec loop prev state = - let thread = Lwt_stream.next events in - match Lwt.state thread with - | Sleep -> - (* This may update the prompt and dynamic completion: *) - set_engine_state state.engine; - (* Check a second time since the last command may have - created new messages: *) - begin match Lwt.state thread with - | Sleep -> - (* Redraw screen if the event queue is empty *) - lwt state = (if state.visible && prev <> state then draw else return) state in - lwt event = thread in - process_event state event (loop state) - - | Return event -> - process_event state event (loop prev) - - | Fail exn -> - raise_lwt exn - end - - | Return event -> - process_event state event (loop prev) - - | Fail exn -> - raise_lwt exn - - (* loop_refresh redraw the current state, even if it haa not - changed: *) - and loop_refresh state = - let thread = Lwt_stream.next events in - match Lwt.state thread with - | Sleep -> - set_engine_state state.engine; - begin match Lwt.state thread with - | Sleep -> - lwt state = (if state.visible then draw else return) state in - lwt event = thread in - process_event state event (loop state) - - | Return event -> - process_event state event loop_refresh - - | Fail exn -> - raise_lwt exn - end - - | Return event -> - process_event state event loop_refresh - - | Fail exn -> - raise_lwt exn - - and process_event state event loop = match event with - | Ev_prompt prompt -> - loop { state with prompt = prompt } - - | Ev_screen_size_changed -> - lwt () = printc (Terminal.erase ~columns:(React.S.value columns) ~render_state:state.render ()) in - loop_refresh { state with render = Terminal.init } - - | Ev_hide wakener -> - if state.visible then begin - lwt () = printc (Terminal.erase ~columns:(React.S.value columns) ~render_state:state.render ()) in - wakeup wakener (); - loop { state with render = Terminal.init; visible = false } - end else - loop state - - | Ev_show wakener -> - if not state.visible then begin - lwt state = draw state in - wakeup wakener (); - loop { state with visible = true } - end else - loop state - - | Ev_box box -> - loop { state with box = box } - - | Ev_completion comp -> - let state = { state with engine = { state.engine with Engine.mode = Engine.Edition comp.comp_state } } in - if mode = `classic && TextSet.cardinal comp.comp_words > 1 then - lwt () = - printc (Terminal.last_draw - ~columns:(React.S.value columns) - ~render_state:state.render - ~engine_state:state.engine - ~prompt:state.prompt - ~map_text - ()) - in - lwt () = print_words stdout (React.S.value Lwt_term.columns) (TextSet.elements comp.comp_words) in - loop_refresh { state with render = Terminal.init } - else - loop state - - | Ev_command command -> - if not (command = Complete && mode = `real_time) then - (* Cancel completion on user input: *) - Lwt.cancel !completion_thread; - - (* Save the command for possible [Undo] command *) - let state = - match command, state.engine with - | Undo, _ -> - state - | _, { Engine.mode = Engine.Edition es } -> begin - let old_states = - match state.old_states with - | es' :: _ when es = es' -> - state.old_states - | old_states -> - es :: old_states - in - { state with old_states = truncate_list 1000 old_states } - end - | _ -> - state - in - - (* User-provided filter *) - lwt command = filter state command in - - (* Commands that need pre-processing *) - lwt command = match command, state.engine.Engine.mode with - | Delete_char_or_list, Engine.Edition ("", "") -> return Break - | Delete_char_or_list, Engine.Edition (_, "") -> return Complete - | Delete_char_or_list, Engine.Edition (_, _) -> return Forward_delete_char - | _ -> return command - in - - match command with - | Nop -> - loop state - - | Undo -> begin - match state.old_states with - | [] -> - loop state - | s :: l -> - loop { state with - engine = { state.engine with Engine.mode = Engine.Edition s }; - old_states = l } - end - - | Complete_right -> - begin match state.box with - | Terminal.Box_words(words, index) when index < TextSet.cardinal words - 1 -> - loop { state with box = Terminal.Box_words(words, index + 1) } - | _ -> - loop state - end - - | Complete_left -> - begin match state.box with - | Terminal.Box_words(words, index) when index > 0 -> - loop { state with box = Terminal.Box_words(words, index - 1) } - | _ -> - loop state - end - - | Complete_first -> - begin match state.box with - | Terminal.Box_words(words, index) -> - loop { state with box = Terminal.Box_words(words, 0) } - | _ -> - loop state - end - - | Complete_last -> - begin match state.box with - | Terminal.Box_words(words, index) when not (TextSet.is_empty words)-> - loop { state with box = Terminal.Box_words(words, TextSet.cardinal words - 1) } - | _ -> - loop state - end - - | Complete -> - begin match mode with - | `none -> - loop state - | `classic -> - let state = { state with engine = Engine.reset state.engine } in - completion_thread := begin - lwt comp = complete (Engine.edition_state state.engine) in - push_event (Ev_completion comp); - return () - end; - loop state - | `real_time -> - match !last_completion with - | Some comp_state -> - loop { state with engine = { state.engine with Engine.mode = Engine.Edition comp_state } } - | None -> - want_completion := true; - loop state - end - - | Meta_complete -> - if mode = `real_time then begin - let state = { state with engine = Engine.reset state.engine } in - match state.box with - | Terminal.Box_words(words, index) when not (TextSet.is_empty words) -> - let before, after = Engine.edition_state state.engine in - let word = set_nth words index in - let word_len = Text.length word and before_len = Text.length before in - (* [search] searches the longest suffix of - [before] which is a prefix of [word]: *) - let rec search ptr idx = - if Text.equal_at ptr (Text.sub word 0 idx) then - loop { state with engine = { state.engine with Engine.mode = Engine.Edition(before ^ Text.sub word idx (word_len - idx), after) } } - else - match Text.next ptr with - | None -> raise_lwt (Failure "invalid completion") - | Some(ch, ptr) -> search ptr (idx - 1) - in - if word_len > before_len then - search (Text.pointer_l before) before_len - else - search (Text.pointer_at before (-word_len)) word_len - | _ -> - loop state - end else - loop state - - | Clear_screen -> - lwt () = clear_screen () in - loop_refresh state - - | Refresh -> - loop_refresh state - - | Accept_line -> - return (state, `Accept) - - | Break -> - return (state,`Interrupt) - - | command -> - loop { state with engine = Engine.update ~engine_state:state.engine ~clipboard ~command () } - - in - - let result = with_raw_mode begin fun () -> - - (* Wait for edition to terminate *) - lwt state, result = loop_refresh { - render = Terminal.init; - engine = React.S.value engine_state; - box = Terminal.Box_none; - prompt = React.S.value prompt; - visible = true; - old_states = []; - } in - - (* Cleanup *) - React.S.stop update_box; - Lwt.cancel !last_read_command_thread; - - (* Do the last draw *) - lwt () = printc (Terminal.last_draw - ~columns:(React.S.value columns) - ~render_state:state.render - ~engine_state:state.engine - ~prompt:state.prompt - ~map_text - ()) - in - - match result with - | `Accept -> - map_result (Engine.all_input state.engine) - | `Interrupt -> - raise_lwt Interrupt - end in - { - result = result; - send_command = (fun command -> push_event (Ev_command command)); - hide = (fun () -> - let waiter, wakener = Lwt.wait () in - push_event (Ev_hide wakener); - waiter); - show = (fun () -> - let waiter, wakener = Lwt.wait () in - push_event (Ev_show wakener); - waiter); - } - - (* +---------------------------------------------------------------+ - | Predefined instances | - +---------------------------------------------------------------+ *) - - let make_prompt prompt = React.S.value (prompt (React.S.const (Engine.init []))) - - let read_line ?history ?complete ?clipboard ?mode ?(prompt=default_prompt) () = - lwt stdin_isatty = Lwt_unix.isatty Lwt_unix.stdin - and stdout_isatty = Lwt_unix.isatty Lwt_unix.stdout in - if stdin_isatty && stdout_isatty then - return (make ?history ?complete ?clipboard ?mode ~prompt ~map_result:return ()) - else - return (fake (lwt () = write stdout (strip_styles (make_prompt prompt)) in - Lwt_text.read_line stdin)) - - let read_password ?clipboard ?(style:password_style=`text "*") ?prompt () = - lwt stdin_isatty = Lwt_unix.isatty Lwt_unix.stdin - and stdout_isatty = Lwt_unix.isatty Lwt_unix.stdout in - if stdin_isatty && stdout_isatty then - let map_text = match style with - | `text ch -> (fun txt -> Text.map (fun _ -> ch) txt) - | `clear -> (fun x -> x) - | `empty -> (fun _ -> "") - and filter state = function - | Backward_search -> - (* Drop search commands *) - return Nop - | command -> - return command - in - return (make ?clipboard ~map_text ~mode:`none ~filter ?prompt ~map_result:return ()) - else - fail (Failure "Lwt_read_line.read_password: not running in a terminal") - - let read_keyword ?history ?(case_sensitive=false) ?mode ?(prompt=default_prompt) ~values () = - let compare = if case_sensitive then Text.compare else Text.icompare in - let rec assoc key = function - | [] -> None - | (key', value) :: l -> - if compare key key' = 0 then - Some value - else - assoc key l - in - lwt stdin_isatty = Lwt_unix.isatty Lwt_unix.stdin - and stdout_isatty = Lwt_unix.isatty Lwt_unix.stdout in - if stdin_isatty && stdout_isatty then - let words = List.fold_left (fun acc (key, value) -> TextSet.add key acc) TextSet.empty values in - let filter state = function - | Accept_line -> - let text = Engine.all_input state.engine in - if List.exists (fun (key, value) -> compare key text = 0) values then - return Accept_line - else - return Nop - | command -> - return command - and map_result text = match assoc text values with - | Some value -> - return value - | None -> - assert false - and complete (before, after) = - return (complete "" before after words) - in - return (make ?history ?mode ~prompt ~filter ~map_result ~complete ()) - else - return (fake (lwt () = write stdout (strip_styles (make_prompt prompt)) in - lwt txt = Lwt_text.read_line stdin in - match assoc txt values with - | Some value -> - return value - | None -> - raise_lwt (Failure "Lwt_read_line.read_keyword: invalid input"))) - - let read_yes_no ?history ?mode ?prompt () = - read_keyword ?history ?mode ?prompt ~values:[("yes", true); ("no", false)] () -end - -(* +-----------------------------------------------------------------+ - | Simple calls | - +-----------------------------------------------------------------+ *) - -let default_prompt = [Text "# "] - -let read_line ?history ?complete ?clipboard ?mode ?(prompt=default_prompt) () = - Control.read_line ?history ?complete ?clipboard ?mode ~prompt:(fun _ -> React.S.const prompt) () >>= Control.result - -let read_password ?clipboard ?style ?(prompt=default_prompt) () = - Control.read_password ?clipboard ?style ~prompt:(fun _ -> React.S.const prompt) () >>= Control.result - -let read_keyword ?history ?case_sensitive ?mode ?(prompt=default_prompt) ~values () = - Control.read_keyword ?history ?case_sensitive ?mode ~prompt:(fun _ -> React.S.const prompt) ~values () >>= Control.result - -let read_yes_no ?history ?mode ?(prompt=default_prompt) () = - Control.read_yes_no ?history ?mode ~prompt:(fun _ -> React.S.const prompt) () >>= Control.result - -(* +-----------------------------------------------------------------+ - | History | - +-----------------------------------------------------------------+ *) - -let add_entry line history = - if Text.strip line = "" then - history - else - if (match history with [] -> false | x :: _ -> x = line) then - history - else - line :: history - -let escape line = - Text.map (function - | "\n" -> "\\n" - | "\\" -> "\\\\" - | ch -> ch) line - -let unescape line = - let buf = Buffer.create (String.length line) in - let rec loop ptr = match Text.next ptr with - | Some("\\", ptr) -> - begin match Text.next ptr with - | Some("\\", ptr) -> - Buffer.add_string buf "\\"; - loop ptr - | Some("n", ptr) -> - Buffer.add_string buf "\n"; - loop ptr - | Some(ch, ptr) -> - Buffer.add_string buf "\\"; - Buffer.add_string buf ch; - loop ptr - | None -> - Buffer.add_string buf "\\"; - Buffer.contents buf - end - | Some(ch, ptr) -> - Buffer.add_string buf ch; - loop ptr - | None -> - Buffer.contents buf - in - loop (Text.pointer_l line) - -let rec load_lines ic acc = - Lwt_io.read_line_opt ic >>= function - | Some l -> - load_lines ic (unescape l :: acc) - | None -> - return acc - -let load_history name = - if Sys.file_exists name then - Lwt_io.with_file ~mode:Lwt_io.input name (fun ic -> load_lines ic []) - else - return [] - -let rec merge h1 h2 = match h1, h2 with - | l1 :: h1, l2 :: h2 when l1 = l2 -> - l1 :: merge h1 h2 - | _ -> - h1 @ h2 - -let save_history name history = - lwt on_disk_history = load_history name in - Lwt_io.lines_to_file name (Lwt_stream.map escape (Lwt_stream.of_list (merge (List.rev on_disk_history) (List.rev history)))) diff --git a/server/thirdparty/lwt-2.3.2/src/text/lwt_read_line.mli b/server/thirdparty/lwt-2.3.2/src/text/lwt_read_line.mli deleted file mode 100644 index c5d0539..0000000 --- a/server/thirdparty/lwt-2.3.2/src/text/lwt_read_line.mli +++ /dev/null @@ -1,453 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_read_line - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Interactive line input *) - -(** {6 Definitions} *) - -exception Interrupt - (** Exception raised when the user press [Ctrl^D] *) - -type edition_state = Text.t * Text.t - (** An edition state, it is a pair of two UTF-8 encoded strings: - - - the input before the cursor - - the input after the cursor *) - -type prompt = Lwt_term.styled_text - (** A prompt. It may contains colors. *) - -type text_set = Set.Make(Text).t - -(** {8 Completion} *) - -(** Result of a completion function: *) -type completion_result = { - comp_state : edition_state; - (** The new edition state *) - - comp_words : text_set; - (** A list of possibilities *) -} - -type completion = edition_state -> completion_result Lwt.t - (** Type of a completion function. It takes as argument the - current edition state. - - Note: the thread launched by the completion function is - cancelled using {!Lwt.cancel} if the user continue typing - text. *) - -val lookup : Text.t -> text_set -> (Text.t * text_set) - (** [lookup word words] lookup for completion of [word] into - [words]. It returns [(prefix, possibilities)] where - [possibilities] are all words starting with [word] and [prefix] - is the longest common prefix of [possibilities]. *) - -val complete : ?suffix : Text.t -> Text.t -> Text.t -> Text.t -> text_set -> completion_result - (** [complete ?suffix before word after words] basic completion - functions. [words] is a list of possible completions for - [word]. - - If completion succeed [suffix] is append to the resulting - text. It defaults to [" "]. *) - -val print_words : Lwt_text.output_channel -> int -> string list -> unit Lwt.t - (** [print_words oc columns strs] pretty-prints a list of words. *) - -(** {8 History} *) - -type history = Text.t list - (** Type of an history *) - -val add_entry : Text.t -> history -> history - (** [add_entry line history] returns the history [history] plus - [line] at the beginning. If [line] already appears at the - beginning or contains only spaces, it is discarded. *) - -val save_history : string -> history -> unit Lwt.t - (** [save_history filename history] saves [history] to - [filename]. History is saved by separating lines with a null - character. *) - -val load_history : string -> history Lwt.t - (** [load_history filename] loads history from [filename]. Returns - the empty history if the the file does not exit. *) - -(** {8 Clipboards} *) - -(** Type of a clipboard. *) -class clipboard : object - method set : Text.t -> unit - method contents : Text.t React.signal -end - -val clipboard : clipboard - (** The global clipboard. All read-line instances which do not use a - specific clipboard use this one. *) - -(** {6 High-level functions} *) - -type completion_mode = [ `classic | `real_time | `none ] - (** The completion mode. - - - [`classic] means that when the user hit [Tab] a list of - possible completions is proposed, - - - [`real_time] means that possible completions are shown to - the user as he types, and he can navigate in them with - [Meta+left], [Meta+right] - - - [`none] means no completion at all *) - -val read_line : - ?history : history -> - ?complete : completion -> - ?clipboard : clipboard -> - ?mode : completion_mode -> - ?prompt : prompt -> unit -> Text.t Lwt.t - (** [readline ?history ?complete ?mode ?prompt ()] inputs some text - from the user. If input is not a terminal, it defaults to - [Lwt_text.read_line Lwt_text.stdin]. - - If @param mode contains the current completion mode. It defaults - to [`real_time]. - - @param prompt defaults to [Lwt_term.Text "# "] *) - -type password_style = [ `empty | `clear | `text of Text.t ] - (** Style which indicate how the password is echoed to the user: - - - with [`empty] nothing is printed - - with [`clear] the password is displayed has it - - with [`text ch] all characters are replaced by [ch] *) - -val read_password : - ?clipboard : clipboard -> - ?style : password_style -> - ?prompt : prompt -> unit -> Text.t Lwt.t - (** [read_password ?clipboard ?clear ~prompt ()] inputs a password - from the user. This function fails if input is not a terminal. - - @param style defaults to [`text "*"]. - *) - -val read_keyword : - ?history : history -> - ?case_sensitive : bool -> - ?mode : completion_mode -> - ?prompt : prompt -> - values : (Text.t * 'value) list -> unit -> 'value Lwt.t - (** [read_keyword ?history ?case_sensitive ?mode ~prompt ~keywords - ()] reads one word which is a member of [words]. And returns - which keyword the user choosed. - - [case_sensitive] default to [false]. *) - -val read_yes_no : ?history : history -> ?mode : completion_mode -> ?prompt : prompt -> unit -> bool Lwt.t - (** [read_yes_no ?history ?dynamic prompt ()] is the same as: - - {[ - read_keyword ?history ?dynamic prompt [("yes", true); ("no", false)] () - ]} - *) - -(** {6 Low-level interaction} *) - -(** This part allow you to implements your own read-line function, or - just to use the readline engine in another context (message box, - ...). *) - -(** Readline commands *) -module Command : sig - - (** Type of all read-line function: *) - type t = - | Nop - (** Command which do nothing. Unknown keys maps to this commands. *) - | Char of Text.t - (** Any printable character. *) - | Backward_delete_char - | Forward_delete_char - | Beginning_of_line - | End_of_line - | Complete - | Meta_complete - | Kill_line - | Backward_kill_line - | Accept_line - | Backward_delete_word - | Forward_delete_word - | History_next - | History_previous - | Break - | Clear_screen - | Insert - | Refresh - | Backward_char - | Forward_char - | Set_mark - | Paste - | Copy - | Cut - | Uppercase - | Lowercase - | Capitalize - | Backward_word - | Forward_word - | Backward_search - | Complete_left - | Complete_right - | Complete_up - | Complete_down - | Complete_first - | Complete_last - | Undo - | Delete_char_or_list - - val to_string : t -> string - (** [to_string cmd] returns a string representation of a command *) - - val of_string : string -> t - (** [of_string cld] tries to convert a command name to a - command. @raise Failure if it fails. *) - - val names : (t * string) list - (** [names] is the list of all commands (except [Char ch]) with - their name. *) - - val of_key : Lwt_term.key -> t - (** [of_key key] returns the command to which a key is mapped. *) -end - -(** Engine *) -module Engine : sig - - (** Note: this part know nothing about rendering or completion. *) - - (** State when the user is doing selection: *) - type selection_state = { - sel_text : Text.t; - (** The whole input text on which the selection is working *) - sel_mark : Text.pointer; - (** Pointer to the mark *) - sel_cursor : Text.pointer; - (** Pointer to the cursor *) - } - - (** State when searching in the history *) - type search_state = { - search_word : Text.t; - (** The word we are looking for *) - search_history : history; - (** Position in history. The first element is a sentence - containing the searched word *) - search_init_history : history; - (** The initial history, before searching for a word *) - } - - (** The engine mode: *) - type mode = - | Edition of edition_state - (** The user is typing some text *) - | Selection of selection_state - (** The user is selecting some text *) - | Search of search_state - (** The user is searching the given word in the history *) - - (** An engine state: *) - type state = { - mode : mode; - history : history * history; - (** Cursor to the history position. *) - } - - val init : history -> state - (** [init history] return a initial state using the given - history *) - - val reset : state -> state - (** [reset state] reset the given state, if the user was doing a - selection, it is canceled *) - - val update : engine_state : state -> ?clipboard : clipboard -> command : Command.t -> unit -> state - (** [update ~state ?clipboard ~command ()] update an engine state by - processing the given command. It returns the new state, and - may have the side effect of changing the clipboard contents. - - [clipboard] defaults to the global clipboard. - *) - - val edition_state : state -> edition_state - (** Returns the edition state of a state, whatever its mode is. *) - - val all_input : state -> Text.t - (** Returns the current complete user input. *) -end - -(** Rendering to the terminal *) -module Terminal : sig - - type state - (** State of rendering *) - - val init : state - (** Initial state *) - - (** The following functions are the one used by read-line functions - of this module. *) - - (** Box for the completion: *) - type box = - | Box_none - (** No box at all *) - | Box_empty - (** An empty box *) - | Box_words of text_set * int - (** [BM_words(words, position)] is a box with the given list - of words. [position] is the position of the selected word - in the list.. *) - | Box_message of string - (** A box containing only the given message *) - - val draw : - columns : int -> - ?map_text : (Text.t -> Text.t) -> - ?box : box -> - render_state : state -> - engine_state : Engine.state -> - prompt : prompt -> unit -> Lwt_term.styled_text * state - (** [draw ~column ?map_text ?bar ~render_state ~engine_state - prompt ()] returns [(text, state)] where [state] is the new - rendering state, and [text] is a text containing escape - sequences. When printed, it will update the displayed state. - - @param map_text is a function used to map user input before - printing it, for example to hide passwords. - @param message is a message to display if completion is not - yet available. - @param box defaults to {!Box_none}. *) - - val last_draw : - columns : int -> - ?map_text : (Text.t -> Text.t) -> - render_state : state -> - engine_state : Engine.state -> - prompt : prompt -> unit -> Lwt_term.styled_text - (** Draw for the last time, i.e. the cursor is left after the text - and not at current position. *) - - val erase : columns : int -> render_state : state -> unit -> Lwt_term.styled_text - (** [erase ~columns ~render_state ()] returns a text which will - erase everything (the prompt, user input, completion, ...). - - After an erase, the rendering state is [init]. *) -end - -(** {6 Advanced use} *) - -(** Controlling a running read-line instance *) -module Control : sig - - type 'a t - (** Type of a running read-line instance, returning a value of - type ['a] *) - - (** {6 Control} *) - - val result : 'a t -> 'a Lwt.t - (** Threads waiting for the read-line instance to terminates *) - - val send_command : 'a t -> Command.t -> unit - (** [send_command instance command] sends the given command to the - read-line instance *) - - val accept : 'a t -> unit - (** [accept instance = send_command instance Command.Accept_line] *) - - val interrupt : 'a t -> unit - (** [accept instance = send_command instance Command.Break] *) - - val hide : 'a t -> unit Lwt.t - (** Hides everything (prompt, user input, completion box) until - {!show} is called. *) - - val show : 'a t -> unit Lwt.t - (** Un-hide everything *) - - (** Note: in case the input is not a terminal, read-line instances - are not controllable. i.e. {!accept}, {!refresh}, ... have no - effect. *) - - (** {6 Creation of read-line instances} *) - - type prompt = Engine.state React.signal -> Lwt_term.styled_text React.signal - (** The prompt a signal which may depends on the engine state *) - - type state - (** State of an instance *) - - val engine_state : state -> Engine.state - (** Return the engine state of the given state *) - - val render_state : state -> Terminal.state - (** Return the rendering state of the given state *) - - val make : - ?history : history -> - ?complete : completion -> - ?clipboard : clipboard -> - ?mode : [ completion_mode | `none ] -> - ?map_text : (Text.t -> Text.t) -> - ?filter : (state -> Command.t -> Command.t Lwt.t) -> - map_result : (Text.t -> 'a Lwt.t) -> - ?prompt : prompt -> unit -> 'a t - (** Creates a new read-line instance with the given - parameters. [filter] is called to handle commands. You can - return {!Command.Nop} to drop a command. *) - - (** {6 Predefined instances} *) - - val read_line : - ?history : history -> - ?complete : completion -> - ?clipboard : clipboard -> - ?mode : completion_mode -> - ?prompt : prompt -> unit -> Text.t t Lwt.t - - val read_password : - ?clipboard : clipboard -> - ?style : password_style -> - ?prompt : prompt -> unit -> Text.t t Lwt.t - - val read_keyword : - ?history : history -> - ?case_sensitive : bool -> - ?mode : completion_mode -> - ?prompt : prompt -> - values : (Text.t * 'value) list -> unit -> 'value t Lwt.t - - val read_yes_no : - ?history : history -> - ?mode : completion_mode -> - ?prompt : prompt -> unit -> bool t Lwt.t -end diff --git a/server/thirdparty/lwt-2.3.2/src/text/lwt_term.ml b/server/thirdparty/lwt-2.3.2/src/text/lwt_term.ml deleted file mode 100644 index 0d0e5e6..0000000 --- a/server/thirdparty/lwt-2.3.2/src/text/lwt_term.ml +++ /dev/null @@ -1,847 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_term - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt -open Lwt_text - -(* +-----------------------------------------------------------------+ - | Terminal mode | - +-----------------------------------------------------------------+ *) - -type state = - | Normal - | Raw of Unix.terminal_io - -let state = ref Normal - -(* Number of function currently using the raw mode: *) -let raw_count = ref 0 - -let get_attr () = - try_lwt - lwt attr = Lwt_unix.tcgetattr Lwt_unix.stdin in - return (Some attr) - with _ -> - return None - -let set_attr mode = - try_lwt - Lwt_unix.tcsetattr Lwt_unix.stdin Unix.TCSAFLUSH mode - with _ -> - return () - -let drawing_mode = ref false - -let enter_drawing_mode () = - drawing_mode := true; - write stdout "\027[?1049h\027[?1h\027=\r" - -let leave_drawing_mode () = - drawing_mode := false; - write stdout "\r\027[K\027[?1l\027>\027[r\027[?1049l" - -let cursor_visible = ref true - -let show_cursor _ = - cursor_visible := true; - write stdout "\x1B[?25h" - -let hide_cursor _ = - cursor_visible := false; - write stdout "\x1B[?25l" - -let clear_screen _ = - write stdout "\027[2J\027[H" - -let clear_line _ = - write stdout "\027[2K" - -(* Go-up by [n] lines then to the beginning of the line. Normally - "\027[nF" does exactly this but for some terminal 1 need to be - added... By the way we can relly on the fact that all terminal - react the same way to "\027[F" which is to go to the beginning of - the previous line: *) -let rec goto_beginning_of_line = function - | 0 -> - write_char stdout "\r" - | 1 -> - write stdout "\027[F" - | n -> - lwt () = write stdout "\027[F" in - goto_beginning_of_line (n - 1) - -(* Restore terminal mode on exit: *) -let cleanup () = - lwt () = - if not !cursor_visible then - show_cursor () - else - return () - in - lwt () = - if !drawing_mode then - leave_drawing_mode () - else - return () - in - match !state with - | Normal -> - return () - | Raw saved_attr -> - set_attr saved_attr - -let () = Lwt_main.at_exit cleanup - -let raw_mode () = match !state with - | Normal -> false - | Raw _ -> true - -let leave_raw_mode () = - decr raw_count; - if !raw_count = 0 then - match !state with - | Normal -> - assert false - | Raw attr -> - state := Normal; - set_attr attr - else - return () - -let with_raw_mode f = - match !state with - | Raw attr -> - incr raw_count; - finalize f leave_raw_mode - | Normal -> - get_attr () >>= function - | Some attr -> - incr raw_count; - state := Raw attr; - lwt () = set_attr { - attr with - (* Inspired from Python-3.0/Lib/tty.py: *) - Unix.c_brkint = false; - Unix.c_inpck = false; - Unix.c_istrip = false; - Unix.c_ixon = false; - Unix.c_csize = 8; - Unix.c_parenb = false; - Unix.c_echo = false; - Unix.c_icanon = false; - Unix.c_isig = false; - Unix.c_vmin = 1; - Unix.c_vtime = 0 - } in - try_lwt f () finally leave_raw_mode () - | None -> - raise_lwt (Failure "Lwt_term.with_raw_mode: input is not a tty") - -(* +-----------------------------------------------------------------+ - | Terminal informations | - +-----------------------------------------------------------------+ *) - -type size = { - lines : int; - columns : int; -} - -external get_size : Unix.file_descr -> size = "lwt_text_term_size" - -#if windows - -let size = - React.S.const - (try - get_size Unix.stdout - with Unix.Unix_error _ -> - { columns = 80; lines = 25 }) - -#else - -external sigwinch : unit -> int = "lwt_text_sigwinch" -let sigwinch = sigwinch () - -let sigwinch_event = - if sigwinch = 0 then - React.E.never - else - try - let event, push = React.E.create () in - let _ = Lwt_unix.on_signal sigwinch push in - event - with Unix.Unix_error _ | Invalid_argument _ | Sys_error _ -> - React.E.never - -let size = - React.S.hold - (try - get_size Unix.stdin - with Unix.Unix_error _ -> - { columns = 80; lines = 25 }) - (React.E.map (fun _ -> get_size Unix.stdin) sigwinch_event) - -#endif - -let columns = React.S.map (fun { columns = c } -> c) size -let lines = React.S.map (fun { lines = l } -> l) size - -(* +-----------------------------------------------------------------+ - | Keys input | - +-----------------------------------------------------------------+ *) - -exception Exit_sequence - -let parse_escape st = - let buf = Buffer.create 10 in - Buffer.add_char buf '\027'; - (* Read one character and add it to [buf]: *) - let get () = - match Lwt.state (Lwt_stream.get st) with - | Sleep -> - (* If the rest is not immediatly available, conclude that - this is not an escape sequence but just the escape key: *) - raise_lwt Exit_sequence - | Fail exn -> - raise_lwt exn - | Return None -> - raise_lwt Exit_sequence - | Return(Some ch) -> - (* Is it an ascii character ? *) - if String.length ch = 1 then begin - Buffer.add_string buf ch; - return ch.[0] - end else - (* If it is not, then this is not an escape sequence: *) - raise_lwt Exit_sequence - in - - (* Sometimes sequences starts with several escape characters: *) - let rec first count = - get () >>= function - | '\027' when count < 3 -> - first (count + 1) - | ch -> - return ch - in - - first 0 >>= function - | '[' | 'O' -> - let rec loop () = - get () >>= function - | '0' .. '9' | ';' -> - loop () - | ch -> - return (Buffer.contents buf) - in - loop () - - | ch -> - return (Buffer.contents buf) - -let parse_key_raw st = - Lwt_stream.next st >>= function - | "\027" -> - begin - try_lwt - Lwt_stream.parse st parse_escape - with - Exit_sequence -> return "\027" - end - | ch -> - return ch - -type key = - | Key of string - | Key_up - | Key_down - | Key_left - | Key_right - | Key_f of int - | Key_next_page - | Key_previous_page - | Key_home - | Key_end - | Key_insert - | Key_delete - | Key_control of char - -let key_enter = Key_control 'j' -let key_escape = Key_control '[' -let key_tab = Key_control 'i' -let key_backspace = Key_control '?' - -let string_of_key = function - | Key ch -> - Printf.sprintf "Key %S" ch - | Key_f n -> - Printf.sprintf "Key_f %d" n - | Key_control c -> - Printf.sprintf "Key_control %C" c - | Key_up -> - "Key_up" - | Key_down -> - "Key_down" - | Key_left -> - "Key_left" - | Key_right -> - "Key_right" - | Key_next_page -> - "Key_next_page" - | Key_previous_page -> - "Key_previous_page" - | Key_home -> - "Key_home" - | Key_end -> - "Key_end" - | Key_insert -> - "Key_insert" - | Key_delete -> - "Key_delete" - -let sequence_mapping = [ - "\027[A", Key_up; - "\027[B", Key_down; - "\027[C", Key_right; - "\027[D", Key_left; - "\027A", Key_up; - "\027B", Key_down; - "\027C", Key_right; - "\027D", Key_left; - "\027OA", Key_up; - "\027OB", Key_down; - "\027OC", Key_right; - "\027OD", Key_left; - "\027[2~", Key_insert; - "\027[3~", Key_delete; - "\027[5~", Key_previous_page; - "\027[6~", Key_next_page; - "\027[7~", Key_home; - "\027[8~", Key_end; - "\027[11~", Key_f 1; - "\027[12~", Key_f 2; - "\027[13~", Key_f 3; - "\027[14~", Key_f 4; - "\027[15~", Key_f 5; - "\027[17~", Key_f 6; - "\027[18~", Key_f 7; - "\027[19~", Key_f 8; - "\027[20~", Key_f 9; - "\027[21~", Key_f 10; - "\027[23~", Key_f 11; - "\027[24~", Key_f 12; - "\027OP", Key_f 1; - "\027OQ", Key_f 2; - "\027OR", Key_f 3; - "\027OS", Key_f 4; - "\027[H", Key_home; - "\027[F", Key_end; - "\027OH", Key_home; - "\027OF", Key_end; - "\027H", Key_home; - "\027F", Key_end; -] - -let control_mapping = [ - 0x00, '@'; - 0x01, 'a'; - 0x02, 'b'; - 0x03, 'c'; - 0x04, 'd'; - 0x05, 'e'; - 0x06, 'f'; - 0x07, 'g'; - 0x08, 'h'; - 0x09, 'i'; - 0x0A, 'j'; - 0x0B, 'k'; - 0x0C, 'l'; - 0x0D, 'm'; - 0x0E, 'n'; - 0x0F, 'o'; - 0x10, 'p'; - 0x11, 'q'; - 0x12, 'r'; - 0x13, 's'; - 0x14, 't'; - 0x15, 'u'; - 0x16, 'v'; - 0x17, 'w'; - 0x18, 'x'; - 0x19, 'y'; - 0x1A, 'z'; - 0x1B, '['; - 0x1C, '\\'; - 0x1D, ']'; - 0x1E, '^'; - 0x1F, '_'; - 0x7F, '?'; -] - -let decode_key ch = - if ch = "" then invalid_arg "Lwt_term.decode_key"; - match ch with - | ch when String.length ch = 1 -> - begin try - Key_control(List.assoc (Char.code ch.[0]) control_mapping) - with - Not_found -> Key ch - end - | ch -> - begin try - List.assoc ch sequence_mapping - with - Not_found -> Key ch - end - -let standard_input = Lwt_text.read_chars Lwt_text.stdin - -let read_key () = - with_raw_mode (fun _ -> parse_key_raw standard_input >|= decode_key) - -(* +-----------------------------------------------------------------+ - | Styles | - +-----------------------------------------------------------------+ *) - -type color = int - -let default = -1 -let black = 0 -let red = 1 -let green = 2 -let yellow = 3 -let blue = 4 -let magenta = 5 -let cyan = 6 -let white = 7 -let lblack = black + 8 -let lred = red + 8 -let lgreen = green + 8 -let lyellow = yellow + 8 -let lblue = blue + 8 -let lmagenta = magenta + 8 -let lcyan = cyan + 8 -let lwhite = white + 8 - -type style = { - bold : bool; - underlined : bool; - blink : bool; - inverse : bool; - hidden : bool; - foreground : color; - background : color; -} - -module Codes = struct - let reset = 0 - let bold = 1 - let underlined = 4 - let blink = 5 - let inverse = 7 - let hidden = 8 - let foreground col = 30 + col - let background col = 40 + col -end - -let set_color num (r, g, b) = - write stdout (Printf.sprintf "\027]4;%d;rgb:%02x/%02x/%02x;\027\\" num r g b) - -(* +-----------------------------------------------------------------+ - | Rendering | - +-----------------------------------------------------------------+ *) - -type point = { - char : string; - style : style; -} - -let blank = { - char = " "; - style = { - bold = false; - underlined = false; - blink = false; - inverse = false; - hidden = false; - foreground = default; - background = default; - }; -} - -let rec add_int buf = function - | 0 -> - () - | n -> - add_int buf (n / 10); - Buffer.add_char buf (Char.unsafe_chr (48 + (n mod 10))) - -let render_char buf oc pt last_style = - lwt () = - if pt.style <> last_style then begin - Buffer.clear buf; - Buffer.add_string buf "\027[0"; - let mode n = function - | true -> - Buffer.add_char buf ';'; - add_int buf n - | false -> - () - and color f col = - if col = default then - () - else if col < 8 then begin - Buffer.add_char buf ';'; - add_int buf (f col) - end else begin - Buffer.add_char buf ';'; - add_int buf (f 8); - Buffer.add_string buf ";5;"; - add_int buf col; - end - in - mode Codes.bold pt.style.bold; - mode Codes.underlined pt.style.underlined; - mode Codes.blink pt.style.blink; - mode Codes.inverse pt.style.inverse; - mode Codes.hidden pt.style.hidden; - color Codes.foreground pt.style.foreground; - color Codes.background pt.style.background; - Buffer.add_char buf 'm'; - write oc (Buffer.contents buf) - end else - return () - in - write_char oc pt.char - -let render_update old m = - let buf = Buffer.create 16 in - Lwt_text.atomic begin fun oc -> - let rec loop_y y last_style = - if y < Array.length m then - let rec loop_x x last_style = - if x < Array.length m.(y) then - let pt = m.(y).(x) in - lwt () = render_char buf oc pt last_style in - loop_x (x + 1) pt.style - else - loop_y (y + 1) last_style - in - if y < Array.length old && old.(y) = m.(y) then begin - if y + 1 < Array.length m then - lwt last_style = - if Array.length m.(y) > 0 then - let pt = m.(y).(0) in - lwt () = render_char buf oc pt last_style in - return pt.style - else - return last_style - in - lwt () = write oc "\r\n" in - loop_y (y + 1) last_style - else - return () - end else - loop_x 0 last_style - else - return () - in - (* Go to the top-left corner and reset attributes: *) - lwt () = write oc "\027[H\027[0m" in - lwt () = loop_y 0 blank.style in - write oc "\027[0m" - end stdout - -let render m = render_update [||] m - -(* +-----------------------------------------------------------------+ - | Styled text | - +-----------------------------------------------------------------+ *) - -open Printf - -type styled_text_instruction = - | Text of Text.t - | Reset - | Bold - | Underlined - | Blink - | Inverse - | Hidden - | Foreground of color - | Background of color - -type styled_text = styled_text_instruction list - -let textf fmt = Printf.ksprintf (fun txt -> Text txt) fmt -let text txt = Text txt -let reset = Reset -let bold = Bold -let underlined = Underlined -let blink = Blink -let inverse = Inverse -let hidden = Hidden -let fg col = Foreground col -let bg col = Background col - -let strip_styles st = - let buf = Buffer.create 42 in - List.iter (function - | Text t -> Buffer.add_string buf t - | _ -> ()) st; - Buffer.contents buf - -let write_styled oc st = - let buf = Buffer.create 16 - - (* Pendings style codes: *) - and codes = Queue.create () in - - (* Output pending codes using only one escape sequence: *) - let output_pendings () = - Buffer.clear buf; - Buffer.add_string buf "\027["; - add_int buf (Queue.take codes); - Queue.iter (fun code -> - Buffer.add_char buf ';'; - add_int buf code) codes; - Queue.clear codes; - Buffer.add_char buf 'm'; - write oc (Buffer.contents buf) - in - - let rec loop = function - | [] -> - if not (Queue.is_empty codes) then - output_pendings () - else - return () - | instr :: rest -> - match instr with - | Text t -> - if not (Queue.is_empty codes) then - lwt () = output_pendings () in - lwt () = write oc t in - loop rest - else - lwt () = write oc t in - loop rest - | Reset -> - Queue.add 0 codes; - loop rest - | Bold -> - Queue.add Codes.bold codes; - loop rest - | Underlined -> - Queue.add Codes.underlined codes; - loop rest - | Blink -> - Queue.add Codes.blink codes; - loop rest - | Inverse -> - Queue.add Codes.inverse codes; - loop rest - | Hidden -> - Queue.add Codes.hidden codes; - loop rest - | Foreground col -> - if col = default then - Queue.add (Codes.foreground 9) codes - else if col < 8 then - Queue.add (Codes.foreground col) codes - else begin - Queue.add (Codes.foreground 8) codes; - Queue.add 5 codes; - Queue.add col codes - end; - loop rest - | Background col -> - if col = default then - Queue.add (Codes.background 9) codes - else if col < 8 then - Queue.add (Codes.background col) codes - else begin - Queue.add (Codes.background 8) codes; - Queue.add 5 codes; - Queue.add col codes - end; - loop rest - in - loop st - -let styled_length st = - let rec loop len = function - | [] -> len - | Text t :: l -> loop (len + Text.length t) l - | _ :: l -> loop len l - in - loop 0 st - -let printc st = - Lwt_unix.isatty Lwt_unix.stdout >>= function - | true -> - atomic (fun oc -> write_styled oc st) stdout - | false -> - write stdout (strip_styles st) - -let eprintc st = - Lwt_unix.isatty Lwt_unix.stderr >>= function - | true -> - atomic (fun oc -> write_styled oc st) stderr - | false -> - write stderr (strip_styles st) - -let fprintlc oc fd st = - Lwt_unix.isatty fd >>= function - | true -> - atomic (fun oc -> - lwt () = write_styled oc st in - lwt () = write oc "\027[m" in - write_char oc "\n") oc - | false -> - write_line oc (strip_styles st) - -let printlc st = fprintlc stdout Lwt_unix.stdout st -let eprintlc st = fprintlc stderr Lwt_unix.stderr st - -(* +-----------------------------------------------------------------+ - | Drawing | - +-----------------------------------------------------------------+ *) - -module Zone = -struct - type t = { - points : point array array; - x : int; - y : int; - width : int; - height : int; - } - - let points zone = zone.points - let x zone = zone.x - let y zone = zone.y - let width zone = zone.width - let height zone = zone.height - - let make ~width ~height = - if width < 0 || height < 0 then invalid_arg "Lwt_term.Zone.make"; - { - points = Array.make_matrix height width blank; - x = 0; - y = 0; - width = width; - height = height; - } - - let sub ~zone ~x ~y ~width ~height = - if (x < 0 || y < 0 || - width < 0 || height < 0 || - x + width > zone.width || - y + height > zone.height) then - invalid_arg "Lwt_term.Zone.sub"; - { - points = zone.points; - x = zone.x + x; - y = zone.y + y; - width = width; - height = height; - } - - let inner zone = { - points = zone.points; - x = if zone.width >= 2 then zone.x + 1 else zone.x; - y = if zone.height >= 2 then zone.y + 1 else zone.y; - width = if zone.width >= 2 then zone.width - 2 else zone.width; - height = if zone.height >= 2 then zone.height - 2 else zone.height; - } -end - -module Draw = -struct - open Zone - - let get ~zone ~x ~y = - if x < 0 || y < 0 || x >= zone.width || y >= zone.height then - invalid_arg "Lwt_term.Draw.get"; - zone.points.(zone.y + y).(zone.x + x) - - let set ~zone ~x ~y ~point = - if x < 0 || y < 0 || x >= zone.width || y >= zone.height then - () - else - zone.points.(zone.y + y).(zone.x + x) <- point - - let map ~zone ~x ~y f = - if x < 0 || y < 0 || x >= zone.width || y >= zone.height then - () - else - let x = zone.x + x and y = zone.y + y in - zone.points.(y).(x) <- f zone.points.(y).(x) - - let text ~zone ~x ~y ~text = - let rec loop x ptr = match Text.next ptr with - | Some(ch, ptr) -> - set zone x y { blank with char = ch }; - loop (x + 1) ptr - | None -> - () - in - loop x (Text.pointer_l text) - - let textf zone x y fmt = - Printf.ksprintf (fun txt -> text zone x y txt) fmt - - let textc ~zone ~x ~y ~text = - let rec loop style x = function - | [] -> - () - | instr :: rest -> - match instr with - | Text text -> - loop_text style x (Text.pointer_l text) rest - | Reset -> - loop blank.style x rest - | Bold -> - loop { style with bold = true } x rest - | Underlined -> - loop { style with underlined = true } x rest - | Blink -> - loop { style with blink = true } x rest - | Inverse -> - loop { style with inverse = true } x rest - | Hidden -> - loop { style with hidden = true } x rest - | Foreground color -> - loop { style with foreground = color } x rest - | Background color -> - loop { style with background = color } x rest - and loop_text style x ptr rest = - match Text.next ptr with - | Some(ch, ptr) -> - set zone x y { char = ch; style = style }; - loop_text style (x + 1) ptr rest - | None -> - loop style x rest - in - loop blank.style x text -end diff --git a/server/thirdparty/lwt-2.3.2/src/text/lwt_term.mli b/server/thirdparty/lwt-2.3.2/src/text/lwt_term.mli deleted file mode 100644 index 7022a9d..0000000 --- a/server/thirdparty/lwt-2.3.2/src/text/lwt_term.mli +++ /dev/null @@ -1,393 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_term - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Terminal control *) - -(** This modules allow you to write interactive programs using the - terminal. *) - -val with_raw_mode : (unit -> 'a Lwt.t) -> 'a Lwt.t - (** [with_raw_mode f] executes [f] while the terminal is in ``raw - mode''. Raw mode means that character are returned as the user - type them (otherwise only complete line are returned to the - program). - - If the terminal is already in raw mode, it just calls [f]. *) - -val raw_mode : unit -> bool - (** Returns wether the terminal is currently in raw mode *) - -val enter_drawing_mode : unit -> unit Lwt.t - (** Put the terminal into drawing mode *) - -val leave_drawing_mode : unit -> unit Lwt.t - (** Restore the state of the terminal *) - -val show_cursor : unit -> unit Lwt.t - (** [show_cursor ()] makes the cursor visible *) - -val hide_cursor : unit -> unit Lwt.t - (** [hide_cursor ()] makes the cursor invisible *) - -val clear_screen : unit -> unit Lwt.t - (** [clear_screen ()] clears the entire screen *) - -val clear_line : unit -> unit Lwt.t - (** [clear_line ()] clears the current line *) - -val goto_beginning_of_line : int -> unit Lwt.t - (** [goto_beginning_of_line n] put the cursor at the beginning of - the [n]th previous line. - - - [goto_beginning_of_line 0] goes to the beginning of the current line - - [goto_beginning_of_line 1] goes to the beginning of the previous line - - ... - *) - -(** {6 Terminal informations} *) - -(** Terminal sizes: *) -type size = { - lines : int; - columns : int; -} - -val size : size React.signal - (** Size of the terminal. *) - -val columns : int React.signal - (** Number of columns of the terminal *) - -val lines : int React.signal - (** Number of lines of the terminal *) - -(** {6 Keys} *) - -val parse_key_raw : Text.t Lwt_stream.t -> Text.t Lwt.t - (** [parse_key_raw st] recognize escape sequence in a stream of - unicode character. - - It returns either: - - either single characters, like ["a"], ["é"], ... - - either escape sequences - *) - -(** Type of ``decoded'' keys. - - This list is not exhaustive, but at least it should works on all - terminals: *) -type key = - | Key of Text.t - (** A unicode character or an uninterpreted sequence *) - | Key_up - | Key_down - | Key_left - | Key_right - | Key_f of int - | Key_next_page - | Key_previous_page - | Key_home - | Key_end - | Key_insert - | Key_delete - | Key_control of char - (** A control key *) - -val string_of_key : key -> string - (** [string_of_key key] string representation of a key *) - -val control_mapping : (int * char) list - (** Mapping from control key codes to character codes. - - Here is the list of control keys: - - {[ - +------+-------+------+------+------+-------+------------------------------------------------+ - | Char | Oct | Dec | Name | Hex | Key | Comment | - +------+-------+------+------+------+-------+------------------------------------------------+ - | '@' | 0o00 | 0 | NUL | 0x00 | ^@ \0 | Null byte | - | 'a' | 0o01 | 1 | SOH | 0x01 | ^A | Start of heading | - | 'b' | 0o02 | 2 | STX | 0x02 | ^B | Start of text | - | 'c' | 0o03 | 3 | ETX | 0x03 | ^C | End of text | - | 'd' | 0o04 | 4 | EOT | 0x04 | ^D | End of transmission | - | 'e' | 0o05 | 5 | ENQ | 0x05 | ^E | Enquiry | - | 'f' | 0o06 | 6 | ACK | 0x06 | ^F | Acknowledge | - | 'g' | 0o07 | 7 | BEL | 0x07 | ^G | Ring terminal bell | - | 'h' | 0o10 | 8 | BS | 0x08 | ^H \b | Backspace | - | 'i' | 0o11 | 9 | HT | 0x09 | ^I \t | Horizontal tab | - | 'j' | 0o12 | 10 | LF | 0x0a | ^J \n | Line feed | - | 'k' | 0o13 | 11 | VT | 0x0b | ^K | Vertical tab | - | 'l' | 0o14 | 12 | FF | 0x0c | ^L \f | Form feed | - | 'm' | 0o15 | 13 | CR | 0x0d | ^M \r | Carriage return | - | 'n' | 0o16 | 14 | SO | 0x0e | ^N | Shift out | - | 'o' | 0o17 | 15 | SI | 0x0f | ^O | Shift in | - | 'p' | 0o20 | 16 | DLE | 0x10 | ^P | Data link escape | - | 'q' | 0o21 | 17 | DC1 | 0x11 | ^Q | Device control 1 (XON) | - | 'r' | 0o22 | 18 | DC2 | 0x12 | ^R | Device control 2 | - | 's' | 0o23 | 19 | DC3 | 0x13 | ^S | Device control 3 (XOFF) | - | 't' | 0o24 | 20 | DC4 | 0x14 | ^T | Device control 4 | - | 'u' | 0o25 | 21 | NAK | 0x15 | ^U | Negative acknowledge | - | 'v' | 0o26 | 22 | SYN | 0x16 | ^V | Synchronous idle | - | 'w' | 0o27 | 23 | ETB | 0x17 | ^W | End of transmission block | - | 'x' | 0o30 | 24 | CAN | 0x18 | ^X | Cancel | - | 'y' | 0o31 | 25 | EM | 0x19 | ^Y | End of medium | - | 'z' | 0o32 | 26 | SUB | 0x1a | ^Z | Substitute character | - | '[' | 0o33 | 27 | ESC | 0x1b | ^[ | Escape | - | '\' | 0o34 | 28 | FS | 0x1c | ^\ | File separator, Information separator four | - | ']' | 0o35 | 29 | GS | 0x1d | ^] | Group separator, Information separator three | - | '^' | 0o36 | 30 | RS | 0x1e | ^^ | Record separator, Information separator two | - | '_' | 0o37 | 31 | US | 0x1f | ^_ | Unit separator, Information separator one | - | '?' | 0o177 | 127 | DEL | 0x7f | ^? | Delete | - +------+-------+------+------+------+-------+------------------------------------------------+ - ]} - *) - -val key_enter : key - (** [key_enter = Key_control 'j'] *) - -val key_escape : key - (** [key_escape = Key_control '\['] *) - -val key_tab : key - (** [key_escape = Key_control 'i'] *) - -val key_backspace : key - (** [key_backspace = Key_control '?'] *) - -val sequence_mapping : (Text.t * key) list - (** Mapping from sequence to keys *) - -val decode_key : Text.t -> key - (** Decode a key. *) - -val standard_input : Text.t Lwt_stream.t - (** The input stream used by {!read_key} *) - -val read_key : unit -> key Lwt.t - (** Get and decode a key from {!standard_input} *) - -(** {6 Styles} *) - -type color = int - (** Type of a color. Most modern terminals support either 88 or - 256 colors. *) - -val set_color : color -> int * int * int -> unit Lwt.t - (** [set_color num (red, green, blue)] sets the three components of - the color number [num] *) - -(** {8 Standard colors} *) - -val default : color -val black : color -val red : color -val green : color -val yellow : color -val blue : color -val magenta : color -val cyan : color -val white : color - -(** {8 Light colors} *) - -(** Note: these colors are not supposed to works on all terminals, but - in practice it works with all modern ones. By the way, using - standard colors + bold mode will give the same result as using a - light color. *) - -val lblack : color -val lred : color -val lgreen : color -val lyellow : color -val lblue : color -val lmagenta : color -val lcyan : color -val lwhite : color - -(** {8 Text with styles} *) - -(** Elmement of a styled-text *) -type styled_text_instruction = - | Text of Text.t - (** Some text *) - | Reset - (** Resets all styles to default *) - | Bold - | Underlined - | Blink - | Inverse - | Hidden - | Foreground of color - | Background of color - -type styled_text = styled_text_instruction list - (** A styled text is a list of instructions *) - -val textf : ('a, unit, string, styled_text_instruction) format4 -> 'a - (** [textf fmt] formats a texts with [fmt] and returns [Text txt] *) - -val text : Text.t -> styled_text_instruction -val reset : styled_text_instruction -val bold : styled_text_instruction -val underlined : styled_text_instruction -val blink : styled_text_instruction -val inverse : styled_text_instruction -val hidden : styled_text_instruction - -val fg : color -> styled_text_instruction - (** [fg col = Foreground col] *) - -val bg : color -> styled_text_instruction - (** [bg col = Background col] *) - -val strip_styles : styled_text -> Text.t - (** Drop all styles *) - -val styled_length : styled_text -> int - (** Returns the length (in unicode character) of the given styled - text. The following equality holds for all styled-texts: - - [styled_length st = Text.length (strip_styles st)] - *) - -val write_styled : Lwt_text.output_channel -> styled_text -> unit Lwt.t - (** [write_styled oc st] writes [st] on [oc] using escape - sequences. *) - -val printc : styled_text -> unit Lwt.t - (** [printc st] prints the given styled text on standard output. If - stdout is not a tty, then styles are stripped. - - The text is encoded to the system encoding before being - output. *) - -val eprintc : styled_text -> unit Lwt.t - (** Same as [printc] but prints on stderr. *) - -val printlc : styled_text -> unit Lwt.t - (** [printlc st] prints [st], then reset styles and prints a - newline *) - -val eprintlc : styled_text -> unit Lwt.t - (** Same as [printlc] but prints on stderr *) - -(** {6 Rendering} *) - -(** Character styles *) -type style = { - bold : bool; - underlined : bool; - blink : bool; - inverse : bool; - hidden : bool; - foreground : color; - background : color; -} - -(** A character on the screen: *) -type point = { - char : Text.t; - (** The character. *) - style : style; - (** The character style *) -} - -val blank : point - (** A space with default color and styles *) - -val render : point array array -> unit Lwt.t - (** Render an offscreen array to the terminal. *) - -val render_update : point array array -> point array array -> unit Lwt.t - (** [render_update displayed to_display] does the same as [render - to_display] but assumes that [displayed] contains the current - displayed text. This reduces the amount of text sent to the - terminal. *) - -(** {6 Drawing} *) - -(** Off-screen zones *) -module Zone : sig - type t = { - points : point array array; - (** The off-screen matrix *) - - x : int; - y : int; - (** Absolute coordinates of the top-left corner of the zone *) - - width : int; - height : int; - (** Dimmensions of the zone *) - } - - val points : t -> point array array - val x : t -> int - val y : t -> int - val width : t -> int - val height : t -> int - - val make : width : int -> height : int -> t - (** Make a new zone where all points are initialized to - {!blank} *) - - val sub : zone : t -> x : int -> y : int -> width : int -> height : int -> t - (** [sub ~zone ~x ~y ~width ~height] creates a sub-zone of - [zone]. [x] and [y] are relatives to the zone top left corner. - - @raise Invalid_argument if the sub zone is not included in - [zone]*) - - val inner : t -> t - (** [inner zone] returns the inner part of [zone] *) -end - -(** Drawing helpers *) -module Draw : sig - - (** Note: except for {!get}, all function ignore points that are - outside the zone *) - - val get : zone : Zone.t -> x : int -> y : int -> point - (** [get ~zone ~x ~y] returns the point at relative position [x] - and [y]. - - @raise Invalid_argument if the coordinates are outside the - zone *) - - val set : zone : Zone.t -> x : int -> y : int -> point : point -> unit - (** [set ~zone ~x ~y ~popint] sets point at relative position [x] - and [y]. *) - - val map : zone : Zone.t -> x : int -> y : int -> (point -> point) -> unit - (** [map ~zone ~x ~y f] replace the point at coordinates [(x, y)] - by the result of [f] applied on it. *) - - val text : zone : Zone.t -> x : int -> y : int -> text : Text.t -> unit - (** Draw the given text at the given positon *) - - val textf : Zone.t -> int -> int -> ('a, unit, string, unit) format4 -> 'a - (** Same as {!text} but uses a format string *) - - val textc : zone : Zone.t -> x : int -> y : int -> text : styled_text -> unit - (** Same as {!text} but takes a text with styles *) -end diff --git a/server/thirdparty/lwt-2.3.2/src/text/lwt_text.ml b/server/thirdparty/lwt-2.3.2/src/text/lwt_text.ml deleted file mode 100644 index 9d808c4..0000000 --- a/server/thirdparty/lwt-2.3.2/src/text/lwt_text.ml +++ /dev/null @@ -1,337 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_text - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt -open Lwt_io - -(* +-----------------------------------------------------------------+ - | Types and creation | - +-----------------------------------------------------------------+ *) - -type coder = - | Encoder of Encoding.encoder - | Decoder of Encoding.decoder - -type 'a channel = { - channel : 'a Lwt_io.channel; - encoding : Text.t; - coder : coder; - strict : bool; -} - -type input_channel = Lwt_io.input channel -type output_channel = Lwt_io.output channel - -let encoder = function - | Encoder e -> e - | Decoder _ -> assert false - -let decoder = function - | Encoder _ -> assert false - | Decoder d -> d - -#if ocaml_version >= (3, 13) -let make : type m. ?strict : bool -> ?encoding : string -> m Lwt_io.channel -> m channel = fun ?(strict=false) ?(encoding=Encoding.system) ch -> -#else -let make ?(strict=false) ?(encoding=Encoding.system) ch = -#endif - { channel = ch; - encoding = encoding; - strict = strict; - coder = match Lwt_io.mode ch with - | Input -> - Decoder(Encoding.decoder encoding) - | Output -> - Encoder(Encoding.encoder(if strict then encoding else encoding ^ "//TRANSLIT")) } - -let byte_channel ch = ch.channel -let encoding ch = ch.encoding - -let close ch = Lwt_io.close ch.channel -let flush ch = Lwt_io.flush ch.channel - -let atomic f ch = Lwt_io.atomic (fun ch' -> f { ch with channel = ch' }) ch.channel - -let open_file ?buffer_size ?strict ?encoding ?flags ?perm ~mode name = - lwt ch = Lwt_io.open_file ?flags ?perm ~mode name in - return (make ?strict ?encoding ch) - -let with_file ?buffer_size ?strict ?encoding ?flags ?perm ~mode name f = - Lwt_io.with_file ?flags ?perm ~mode name (fun ch -> f (make ?strict ?encoding ch)) - -module Primitives = -struct - (* +---------------------------------------------------------------+ - | Primitives for reading | - +---------------------------------------------------------------+ *) - - let rec read_char da strict decoder = - let ptr = da.da_ptr and max = da.da_max in - if ptr = max then - da.da_perform () >>= function - | 0 -> raise_lwt End_of_file - | _ -> read_char da strict decoder - else - match Encoding_bigarray.decode decoder da.da_buffer ptr (max - ptr) with - | Encoding.Dec_ok(code, count) -> - da.da_ptr <- ptr + count; - return (Text.char code) - | Encoding.Dec_need_more -> - da.da_perform () >>= begin function - | 0 -> - if strict then - raise_lwt (Failure "Lwt_text.read_char: unterminated multibyte sequence") - else begin - da.da_ptr <- ptr + 1; - return (Text.char (Char.code da.da_buffer.{ptr})) - end - | _ -> - read_char da strict decoder - end - | Encoding.Dec_error -> - if strict then - raise_lwt (Failure "Lwt_text.read_char: unterminated multibyte sequence") - else begin - da.da_ptr <- ptr + 1; - return (Text.char (Char.code da.da_buffer.{ptr})) - end - - let read_char_opt da strict decoder = - try_lwt - read_char da strict decoder >|= fun ch -> Some ch - with - | End_of_file -> - return None - | exn -> - raise_lwt exn - - let rec read_all da strict decoder buf = - lwt ch = read_char da strict decoder in - Buffer.add_string buf ch; - read_all da strict decoder buf - - let rec read_count da strict decoder buf = function - | 0 -> - return (Buffer.contents buf) - | n -> - lwt ch = read_char da strict decoder in - Buffer.add_string buf ch; - read_count da strict decoder buf (n - 1) - - let read count da strict decoder = match count with - | None -> - let buf = Buffer.create 512 in - begin - try_lwt - read_all da strict decoder buf - with - | End_of_file -> - return (Buffer.contents buf) - end - | Some 0 -> - return "" - | Some 1 -> - begin - try_lwt - read_char da strict decoder - with - | End_of_file -> - return "" - end - | Some len -> - let buf = Buffer.create len in - begin - try_lwt - read_count da strict decoder buf len - with - | End_of_file -> - return (Buffer.contents buf) - end - - let read_line da strict decoder = - let buf = Buffer.create 128 in - let rec loop cr_read = - try_bind (fun _ -> read_char da strict decoder) - (function - | "\n" -> - return(Buffer.contents buf) - | "\r" -> - if cr_read then Buffer.add_char buf '\r'; - loop true - | ch -> - if cr_read then Buffer.add_char buf '\r'; - Buffer.add_string buf ch; - loop false) - (function - | End_of_file -> - if cr_read then Buffer.add_char buf '\r'; - return(Buffer.contents buf) - | exn -> - raise_lwt exn) - in - read_char da strict decoder >>= function - | "\r" -> loop true - | "\n" -> return "" - | ch -> Buffer.add_string buf ch; loop false - - let read_line_opt da strict decoder = - try_lwt - read_line da strict decoder >|= fun ch -> Some ch - with - | End_of_file -> - return None - | exn -> - raise_lwt exn - - (* +---------------------------------------------------------------+ - | Primitives for writing | - +---------------------------------------------------------------+ *) - - let rec write_code da encoder code = - match Encoding_bigarray.encode encoder da.da_buffer da.da_ptr (da.da_max - da.da_ptr) code with - | Encoding.Enc_ok count -> - da.da_ptr <- da.da_ptr + count; - return () - | Encoding.Enc_need_more -> - lwt _ = da.da_perform () in - write_code da encoder code - | Encoding.Enc_error -> - raise_lwt (Failure "Lwt_text: cannot encode character") - - let byte str pos = Char.code (String.unsafe_get str pos) - - let next_code str i len = - let n = byte str i in - let rec trail j acc = function - | 0 -> - (j, acc) - | count -> - if j = len then - (i + 1, n) - else - let m = byte str j in - if m land 0xc0 = 0x80 then - trail (j + 1) ((acc lsl 6) lor (m land 0x3f)) (count - 1) - else - (i + 1, n) - in - if n land 0x80 = 0 then - (i + 1, n) - else if n land 0xe0 = 0xc0 then - trail (i + 1) (n land 0x1f) 1 - else if n land 0xf0 = 0xe0 then - trail (i + 1) (n land 0x0f) 2 - else if n land 0xf8 = 0xf0 then - trail (i + 1) (n land 0x07) 3 - else - (i + 1, n) - - let write_char da strict encoder = function - | "" -> - raise_lwt (Invalid_argument "Lwt_text.write_char: empty text") - | ch -> - let _, code = next_code ch 0 (String.length ch) in - write_code da encoder code - - let rec write_all da strict encoder str i len = - if i = len then - return () - else - let i, code = next_code str i len in - lwt () = write_code da encoder code in - write_all da strict encoder str i len - - let write da strict encoder txt = - write_all da strict encoder txt 0 (String.length txt) - - let write_line da strict encoder txt = - lwt () = write_all da strict encoder txt 0 (String.length txt) in - write_code da encoder 10 -end - -let read_char ic = direct_access ic.channel (fun da -> Primitives.read_char da ic.strict (decoder ic.coder)) -let read_char_opt ic = direct_access ic.channel (fun da -> Primitives.read_char_opt da ic.strict (decoder ic.coder)) -let read ?count ic = direct_access ic.channel (fun da -> Primitives.read count da ic.strict (decoder ic.coder)) -let read_line ic = direct_access ic.channel (fun da -> Primitives.read_line da ic.strict (decoder ic.coder)) -let read_line_opt ic = direct_access ic.channel (fun da -> Primitives.read_line_opt da ic.strict (decoder ic.coder)) -let read_chars ic = Lwt_stream.from (fun _ -> read_char_opt ic) -let read_lines ic = Lwt_stream.from (fun _ -> read_line_opt ic) - -let write_char oc x = direct_access oc.channel (fun da -> Primitives.write_char da oc.strict (encoder oc.coder) x) -let write_line oc x = direct_access oc.channel (fun da -> Primitives.write_line da oc.strict (encoder oc.coder) x) -let write oc x = direct_access oc.channel (fun da -> Primitives.write da oc.strict (encoder oc.coder) x) -let write_chars oc st = Lwt_stream.iter_s (write_char oc) st -let write_lines oc st = Lwt_stream.iter_s (write_line oc) st - -let stdin = make Lwt_io.stdin -let stdout = make Lwt_io.stdout -let stderr = make Lwt_io.stderr -let null = make Lwt_io.null -let zero = make Lwt_io.zero - -let fprint oc txt = write oc txt -let fprintl oc txt = write_line oc txt -let fprintf oc fmt = Printf.ksprintf (fun txt -> write oc txt) fmt -let fprintlf oc fmt = Printf.ksprintf (fun txt -> write_line oc txt) fmt - -let print txt = write stdout txt -let printl txt = write_line stdout txt -let printf fmt = Printf.ksprintf print fmt -let printlf fmt = Printf.ksprintf printl fmt - -let eprint txt = write stderr txt -let eprintl txt = write_line stderr txt -let eprintf fmt = Printf.ksprintf eprint fmt -let eprintlf fmt = Printf.ksprintf eprintl fmt - -let ignore_close ch = - ignore (close ch) - -let make_stream f lazy_ic = - let lazy_ic = - lazy(lwt ic = Lazy.force lazy_ic in - Gc.finalise ignore_close ic; - return ic) - in - Lwt_stream.from (fun _ -> - lwt ic = Lazy.force lazy_ic in - try_lwt - f ic >|= fun x -> Some x - with - | End_of_file -> - lwt () = close ic in - return None) - -let lines_of_file filename = - make_stream read_line (lazy(open_file ~mode:input filename)) - -let lines_to_file filename lines = - with_file ~mode:output filename (fun oc -> write_lines oc lines) - -let chars_of_file filename = - make_stream read_char (lazy(open_file ~mode:input filename)) - -let chars_to_file filename chars = - with_file ~mode:output filename (fun oc -> write_chars oc chars) - -let hexdump_stream oc stream = write_lines oc (Lwt_stream.hexdump stream) -let hexdump oc buf = hexdump_stream oc (Lwt_stream.of_string buf) diff --git a/server/thirdparty/lwt-2.3.2/src/text/lwt_text.mli b/server/thirdparty/lwt-2.3.2/src/text/lwt_text.mli deleted file mode 100644 index 5b0e183..0000000 --- a/server/thirdparty/lwt-2.3.2/src/text/lwt_text.mli +++ /dev/null @@ -1,128 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_text - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Text channels *) - -(** This modules implements {b text channel}s. A {b text channel} is - basically a {b byte channel} (as in {!Lwt_io}) plus a {b character - encoding}. - - It has almost the same interface as {!Lwt_io} except that it - uses [Text.t] in place of [string] and [char] -*) - -open Lwt_io - -(** {6 Types} *) - -type 'mode channel - (** Type of a text channel *) - -type input_channel = input channel - (** Type of a text input channel *) - -type output_channel = output channel - (** Type of a text output channel *) - -(** {6 Creation/manipulation} *) - -val make : ?strict : bool -> ?encoding : Encoding.t -> 'a Lwt_io.channel -> 'a channel - (** [make ?strict ?encoding ch] creates a text channel from a byte - channel. - - @param strict tell whether encoding/decoding must be ``strict'', - which whether the encoder/decoder should fail on invalid - sequence. In non-strict mode, it transparently fallback to - ISO-8859-15. By the way it is ensured that [read*] functions - always returns valid UTF-8 encoded text. [strict] defaults to - [false]. - - @param encoding is the character encoding used for the - channel. It defaults to [Encoding.system]. *) - -val byte_channel : 'a channel -> 'a Lwt_io.channel - (** [byte_channel ch] returns the underlying byte channel of a text - channel *) - -val encoding : 'a channel -> Encoding.t - (** [encoding ch] returns the character encoding of a channel. *) - -val flush : output_channel -> unit Lwt.t - (** Flush the underlying byte channel *) - -val close : 'a channel -> unit Lwt.t - (** Close the underlying byte channel *) - -(** {6 Lwt_io like values} *) - -val atomic : ('a channel -> 'b Lwt.t) -> ('a channel -> 'b Lwt.t) -val stdin : input_channel -val stdout : output_channel -val stderr : output_channel -val zero : input_channel -val null : output_channel -val read_char : input_channel -> Text.t Lwt.t -val read_char_opt : input_channel -> Text.t option Lwt.t -val read_chars : input_channel -> Text.t Lwt_stream.t -val read_line : input_channel -> Text.t Lwt.t -val read_line_opt : input_channel -> Text.t option Lwt.t -val read_lines : input_channel -> Text.t Lwt_stream.t -val read : ?count : int -> input_channel -> Text.t Lwt.t -val write_char : output_channel -> Text.t -> unit Lwt.t -val write_chars : output_channel -> Text.t Lwt_stream.t -> unit Lwt.t -val write : output_channel -> Text.t -> unit Lwt.t -val write_line : output_channel -> Text.t -> unit Lwt.t -val write_lines : output_channel -> Text.t Lwt_stream.t -> unit Lwt.t -val open_file : - ?buffer_size : int -> - ?strict : bool -> - ?encoding : Encoding.t -> - ?flags : Unix.open_flag list -> - ?perm : Unix.file_perm -> - mode : 'a mode -> - file_name -> 'a channel Lwt.t -val with_file : - ?buffer_size : int -> - ?strict : bool -> - ?encoding : Encoding.t -> - ?flags : Unix.open_flag list -> - ?perm : Unix.file_perm -> - mode : 'a mode -> - file_name -> ('a channel -> 'b Lwt.t) -> 'b Lwt.t -val lines_of_file : file_name -> Text.t Lwt_stream.t -val lines_to_file : file_name -> Text.t Lwt_stream.t -> unit Lwt.t -val chars_of_file : file_name -> Text.t Lwt_stream.t -val chars_to_file : file_name -> Text.t Lwt_stream.t -> unit Lwt.t -val fprint : output_channel -> Text.t -> unit Lwt.t -val fprintl : output_channel -> Text.t -> unit Lwt.t -val fprintf : output_channel -> ('a, unit, Text.t, unit Lwt.t) format4 -> 'a -val fprintlf : output_channel -> ('a, unit, Text.t, unit Lwt.t) format4 -> 'a -val print : Text.t -> unit Lwt.t -val printl : Text.t -> unit Lwt.t -val printf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a -val printlf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a -val eprint : Text.t -> unit Lwt.t -val eprintl : Text.t -> unit Lwt.t -val eprintf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a -val eprintlf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a -val hexdump_stream : output_channel -> char Lwt_stream.t -> unit Lwt.t -val hexdump : output_channel -> string -> unit Lwt.t diff --git a/server/thirdparty/lwt-2.3.2/src/text/lwt_text_stubs.c b/server/thirdparty/lwt-2.3.2/src/text/lwt_text_stubs.c deleted file mode 100644 index 3e2a929..0000000 --- a/server/thirdparty/lwt-2.3.2/src/text/lwt_text_stubs.c +++ /dev/null @@ -1,84 +0,0 @@ -/* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_text_stubs - * Copyright (C) 2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - */ - -#if defined(_WIN32) || defined(_WIN64) -# include -# include -#else -# include -# include -# include -# include -#endif - -#include "../unix/lwt_unix.h" - -#include -#include - -/* +-----------------------------------------------------------------+ - | Terminal sizes | - +-----------------------------------------------------------------+ */ - -#if defined(LWT_ON_WINDOWS) - -CAMLprim value lwt_text_term_size(value fd) -{ - HANDLE handle; - CONSOLE_SCREEN_BUFFER_INFO info; - - if (!GetConsoleScreenBufferInfo(Handle_val(fd), &info)) { - win32_maperr(GetLastError()); - uerror("GetConsoleScreenBufferInfo", Nothing); - } - - value result = caml_alloc_tuple(2); - Field(result, 0) = Val_int(info.dwSize.X); - Field(result, 1) = Val_int(info.dwSize.Y); - return result; -} - -#else - -CAMLprim value lwt_text_term_size(value fd) -{ - struct winsize size; - - if (ioctl(Int_val(fd), TIOCGWINSZ, &size) < 0) - uerror("ioctl", Nothing); - - value result = caml_alloc_tuple(2); - Field(result, 0) = Val_int(size.ws_row); - Field(result, 1) = Val_int(size.ws_col); - return result; -} - -CAMLprim value lwt_text_sigwinch() -{ -#ifdef SIGWINCH - return Val_int(SIGWINCH); -#else - return Val_int(0); -#endif -} - -#endif diff --git a/server/thirdparty/lwt-2.3.2/src/top/lwt-top.mllib b/server/thirdparty/lwt-2.3.2/src/top/lwt-top.mllib deleted file mode 100644 index c8314f9..0000000 --- a/server/thirdparty/lwt-2.3.2/src/top/lwt-top.mllib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 6aba40695d6f4091d2063c4b620ae589) -Lwt_top -Lwt_ocaml_completion -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/top/lwt_ocaml_completion.mll b/server/thirdparty/lwt-2.3.2/src/top/lwt_ocaml_completion.mll deleted file mode 100644 index e50a3ac..0000000 --- a/server/thirdparty/lwt-2.3.2/src/top/lwt_ocaml_completion.mll +++ /dev/null @@ -1,194 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_ocaml_completion - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -{ - open Toploop - open Lwt - open Lwt_read_line - - module TextSet = Set.Make(Text) - - let set_of_list = List.fold_left (fun set x -> TextSet.add x set) TextSet.empty - - let keywords = set_of_list [ - "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; - "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; - "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; - "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; - "mutable"; "new"; "object"; "of"; "open"; "private"; "rec"; "sig"; - "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; - "when"; "while"; "with"; "try_lwt"; "finally"; "for_lwt"; "lwt"; - ] - - let get_directives () = - Hashtbl.fold (fun k v set -> TextSet.add k set) Toploop.directive_table TextSet.empty - - let complete_ident = ref (fun before ident after -> complete ~suffix:"" before ident after keywords) - let restart = ref (fun () -> ()) - - let list_files filter fname = - let dir = Filename.dirname fname in - Array.fold_left (fun set name -> - let absolute_name = Filename.concat dir name in - if try Sys.is_directory absolute_name with _ -> false then - TextSet.add (Filename.concat name "") set - else if filter name then - TextSet.add name set - else - set) - TextSet.empty - (Sys.readdir (if dir = "" then Filename.current_dir_name else dir)) - - let list_directories fname = - let dir = Filename.dirname fname in - Array.fold_left (fun set name -> - let name = Filename.concat dir name in - if try Sys.is_directory name with _ -> false then - TextSet.add name set - else - set) - TextSet.empty - (Sys.readdir (if dir = "" then Filename.current_dir_name else dir)) -} - -let lower = ['a'-'z'] -let upper = ['A'-'Z'] -let alpha = lower | upper -let digit = ['0'-'9'] -let alnum = alpha | digit -let punct = ['!' '"' '#' '$' '%' '&' '\'' '(' ')' '*' '+' ',' '-' '.' '/' ':' ';' '<' '=' '>' '?' '@' '[' '\\' ']' '^' '_' '`' '{' '|' '}' '~'] -let graph = alnum | punct -let print = graph | ' ' -let blank = ' ' | '\t' -let cntrl = ['\x00'-'\x1F' '\x7F'] -let xdigit = digit | ['a'-'f' 'A'-'F'] -let space = blank | ['\n' '\x0b' '\x0c' '\r'] - -let uchar = ['\x00' - '\x7f'] | _ [ '\x80' - '\xbf' ]* - -let identstart = [ 'A'-'Z' 'a'-'z' '_' ] -let identbody = [ 'A'-'Z' 'a'-'z' '_' '\'' '0' - '9' ] -let ident = identstart identbody* -let maybe_ident = "" | ident - -(* Parse a line of input. [before] correspond to the input before the - cursor and [after] to the input after the cursor. The lexing buffer - is created from [before]. *) - -rule complete_input before after = parse - - (* Completion over directives *) - | (blank* '#' blank* as before') (maybe_ident as dir) (blank* as bl) eof { - if Hashtbl.mem Toploop.directive_table dir then - return (match Hashtbl.find Toploop.directive_table dir with - | Directive_none _ -> - { comp_state = (before ^ ";;", after); - comp_words = TextSet.empty } - | Directive_string _ -> - { comp_state = (before ^ (if bl = "" then " \"" else "\""), after); - comp_words = TextSet.empty } - | Directive_bool _ -> - { comp_state = ((if bl = "" then before ^ " " else ""), after); - comp_words = set_of_list ["false"; "true"] } - | Directive_int _ | Directive_ident _ -> - { comp_state = ((if bl = "" then before ^ " " else ""), after); - comp_words = TextSet.empty }) - else - return (match lookup dir (get_directives ()) with - | (_, words) when TextSet.is_empty words -> - { comp_state = (before, after); - comp_words = TextSet.empty } - | (prefix, words) -> - if bl = "" then - { comp_state = (before' ^ prefix, after); - comp_words = words } - else - { comp_state = (before, after); - comp_words = TextSet.empty }) - } - - (* Completion on directive argument *) - | (blank* '#' blank* (ident as dir) blank* as before') (ident as arg) eof { - return (match try Some(Hashtbl.find directive_table dir) with Not_found -> None with - | Some (Directive_bool _) -> - complete ~suffix:";;" before' arg after (set_of_list ["false"; "true"]) - | _ -> - { comp_state = (before, after); - comp_words = TextSet.empty }) - } - - (* Completion on packages *) - | (blank* '#' blank* "require" blank* '"' as before) ([^'"']* as package) eof { - return (complete ~suffix:"\";;" before package after (set_of_list (Fl_package_base.list_packages ()))) - } - - (* Completion on files *) - | (blank* '#' blank* "load" blank* '"' as before) ([^'"']* as fname) eof { - let list = list_files (fun name -> - Filename.check_suffix name ".cma" || Filename.check_suffix name ".cmo") fname in - return (complete ~suffix:"" before fname after list) - } - - | (blank* '#' blank* "use" blank* '"' as before) ([^'"']* as fname) eof { - let list = list_files (fun _ -> true) fname in - return (complete ~suffix:"" before fname after list) - } - - (* Completion on directories *) - | (blank* '#' blank* "directory" blank* '"' as before) ([^'"']* as fname) eof { - let list = list_directories fname in - return (complete ~suffix:"" before fname after list) - } - - (* Completion on packages *) - | blank* '#' blank* ident blank* '"' [^'"']* '"' blank* eof { - return { comp_state = (before ^ ";;", after); - comp_words = TextSet.empty } - } - - (* A line that do not need to be completed: *) - | blank* '#' blank* ident blank* '"' [^'"']* '"' blank* ";;" eof { - return { comp_state = (before, after); - comp_words = TextSet.empty } - } - - | "" { - complete_end (Buffer.create (String.length before)) after lexbuf - } - -and complete_end before after = parse - - (* Completion on keywords *) - | ((ident '.')* maybe_ident as id) eof { - let before = Buffer.contents before in - return (!complete_ident before id after) - } - - | uchar as ch { - Buffer.add_string before ch; - complete_end before after lexbuf - } - - | "" { - return { comp_state = (Buffer.contents before, after); - comp_words = TextSet.empty } - } diff --git a/server/thirdparty/lwt-2.3.2/src/top/lwt_top.ml b/server/thirdparty/lwt-2.3.2/src/top/lwt_top.ml deleted file mode 100644 index 851bb2c..0000000 --- a/server/thirdparty/lwt-2.3.2/src/top/lwt_top.ml +++ /dev/null @@ -1,141 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_top - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(* Integration with the toplevel: - - readline + let threads runs while reading user input. *) - -open Lwt_unix -open Lwt -open Lwt_text -open Lwt_term - -(* +-----------------------------------------------------------------+ - | Completion | - +-----------------------------------------------------------------+ *) - -module TextSet = Set.Make(Text) - -let complete (before, after) = - Lwt_ocaml_completion.complete_input before after (Lexing.from_string before) - -(* +-----------------------------------------------------------------+ - | Read-line wrapper | - +-----------------------------------------------------------------+ *) - -let mode = ref `real_time -let completion_mode () = !mode -let set_completion_mode m = mode := m - -let history = ref [] - -let _ = - let hist_name = Filename.concat (try Unix.getenv "HOME" with _ -> "") ".lwt-top-history" in - Lwt_main.at_exit (fun () -> Lwt_read_line.save_history hist_name !history); - history := Lwt_main.run (Lwt_read_line.load_history hist_name) - -let input = ref "" -let pos = ref 0 - -let rec read_input prompt buffer len = - try - if !pos = String.length !input then begin - let prompt' = if prompt = " " then [fg blue; text "> "] else [fg yellow; text prompt] in - !Lwt_ocaml_completion.restart (); - let txt = Lwt_main.run begin - lwt l = Lwt_read_line.Control.result - (Lwt_read_line.Control.make - ~complete - ~mode:!mode - ~history:(!history) - ~prompt:(fun _ -> React.S.const prompt') - ~filter:(fun state command -> - match command with - | Lwt_read_line.Command.Accept_line -> - (* Do not accept the line if it does not terminates with ";;" *) - let text = Lwt_read_line.Engine.all_input (Lwt_read_line.Control.engine_state state) in - if Text.ends_with (Text.rstrip text) ";;" then - return Lwt_read_line.Command.Accept_line - else - return (Lwt_read_line.Command.Char "\n") - | command -> - return command) - ~map_result:return - ()) - in - lwt () = Lwt_text.flush Lwt_text.stdout in - return l - end in - history := Lwt_read_line.add_entry txt !history; - input := txt ^ "\n"; - pos := 0; - read_input prompt buffer len - end else begin - let i = ref 0 in - while !i < len && !pos < String.length !input do - buffer.[!i] <- (!input).[!pos]; - incr i; - incr pos - done; - (!i, false) - end - with - | Lwt_read_line.Interrupt -> - (0, true) - -let read_input_non_interactive prompt buffer len = - let rec loop i = - if i = len then - return (i, false) - else - Lwt_io.read_char_opt Lwt_io.stdin >>= function - | Some c -> - buffer.[i] <- c; - if c = '\n' then - return (i + 1, false) - else - loop (i + 1) - | None -> - return (i, true) - in - Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >> loop 0) - -let _ = - (* If input is a tty, use interactive read-line and display and - welcome message: *) - if Unix.isatty Unix.stdin then begin - Toploop.read_interactive_input := read_input; - - let txt = "Welcome to the Lwt powered OCaml toplevel!" in - let col_border = cyan and col_txt = yellow in - let len = Text.length txt in - let col = React.S.value Lwt_term.columns in - let space = (col - 4 - len) / 2 in - let rep n txt = text (Text.repeat n txt) in - Lwt_main.run - (lwt () = printlc [fg col_border; rep space "─"; text "┬─"; rep len "─"; text "─┬"; rep (col - 4 - len - space) "─"] in - lwt () = printlc [rep space " "; fg col_border; text "│ "; fg col_txt; text txt; fg col_border; text " │"] in - lwt () = printlc [rep space " "; fg col_border; text "└─"; rep len "─"; text "─┘"] in - Lwt_io.flush Lwt_io.stdout) - end else - (* Otherwise fallback to classic non-interactive mode: *) - Toploop.read_interactive_input := read_input_non_interactive; diff --git a/server/thirdparty/lwt-2.3.2/src/top/lwt_top.mli b/server/thirdparty/lwt-2.3.2/src/top/lwt_top.mli deleted file mode 100644 index 8fad322..0000000 --- a/server/thirdparty/lwt-2.3.2/src/top/lwt_top.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_top - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Toplevel configuration *) - -val completion_mode : unit -> [ `classic | `real_time | `none ] - (** Return the current completion mode. *) - -val set_completion_mode : [ `classic | `real_time | `none ] -> unit - (** Change the completion mode *) diff --git a/server/thirdparty/lwt-2.3.2/src/top/toplevel.ml b/server/thirdparty/lwt-2.3.2/src/top/toplevel.ml deleted file mode 100644 index 47f0cc5..0000000 --- a/server/thirdparty/lwt-2.3.2/src/top/toplevel.ml +++ /dev/null @@ -1,131 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Toplevel - * Copyright (C) 2009 Jérémie Dimino - * Pierre Chambart - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Types -open Lwt_read_line - -module TextSet = Set.Make(Text) - -type path = - | Path of Path.t - | Longident of Longident.t - -module PathMap = Map.Make(struct type t = path let compare = compare end) - -let keywords = Lwt_ocaml_completion.keywords - -let global_env = ref(lazy(raise Exit)) -let local_envs = ref(PathMap.empty) - -(* Returns [acc] plus all modules of [dir] *) -let add_modules_from_directory acc dir = - let dir = if dir = "" then "./" else dir in - let acc = ref acc in - Array.iter (fun fname -> - if Filename.check_suffix fname ".cmi" then - acc := TextSet.add (Text.capitalize (Filename.chop_suffix fname ".cmi")) !acc) - (Sys.readdir (if dir = "" then Filename.current_dir_name else dir)); - !acc - -(* List all names of the module with path [path] *) -let get_names_of_module path = - try - match - match path with - | Path path -> - Env.find_module path !Toploop.toplevel_env - | Longident ident -> - snd (Env.lookup_module ident !Toploop.toplevel_env) - with - | Tmty_signature decls -> - List.fold_left - (fun acc decl -> match decl with - | Tsig_value(id, _) - | Tsig_type(id, _, _) - | Tsig_exception(id, _) - | Tsig_module(id, _, _) - | Tsig_modtype(id, _) - | Tsig_class(id, _, _) - | Tsig_cltype(id, _, _) -> - TextSet.add (Ident.name id) acc) - TextSet.empty decls - | _ -> - TextSet.empty - with Not_found -> - TextSet.empty - -let names_of_module path = - try - PathMap.find path !local_envs - with Not_found -> - let names = get_names_of_module path in - local_envs := PathMap.add path names !local_envs; - names - -(* List all names accessible without a path *) -let env_names () = - let rec loop acc = function - | Env.Env_empty -> acc - | Env.Env_value(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary - | Env.Env_type(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary - | Env.Env_exception(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary - | Env.Env_module(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary - | Env.Env_modtype(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary - | Env.Env_class(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary - | Env.Env_cltype(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary - | Env.Env_open(summary, path) -> loop (TextSet.union acc (names_of_module (Path path))) summary - in - (* Add names of the environment: *) - let acc = loop TextSet.empty (Env.summary !Toploop.toplevel_env) in - (* Add accessible modules: *) - List.fold_left add_modules_from_directory acc !Config.load_path - -let path_of_string text = - match Text.split ~sep:"." text with - | [] -> - invalid_arg "Toplevel.make_path" - | ident :: rest -> - let rec loop path = function - | [] -> Longident path - | component :: rest -> loop (Longident.Ldot(path, component)) rest - in - loop (Longident.Lident ident) rest - -let complete_ident before ident after = - match Text.rev_split ~sep:"." ~max:2 ident with - | [ident]-> - complete ~suffix:"" before ident after (TextSet.union keywords (Lazy.force !global_env)) - | [path; ident] -> - let before = before ^ path ^ "." in - complete ~suffix:"" before ident after (names_of_module (path_of_string path)) - | _ -> - assert false - -let restart () = - global_env := lazy(env_names ()); - local_envs := PathMap.empty - -let () = - Topfind.don't_load_deeply ["lwt"; "lwt.react"; "lwt.unix"; "lwt.text"; "lwt.top"]; - Lwt_ocaml_completion.complete_ident := complete_ident; - Lwt_ocaml_completion.restart := restart diff --git a/server/thirdparty/lwt-2.3.2/src/top/toplevel_temp.mltop b/server/thirdparty/lwt-2.3.2/src/top/toplevel_temp.mltop deleted file mode 100644 index 83c26cf..0000000 --- a/server/thirdparty/lwt-2.3.2/src/top/toplevel_temp.mltop +++ /dev/null @@ -1,3 +0,0 @@ -# This file is used to generate "toplevel_temp.top", which is then -# expunged into "lwt-toplevel" -Toplevel diff --git a/server/thirdparty/lwt-2.3.2/src/unix/liblwt-unix.clib b/server/thirdparty/lwt-2.3.2/src/unix/liblwt-unix.clib deleted file mode 100644 index 0143cb3..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/liblwt-unix.clib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 0d2c17c0648a3a3dd282ce99960c7277) -lwt_unix_stubs.o -lwt_libev_stubs.o -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt-unix.mllib b/server/thirdparty/lwt-2.3.2/src/unix/lwt-unix.mllib deleted file mode 100644 index 66adca7..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt-unix.mllib +++ /dev/null @@ -1,17 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 2e742a984520810653596dcf9f7563fa) -Lwt_chan -Lwt_daemon -Lwt_gc -Lwt_io -Lwt_log -Lwt_main -Lwt_process -Lwt_throttle -Lwt_timeout -Lwt_unix -Lwt_sys -Lwt_engine -Lwt_bytes -Lwt_log_rules -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.ml deleted file mode 100644 index fc9547b..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.ml +++ /dev/null @@ -1,344 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_unix - * Copyright (C) 2010 Jérémie Dimino - * 2010 Pierre Chambart - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -#include "src/unix/lwt_config.ml" - -open Bigarray -open Lwt - -type t = (char, int8_unsigned_elt, c_layout) Array1.t - -let create size = Array1.create char c_layout size -let length bytes = Array1.dim bytes - -external get : t -> int -> char = "%caml_ba_ref_1" -external set : t -> int -> char -> unit = "%caml_ba_set_1" - -external unsafe_get : t -> int -> char = "%caml_ba_unsafe_ref_1" -external unsafe_set : t -> int -> char -> unit = "%caml_ba_unsafe_set_1" - -external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc" - -let fill bytes ofs len ch = - if ofs < 0 || len < 0 || ofs > length bytes - len then - invalid_arg "Lwt_bytes.fill" - else - unsafe_fill bytes ofs len ch - -(* +-----------------------------------------------------------------+ - | Blitting | - +-----------------------------------------------------------------+ *) - -external unsafe_blit_string_bytes : string -> int -> t -> int -> int -> unit = "lwt_unix_blit_string_bytes" "noalloc" -external unsafe_blit_bytes_string : t -> int -> string -> int -> int -> unit = "lwt_unix_blit_bytes_string" "noalloc" -external unsafe_blit : t -> int -> t -> int -> int -> unit = "lwt_unix_blit_bytes_bytes" "noalloc" - -let blit_string_bytes src_buf src_ofs dst_buf dst_ofs len = - if (len < 0 - || src_ofs < 0 || src_ofs > String.length src_buf - len - || dst_ofs < 0 || dst_ofs > length dst_buf - len) then - invalid_arg "String.blit" - else - unsafe_blit_string_bytes src_buf src_ofs dst_buf dst_ofs len - -let blit_bytes_string src_buf src_ofs dst_buf dst_ofs len = - if (len < 0 - || src_ofs < 0 || src_ofs > length src_buf - len - || dst_ofs < 0 || dst_ofs > String.length dst_buf - len) then - invalid_arg "String.blit" - else - unsafe_blit_bytes_string src_buf src_ofs dst_buf dst_ofs len - -let blit src_buf src_ofs dst_buf dst_ofs len = - if (len < 0 - || src_ofs < 0 || src_ofs > length src_buf - len - || dst_ofs < 0 || dst_ofs > length dst_buf - len) then - invalid_arg "String.blit" - else - unsafe_blit src_buf src_ofs dst_buf dst_ofs len - -let of_string str = - let len = String.length str in - let bytes = create len in - unsafe_blit_string_bytes str 0 bytes 0 len; - bytes - -let to_string bytes = - let len = length bytes in - let str = String.create len in - unsafe_blit_bytes_string bytes 0 str 0 len; - str - -let proxy = Array1.sub - -let extract buf ofs len = - if ofs < 0 || len < 0 || ofs > length buf - len then - invalid_arg "Lwt_bytes.extract" - else begin - let buf' = create len in - blit buf ofs buf' 0 len; - buf' - end - -let copy buf = - let len = length buf in - let buf' = create len in - blit buf 0 buf' 0 len; - buf' - -(* +-----------------------------------------------------------------+ - | IOs | - +-----------------------------------------------------------------+ *) - -open Lwt_unix - -external stub_read : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_read" -external read_job : Unix.file_descr -> t -> int -> int -> [ `unix_bytes_read ] job = "lwt_unix_bytes_read_job" -external read_result : [ `unix_bytes_read ] job -> int = "lwt_unix_bytes_read_result" -external read_free : [ `unix_bytes_read ] job -> unit = "lwt_unix_bytes_read_free" "noalloc" - -let read fd buf pos len = - if pos < 0 || len < 0 || pos > length buf - len then - invalid_arg "Lwt_bytes.read" - else - blocking fd >>= function - | true -> - lwt () = wait_read fd in - execute_job (read_job (unix_file_descr fd) buf pos len) read_result read_free - | false -> - wrap_syscall Read fd (fun () -> stub_read (unix_file_descr fd) buf pos len) - -external stub_write : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_write" -external write_job : Unix.file_descr -> t -> int -> int -> [ `unix_bytes_write ] job = "lwt_unix_bytes_write_job" -external write_result : [ `unix_bytes_write ] job -> int = "lwt_unix_bytes_write_result" -external write_free : [ `unix_bytes_write ] job -> unit = "lwt_unix_bytes_write_free" "noalloc" - -let write fd buf pos len = - if pos < 0 || len < 0 || pos > length buf - len then - invalid_arg "Lwt_bytes.write" - else - blocking fd >>= function - | true -> - lwt () = wait_write fd in - execute_job (write_job (unix_file_descr fd) buf pos len) write_result write_free - | false -> - wrap_syscall Write fd (fun () -> stub_write (unix_file_descr fd) buf pos len) - -#if windows - -let recv fd buf pos len flags = - raise (Lwt_sys.Not_available "Lwt_bytes.recv") - -#else - -external stub_recv : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_recv" - -let recv fd buf pos len flags = - if pos < 0 || len < 0 || pos > length buf - len then - invalid_arg "recv" - else - wrap_syscall Read fd (fun () -> stub_recv (unix_file_descr fd) buf pos len flags) - -#endif - -#if windows - -let send fd buf pos len flags = - raise (Lwt_sys.Not_available "Lwt_bytes.send") - -#else - -external stub_send : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_send" - -let send fd buf pos len flags = - if pos < 0 || len < 0 || pos > length buf - len then - invalid_arg "send" - else - wrap_syscall Write fd (fun () -> stub_send (unix_file_descr fd) buf pos len flags) - -#endif - -type io_vector = { - iov_buffer : t; - iov_offset : int; - iov_length : int; -} - -let io_vector ~buffer ~offset ~length = { - iov_buffer = buffer; - iov_offset = offset; - iov_length = length; -} - -let check_io_vectors func_name iovs = - List.iter - (fun iov -> - if iov.iov_offset < 0 - || iov.iov_length < 0 - || iov.iov_offset > length iov.iov_buffer - iov.iov_length then - invalid_arg func_name) - iovs - -#if windows - -let recv_msg ~socket ~io_vectors = - raise (Lwt_sys.Not_available "recv_msg") - -#else - -external stub_recv_msg : Unix.file_descr -> int -> io_vector list -> int * Unix.file_descr list = "lwt_unix_bytes_recv_msg" - -let recv_msg ~socket ~io_vectors = - check_io_vectors "recv_msg" io_vectors; - let n_iovs = List.length io_vectors in - wrap_syscall Read socket - (fun () -> - stub_recv_msg (unix_file_descr socket) n_iovs io_vectors) - -#endif - -#if windows - -let send_msg ~socket ~io_vectors ~fds = - raise (Lwt_sys.Not_available "send_msg") - -#else - -external stub_send_msg : Unix.file_descr -> int -> io_vector list -> int -> Unix.file_descr list -> int = "lwt_unix_bytes_send_msg" - -let send_msg ~socket ~io_vectors ~fds = - check_io_vectors "send_msg" io_vectors; - let n_iovs = List.length io_vectors and n_fds = List.length fds in - wrap_syscall Write socket - (fun () -> - stub_send_msg (unix_file_descr socket) n_iovs io_vectors n_fds fds) - -#endif - -#if windows - -let recvfrom fd buf pos len flags = - raise (Lwt_sys.Not_available "Lwt_bytes.recvfrom") - -#else - -external stub_recvfrom : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr = "lwt_unix_bytes_recvfrom" - -let recvfrom fd buf pos len flags = - if pos < 0 || len < 0 || pos > length buf - len then - invalid_arg "Lwt_bytes.recvfrom" - else - wrap_syscall Read fd (fun () -> stub_recvfrom (unix_file_descr fd) buf pos len flags) - -#endif - -#if windows - -let sendto fd buf pos len flags addr = - raise (Lwt_sys.Not_available "Lwt_bytes.sendto") - -#else - -external stub_sendto : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int = "lwt_unix_bytes_sendto_byte" "lwt_unix_bytes_sendto" - -let sendto fd buf pos len flags addr = - if pos < 0 || len < 0 || pos > length buf - len then - invalid_arg "Lwt_bytes.sendto" - else - wrap_syscall Write fd (fun () -> stub_sendto (unix_file_descr fd) buf pos len flags addr) - -#endif - -(* +-----------------------------------------------------------------+ - | Memory mapped files | - +-----------------------------------------------------------------+ *) - -let map_file ~fd ?pos ~shared ?(size=(-1)) () = - Array1.map_file fd ?pos char c_layout shared size - -external mapped : t -> bool = "lwt_unix_mapped" "noalloc" - -type advice = - | MADV_NORMAL - | MADV_RANDOM - | MADV_SEQUENTIAL - | MADV_WILLNEED - | MADV_DONTNEED - -#if windows - -let madvise buf pos len advice = - raise (Lwt_sys.Not_available "madvise") - -#else - -external stub_madvise : t -> int -> int -> advice -> unit = "lwt_unix_madvise" - -let madvise buf pos len advice = - if pos < 0 || len < 0 || pos > length buf - len then - invalid_arg "Lwt_bytes.madvise" - else - stub_madvise buf pos len advice - -#endif - -external get_page_size : unit -> int = "lwt_unix_get_page_size" - -let page_size = get_page_size () - -#if windows - -let mincore buffer offset states = - raise (Lwt_sys.Not_available "mincore") - -let wait_mincore buffer offset = - raise (Lwt_sys.Not_available "mincore") - -#else - -external stub_mincore : t -> int -> int -> bool array -> unit = "lwt_unix_mincore" - -let mincore buffer offset states = - if (offset mod page_size <> 0 - || offset < 0 - || offset > length buffer - (Array.length states * page_size)) then - invalid_arg "Lwt_bytes.mincore" - else - stub_mincore buffer offset (Array.length states * page_size) states - -external wait_mincore_job : t -> int -> [ `unix_wait_mincore ] job = "lwt_unix_wait_mincore_job" -external wait_mincore_free : [ `unix_wait_mincore ] job -> unit = "lwt_unix_wait_mincore_free" "noalloc" - -let wait_mincore buffer offset = - if offset < 0 || offset >= length buffer then - invalid_arg "Lwt_bytes.wait_mincore" - else begin - let state = [|false|] in - mincore buffer (offset - (offset mod page_size)) state; - if state.(0) then - return () - else - execute_job (wait_mincore_job buffer offset) ignore wait_mincore_free - end - -#endif diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.mli deleted file mode 100644 index d76674b..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.mli +++ /dev/null @@ -1,176 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_unix - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Byte arrays *) - -type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t - (** Type of array of bytes. *) - -val create : int -> t - (** Creates a new byte array of the given size. *) - -val length : t -> int - (** Returns the length of the given byte array. *) - -(** {6 Access} *) - -external get : t -> int -> char = "%caml_ba_ref_1" - (** [get buffer offset] returns the byte at offset [offset] in - [buffer]. *) - -external set : t -> int -> char -> unit = "%caml_ba_set_1" - (** [get buffer offset value] changes the value of the byte at - offset [offset] in [buffer] to [value]. *) - -external unsafe_get : t -> int -> char = "%caml_ba_unsafe_ref_1" - (** Same as {!get} but without bound checking. *) - -external unsafe_set : t -> int -> char -> unit = "%caml_ba_unsafe_set_1" - (** Same as {!set} but without bound checking. *) - -(** {6 Conversions} *) - -val of_string : string -> t - (** [of_string str] returns a newly allocated byte array with the - same contents as [str]. *) - -val to_string : t -> string - (** [to_string buf] returns a newly allocated string with the same - contents as [buf]. *) - -(** {6 Copying} *) - -val blit : t -> int -> t -> int -> int -> unit - (** [blit buf1 ofs1 buf2 ofs2 len] copy [len] bytes from [buf1] - starting at offset [ofs1] to [buf2] starting at offset [ofs2]. *) - -val blit_string_bytes : string -> int -> t -> int -> int -> unit - (** Same as blit but the first buffer is a string instead of a byte - array. *) - -val blit_bytes_string : t -> int -> string -> int -> int -> unit - (** Same as blit but the second buffer is a string instead of a byte - array. *) - -external unsafe_blit : t -> int -> t -> int -> int -> unit = "lwt_unix_blit_bytes_bytes" "noalloc" - (** Same as {!blit} but without bound checking. *) - -external unsafe_blit_string_bytes : string -> int -> t -> int -> int -> unit = "lwt_unix_blit_string_bytes" "noalloc" - (** Same as {!blit_string_bytes} but without bound checking. *) - -external unsafe_blit_bytes_string : t -> int -> string -> int -> int -> unit = "lwt_unix_blit_bytes_string" "noalloc" - (** Same as {!blit_bytes_string} but without bound checking. *) - -val proxy : t -> int -> int -> t - (** [proxy buffer offset length] creates a ``proxy''. The returned - byte array share the data of [buffer] but with different - bounds. *) - -val extract : t -> int -> int -> t - (** [extract buffer offset length] creates a new byte array of - length [length] and copy the [length] bytes of [buffer] at - [offset] into it. *) - -val copy : t -> t - (** [copy buffer] creates a copy of the given byte array. *) - -(** {6 Filling} *) - -val fill : t -> int -> int -> char -> unit - (** [fill buffer offset length value] puts [value] in all [length] - bytes of [buffer] starting at offset [offset]. *) - -external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc" - (** Same as {!fill} but without bound checking. *) - -(** {6 IOs} *) - -(** The following functions does the same as the functions in - {!Lwt_unix} except that they use byte arrays instead of - strings. *) - -val read : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t -val write : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t - -val recv : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t -val send : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t - -val recvfrom : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> (int * Unix.sockaddr) Lwt.t -val sendto : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int Lwt.t - -type io_vector = { - iov_buffer : t; - iov_offset : int; - iov_length : int; -} - -val io_vector : buffer : t -> offset : int -> length : int -> io_vector - -val recv_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> (int * Unix.file_descr list) Lwt.t - (** This call is not available on windows. *) - -val send_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> fds : Unix.file_descr list -> int Lwt.t - (** This call is not available on windows. *) - -(** {6 Memory mapped files} *) - -val map_file : fd : Unix.file_descr -> ?pos : int64 -> shared : bool -> ?size : int -> unit -> t - (** [map_file ~fd ?pos ~shared ?size ()] maps the file descriptor - [fd] to an array of bytes. *) - -external mapped : t -> bool = "lwt_unix_mapped" "noalloc" - (** [mapped buffer] returns [true] iff [buffer] is a memory mapped - file. *) - -(** Type of advise that can be sent to the kernel by the program. See - the manual madvise(2) for a description of each advices. *) -type advice = - | MADV_NORMAL - | MADV_RANDOM - | MADV_SEQUENTIAL - | MADV_WILLNEED - | MADV_DONTNEED - -val madvise : t -> int -> int -> advice -> unit - (** [madvise buffer pos len advice] advise the kernel about how the - program is going to use the part of the memory mapped file - between [pos] and [pos + len]. - - This call is not available on windows. *) - -val page_size : int - (** Size of pages. *) - -val mincore : t -> int -> bool array -> unit - (** [mincore buffer offset states] tests whether the given pages are - in the system memory (the RAM). The [offset] argument must be a - multiple of {!page_size}. [states] is used to store the result; - each cases is [true] if the corresponding page in the RAM and - [false] otherwise. - - This call is not available on windows. *) - -val wait_mincore : t -> int -> unit Lwt.t - (** [wait_mincore buffer offset] waits until the page containing the - byte at offset [offset] in the the RAM. - - This functions is not available on windows. *) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_chan.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_chan.ml deleted file mode 100644 index 3fbf613..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_chan.ml +++ /dev/null @@ -1,86 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_chan - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * 2009 Jrmie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt -open Lwt_io - -type in_channel = Lwt_io.input_channel -type out_channel = Lwt_io.output_channel - -let in_channel_of_descr fd = of_fd ~mode:Lwt_io.input fd - -let make_in_channel ?close read = - make ~mode:Lwt_io.input ?close - (fun buf ofs len -> - let str = String.create len in - lwt n = read str 0 len in - if (n > 0) then Lwt_bytes.blit_string_bytes str 0 buf ofs len; - return n) - -let input_line ic = - let rec loop buf = - read_char_opt ic >>= function - | None | Some '\n' -> - return (Buffer.contents buf) - | Some char -> - Buffer.add_char buf char; - loop buf - in - read_char_opt ic >>= function - | Some '\n' -> - return "" - | Some char -> - let buf = Buffer.create 128 in - Buffer.add_char buf char; - loop buf - | None -> - raise_lwt End_of_file - -let input_value = read_value -let input = read_into -let really_input = read_into_exactly -let input_char = read_char -let input_binary_int = BE.read_int -let open_in_gen flags perm fname = open_file ~flags ~perm ~mode:Lwt_io.input fname -let open_in fname = open_file ~mode:Lwt_io.input fname -let close_in = close -let out_channel_of_descr fd = of_fd ~mode:Lwt_io.output fd - -let make_out_channel ?close write = - make ~mode:Lwt_io.output ?close - (fun buf ofs len -> - let str = String.create len in - Lwt_bytes.blit_bytes_string buf ofs str 0 len; - write str 0 len) - -let output = write_from_exactly -let flush = flush -let output_string = write -let output_value oc v = write_value oc v -let output_char = write_char -let output_binary_int = BE.write_int -let open_out_gen flags perm fname = open_file ~flags ~perm ~mode:Lwt_io.output fname -let open_out fname = open_file ~mode:Lwt_io.output fname -let close_out = close -let open_connection sockaddr = open_connection sockaddr diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_chan.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_chan.mli deleted file mode 100644 index 175d31e..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_chan.mli +++ /dev/null @@ -1,75 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_chan - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Module [Lwt_chan]: cooperative, [Pervasives]-like, I/O functions *) - -(** Note: the {!Lwt_io} module deprecates this module. *) - -(** {2 Cooperative input channels} *) -type in_channel = Lwt_io.input_channel - -val in_channel_of_descr : Lwt_unix.file_descr -> in_channel - -val make_in_channel : ?close:(unit -> unit Lwt.t) -> (string -> int -> int -> int Lwt.t) -> in_channel -(** [make_in_channel read] creates an input channel from the [read] - function. [read s ofs len] should (cooperatively) read [len] bytes from - the source, and put them in [s], at offset [ofs], and return the number - of bytes effectively read. If provided, [close] will be called by - [close_in]. By default, [close_in] does not do anything. *) - -val input_line : in_channel -> string Lwt.t -val input_value : in_channel -> 'a Lwt.t -val input : in_channel -> string -> int -> int -> int Lwt.t -val really_input : in_channel -> string -> int -> int -> unit Lwt.t -val input_char : in_channel -> char Lwt.t -val input_binary_int : in_channel -> int Lwt.t - -val open_in_gen : Unix.open_flag list -> int -> string -> in_channel Lwt.t -val open_in : string -> in_channel Lwt.t -val close_in : in_channel -> unit Lwt.t - -(** {2 Cooperative output channels} *) - -type out_channel = Lwt_io.output_channel - -val out_channel_of_descr : Lwt_unix.file_descr -> out_channel - -val make_out_channel : ?close:(unit -> unit Lwt.t) -> (string -> int -> int -> int Lwt.t) -> out_channel -(** [make_out_channel write] creates an output channel from the [write] - function. [write s ofs len] should (cooperatively) write [len] bytes from - [s], starting at offset [ofs], to the backend, and return the number of - bytes effectively written. If provided, [close] will be called by - [close_out]. By default, [close_out] does not do anything. *) - -val output : out_channel -> string -> int -> int -> unit Lwt.t -val flush : out_channel -> unit Lwt.t -val output_string : out_channel -> string -> unit Lwt.t -val output_value : out_channel -> 'a -> unit Lwt.t -val output_char : out_channel -> char -> unit Lwt.t -val output_binary_int : out_channel -> int -> unit Lwt.t - -val open_out_gen : Unix.open_flag list -> int -> string -> out_channel Lwt.t -val open_out : string -> out_channel Lwt.t -val close_out : out_channel -> unit Lwt.t - -val open_connection : Unix.sockaddr -> (in_channel * out_channel) Lwt.t diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.ml deleted file mode 100644 index a5a7333..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.ml +++ /dev/null @@ -1,89 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_io - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt - -let rec copy ic logger = - lwt line = Lwt_io.read_line ic in - lwt () = Lwt_log.log ?logger ~level:Lwt_log.Notice line in - copy ic logger - -let redirect fd logger = - let fd_r, fd_w = Unix.pipe () in - Unix.set_close_on_exec fd_r; - Unix.dup2 fd_w fd; - Unix.close fd_w; - let ic = Lwt_io.of_unix_fd ~mode:Lwt_io.input fd in - ignore (copy ic logger) - -let redirect_output dev_null fd mode = match mode with - | `Dev_null -> - Unix.dup2 dev_null fd - | `Close -> - Unix.close fd - | `Keep -> - () - | `Log_default -> - redirect fd None - | `Log logger -> - redirect fd (Some logger) - -let daemonize ?(syslog=true) ?(stdin=`Dev_null) ?(stdout=`Log_default) ?(stderr=`Log_default) ?(directory="/") ?(umask=`Set 0o022) () = - if Unix.getppid () = 1 then - (* If our parent is [init], then we already are a demon *) - () - else begin - Unix.chdir directory; - - (* Exit the parent, and continue in the child: *) - if Lwt_unix.fork () > 0 then begin - (* Do not run exit hooks in the parent. *) - Lwt_sequence.iter_node_l Lwt_sequence.remove Lwt_main.exit_hooks; - exit 0 - end; - - if syslog then Lwt_log.default := Lwt_log.syslog ~facility:`Daemon (); - - (* Redirection of standard IOs *) - let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR] 0o666 in - begin match stdin with - | `Dev_null -> - Unix.dup2 dev_null Unix.stdin - | `Close -> - Unix.close Unix.stdin - | `Keep -> - () - end; - redirect_output dev_null Unix.stdout stdout; - redirect_output dev_null Unix.stderr stderr; - Unix.close dev_null; - - begin match umask with - | `Keep -> - () - | `Set n -> - ignore (Unix.umask 0o022); - end; - - ignore (Unix.setsid ()) - end - diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.mli deleted file mode 100644 index 7e7f23b..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.mli +++ /dev/null @@ -1,81 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_io - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Daemon helpers *) - -val daemonize : - ?syslog : bool -> - ?stdin : [ `Dev_null | `Close | `Keep ] -> - ?stdout : [ `Dev_null | `Close | `Keep | `Log_default | `Log of Lwt_log.logger ] -> - ?stderr : [ `Dev_null | `Close | `Keep | `Log_default | `Log of Lwt_log.logger ] -> - ?directory : string -> - ?umask : [ `Keep | `Set of int ] -> - unit -> unit - (** Put the current running process into daemon mode. I.e. it forks - and exit the parent, detach it from its controlling terminal, - and redict standard intputs/outputs.. - - Notes: - - if the process is already a daemon, it does nothing. - - you must be sure that there is no pending threads when - calling this function, otherwise they may be canceled. - - If [syslog] is [true] (the default), then {!Lwt_log.default} is - set to [Lwt_log.syslog ~facility:`Daemon ()], otherwise it is - kept unchanged. - - [stdin] is one of: - - [`Dev_null] which means that [Unix.stdin] is reopened as - [/dev/null], this is the default behavior - - [`Close] means that [Unix.stdin] is simply closed - - [`Keep] means that [Unix.stdin] is left unchanged - - [stdout] and [stderr] control how the two associated file - descriptors are redirected: - - [`Dev_null] means that the output is redirected to [/dev/null] - - [`Close] means that the file descriptor is closed - - [`Keep] means that it is left unchanged - - [`Log logger] means that the output is redirected to this - logger - - [`Log_default] means that the output is redirected to the - default logger - - Both [stdout] and [stderr] defaults to [`Log_default]. - - Warning: do not redirect an output to a logger logging into this - outpout, for example this code will create an infinite loop: - - {[ - let logger = Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr () in - Lwt_daemon.daemonize ~syslog:false ~stderr:(`Log logger) (); - prerr_endline "foo" - ]} - - The current working directory is set to [directory], which - defaults to ["/"]. - - [umask] may be one of: - - [`Keep] which means that the umask is left unchanged - - [`Set n] which means that the umash is set to [n] - - It defaults to [`Set 0o022]. - *) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_engine.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_engine.ml deleted file mode 100644 index 0594376..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_engine.ml +++ /dev/null @@ -1,421 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_engine - * Copyright (C) 2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -#include "src/unix/lwt_config.ml" - -(* +-----------------------------------------------------------------+ - | Events | - +-----------------------------------------------------------------+ *) - -type _event = { - stop : unit Lazy.t; - (* The stop method of the event. *) - node : Obj.t Lwt_sequence.node; - (* The node in the sequence of registered events. *) -} - -type event = _event ref - -external cast_node : 'a Lwt_sequence.node -> Obj.t Lwt_sequence.node = "%identity" - -let stop_event ev = - let ev = !ev in - Lwt_sequence.remove ev.node; - Lazy.force ev.stop - -let _fake_event = { - stop = lazy (); - node = Lwt_sequence.add_l (Obj.repr ()) (Lwt_sequence.create ()); -} - -let fake_event = ref _fake_event - -(* +-----------------------------------------------------------------+ - | Engines | - +-----------------------------------------------------------------+ *) - -class virtual abstract = object(self) - method virtual iter : bool -> unit - method virtual private cleanup : unit - method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t - - val readables = Lwt_sequence.create () - (* Sequence of callbacks waiting for a file descriptor to become - readable. *) - - val writables = Lwt_sequence.create () - (* Sequence of callbacks waiting for a file descriptor to become - writable. *) - - val timers = Lwt_sequence.create () - (* Sequence of timers. *) - - method destroy = - Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev) readables; - Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev) writables; - Lwt_sequence.iter_l (fun (delay, repeat, f, g, ev) -> stop_event ev) timers; - self#cleanup - - method transfer (engine : abstract) = - Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev; ev := !(engine#on_readable fd f)) readables; - Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev; ev := !(engine#on_writable fd f)) writables; - Lwt_sequence.iter_l (fun (delay, repeat, f, g, ev) -> stop_event ev; ev := !(engine#on_timer delay repeat f)) timers - - method fake_io fd = - Lwt_sequence.iter_l (fun (fd', f, g, stop) -> if fd = fd' then g ()) readables; - Lwt_sequence.iter_l (fun (fd', f, g, stop) -> if fd = fd' then g ()) writables - - method on_readable fd f = - let ev = ref _fake_event in - let g () = f ev in - let stop = self#register_readable fd g in - ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) readables) }; - ev - - method on_writable fd f = - let ev = ref _fake_event in - let g () = f ev in - let stop = self#register_writable fd g in - ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) writables) } ; - ev - - method on_timer delay repeat f = - let ev = ref _fake_event in - let g () = f ev in - let stop = self#register_timer delay repeat g in - ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (delay, repeat, f, g, ev) timers) }; - ev - - method readable_count = Lwt_sequence.length readables - method writable_count = Lwt_sequence.length writables - method timer_count = Lwt_sequence.length timers -end - -class type t = object - inherit abstract - - method iter : bool -> unit - method private cleanup : unit - method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t -end - -(* +-----------------------------------------------------------------+ - | The libev engine | - +-----------------------------------------------------------------+ *) - -#if HAVE_LIBEV - -type ev_loop -type ev_io -type ev_timer - -external ev_init : unit -> ev_loop = "lwt_libev_init" -external ev_stop : ev_loop -> unit = "lwt_libev_stop" -external ev_loop : ev_loop -> bool -> unit = "lwt_libev_loop" -external ev_unloop : ev_loop -> unit = "lwt_libev_unloop" -external ev_readable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_readable_init" -external ev_writable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_writable_init" -external ev_io_stop : ev_loop -> ev_io -> unit = "lwt_libev_io_stop" -external ev_timer_init : ev_loop -> float -> bool -> (unit -> unit) -> ev_timer = "lwt_libev_timer_init" -external ev_timer_stop : ev_loop -> ev_timer -> unit = "lwt_libev_timer_stop" - -class libev = object - inherit abstract - - val loop = ev_init () - method loop = loop - - method private cleanup = ev_stop loop - - method iter block = - try - ev_loop loop block - with exn -> - ev_unloop loop; - raise exn - - method private register_readable fd f = - let ev = ev_readable_init loop fd f in - lazy(ev_io_stop loop ev) - - method private register_writable fd f = - let ev = ev_writable_init loop fd f in - lazy(ev_io_stop loop ev) - - method private register_timer delay repeat f = - let ev = ev_timer_init loop delay repeat f in - lazy(ev_timer_stop loop ev) -end - -#else - -type ev_loop - -class libev = object(self) - inherit abstract - - val loop : ev_loop = raise (Lwt_sys.Not_available "libev") - method loop : ev_loop = assert false - method iter = assert false - method private cleanup = assert false - method private register_readable = assert false - method private register_writable = assert false - method private register_timer = assert false -end - -#endif - -(* +-----------------------------------------------------------------+ - | Select/poll based engines | - +-----------------------------------------------------------------+ *) - -(* Type of a sleeper for the select engine. *) -type sleeper = { - mutable time : float; - (* The time at which the sleeper should be wakeup. *) - - mutable stopped : bool; - (* [true] iff the event has been stopped. *) - - action : unit -> unit; - (* The action for the sleeper. *) -} - -module Sleep_queue = - Lwt_pqueue.Make(struct - type t = sleeper - let compare { time = t1 } { time = t2 } = compare t1 t2 - end) - -module Fd_map = Map.Make(struct type t = Unix.file_descr let compare = compare end) - -let rec restart_actions sleep_queue now = - match Sleep_queue.lookup_min sleep_queue with - | Some{ stopped = true } -> - restart_actions (Sleep_queue.remove_min sleep_queue) now - | Some{ time = time; action = action } when time <= now -> - action (); - restart_actions (Sleep_queue.remove_min sleep_queue) now - | _ -> - sleep_queue - -let rec get_next_timeout sleep_queue = - match Sleep_queue.lookup_min sleep_queue with - | Some{ stopped = true } -> - get_next_timeout (Sleep_queue.remove_min sleep_queue) - | Some{ time = time } -> - max 0. (time -. Unix.gettimeofday ()) - | None -> - -1. - -let bad_fd fd = - try - let _ = Unix.fstat fd in - false - with Unix.Unix_error (_, _, _) -> - true - -let invoke_actions fd map = - match try Some(Fd_map.find fd map) with Not_found -> None with - | Some actions -> Lwt_sequence.iter_l (fun f -> f ()) actions - | None -> () - -class virtual select_or_poll_based = object(self) - inherit abstract - - val mutable sleep_queue = Sleep_queue.empty - (* Threads waiting for a timeout to expire. *) - - val mutable new_sleeps = [] - (* Sleepers added since the last iteration of the main loop: - - They are not added immediatly to the main sleep queue in order - to prevent them from being wakeup immediatly. *) - - val mutable wait_readable = Fd_map.empty - (* Sequences of actions waiting for file descriptors to become - readable. *) - - val mutable wait_writable = Fd_map.empty - (* Sequences of actions waiting for file descriptors to become - writable. *) - - method private cleanup = () - - method private register_timer delay repeat f = - if repeat then begin - let rec sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = g } - and g () = - sleeper.time <- Unix.gettimeofday () +. delay; - new_sleeps <- sleeper :: new_sleeps; - f () - in - new_sleeps <- sleeper :: new_sleeps; - lazy(sleeper.stopped <- true) - end else begin - let sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = f } in - new_sleeps <- sleeper :: new_sleeps; - lazy(sleeper.stopped <- true) - end - - method private register_readable fd f = - let actions = - try - Fd_map.find fd wait_readable - with Not_found -> - let actions = Lwt_sequence.create () in - wait_readable <- Fd_map.add fd actions wait_readable; - actions - in - let node = Lwt_sequence.add_l f actions in - lazy(Lwt_sequence.remove node; - if Lwt_sequence.is_empty actions then wait_readable <- Fd_map.remove fd wait_readable) - - method private register_writable fd f = - let actions = - try - Fd_map.find fd wait_writable - with Not_found -> - let actions = Lwt_sequence.create () in - wait_writable <- Fd_map.add fd actions wait_writable; - actions - in - let node = Lwt_sequence.add_l f actions in - lazy(Lwt_sequence.remove node; - if Lwt_sequence.is_empty actions then wait_writable <- Fd_map.remove fd wait_writable) -end - -class virtual select_based = object(self) - inherit select_or_poll_based - - method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list - - method iter block = - (* Transfer all sleepers added since the last iteration to the - main sleep queue: *) - sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps; - new_sleeps <- []; - (* Collect file descriptors. *) - let fds_r = Fd_map.fold (fun fd _ l -> fd :: l) wait_readable [] in - let fds_w = Fd_map.fold (fun fd _ l -> fd :: l) wait_writable [] in - (* Compute the timeout. *) - let timeout = if block then get_next_timeout sleep_queue else 0. in - (* Do the blocking call *) - let fds_r, fds_w = - try - self#select fds_r fds_w timeout - with - | Unix.Unix_error (Unix.EINTR, _, _) -> - ([], []) - | Unix.Unix_error (Unix.EBADF, _, _) -> - (* Keeps only bad file descriptors. Actions registered on - them have to handle the error: *) - (List.filter bad_fd fds_r, - List.filter bad_fd fds_w) - in - (* Restart threads waiting for a timeout: *) - sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); - (* Restart threads waiting on a file descriptors: *) - List.iter (fun fd -> invoke_actions fd wait_readable) fds_r; - List.iter (fun fd -> invoke_actions fd wait_writable) fds_w -end - -class virtual poll_based = object(self) - inherit select_or_poll_based - - method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list - - method iter block = - (* Transfer all sleepers added since the last iteration to the - main sleep queue: *) - sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps; - new_sleeps <- []; - (* Collect file descriptors. *) - let fds = [] in - let fds = Fd_map.fold (fun fd _ l -> (fd, true, false) :: l) wait_readable fds in - let fds = Fd_map.fold (fun fd _ l -> (fd, false, true) :: l) wait_writable fds in - (* Compute the timeout. *) - let timeout = if block then get_next_timeout sleep_queue else 0. in - (* Do the blocking call *) - let fds = - try - self#poll fds timeout - with - | Unix.Unix_error (Unix.EINTR, _, _) -> - [] - | Unix.Unix_error (Unix.EBADF, _, _) -> - (* Keeps only bad file descriptors. Actions registered on - them have to handle the error: *) - List.filter (fun (fd, _, _) -> bad_fd fd) fds - in - (* Restart threads waiting for a timeout: *) - sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); - (* Restart threads waiting on a file descriptors: *) - List.iter - (fun (fd, readable, writable) -> - if readable then invoke_actions fd wait_readable; - if writable then invoke_actions fd wait_writable) - fds -end - -class select = object - inherit select_based - - method private select fds_r fds_w timeout = - let fds_r, fds_w, _ = Unix.select fds_r fds_w [] timeout in - (fds_r, fds_w) -end - -(* +-----------------------------------------------------------------+ - | The current engine | - +-----------------------------------------------------------------+ *) - -#if HAVE_LIBEV && not windows - -let current = ref (new libev :> t) - -#else - -let current = ref (new select :> t) - -#endif - -let get () = - !current - -let set ?(transfer=true) ?(destroy=true) engine = - if transfer then !current#transfer (engine : #t :> abstract); - if destroy then !current#destroy; - current := (engine : #t :> t) - -let iter block = !current#iter block -let on_readable fd f = !current#on_readable fd f -let on_writable fd f = !current#on_writable fd f -let on_timer delay repeat f = !current#on_timer delay repeat f -let fake_io fd = !current#fake_io fd -let readable_count () = !current#readable_count -let writable_count () = !current#writable_count -let timer_count () = !current#timer_count diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_engine.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_engine.mli deleted file mode 100644 index d9ca9dd..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_engine.mli +++ /dev/null @@ -1,194 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_engine - * Copyright (C) 2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Lwt unix main loop engine *) - -(** {6 Events} *) - -type event - (** Type of events. An event represent a callback registered to be - called when some event occurs. *) - -val stop_event : event -> unit - (** [stop_event event] stops the given event. *) - -val fake_event : event - (** Event which does nothing when stopped. *) - -(** {6 Event loop functions} *) - -val iter : bool -> unit - (** [iter block] performs one iteration of the main loop. If [block] - is [true] the function must blocks until one event become - available, otherwise it should just check for available events - and return immediatly. *) - -val on_readable : Unix.file_descr -> (event -> unit) -> event - (** [on_readable fd f] calls [f] each time [fd] becomes readable. *) - -val on_writable : Unix.file_descr -> (event -> unit) -> event - (** [on_readable fd f] calls [f] each time [fd] becomes writable. *) - -val on_timer : float -> bool -> (event -> unit) -> event - (** [on_timer delay repeat f] calls [f] one time after [delay] - seconds. If [repeat] is [true] then [f] is called each [delay] - seconds, otherwise it is called only one time. *) - -val readable_count : unit -> int - (** Returns the number of events waiting for a file descriptor to - become readable. *) - -val writable_count : unit -> int - (** Returns the number of events waiting for a file descriptor to - become writable. *) - -val timer_count : unit -> int - (** Returns the number of registered timers. *) - -val fake_io : Unix.file_descr -> unit - (** Simulates activity on the given file descriptor. *) - -(** {6 Engines} *) - -(** An engine represent a set of functions used to register different - kind of callbacks for different kind of events. *) - -(** Abstract class for engines. *) -class virtual abstract : object - method destroy : unit - (** Destroy the engine, remove all its events and free its - associated resources. *) - - method transfer : abstract -> unit - (** [transfer engine] moves all events from the current engine to - [engine]. Note that timers are reset in the destination - engine, i.e. if a timer with a delay of 2 seconds was - registered 1 second ago it will occurs in 2 seconds in the - destination engine. *) - - (** {6 Event loop methods} *) - - method virtual iter : bool -> unit - method on_readable : Unix.file_descr -> (event -> unit) -> event - method on_writable : Unix.file_descr -> (event -> unit) -> event - method on_timer : float -> bool -> (event -> unit) -> event - method fake_io : Unix.file_descr -> unit - method readable_count : int - method writable_count : int - method timer_count : int - - (** {6 Backend methods} *) - - (** Notes: - - - the callback passed to register methods is of type [unit -> - unit] and not [event -> unit] - - register methods returns a lazy value which unregister the - event when forced - *) - - method virtual private cleanup : unit - (** Cleanup resources associated to the engine. *) - - method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t -end - -(** Type of engines. *) -class type t = object - inherit abstract - - method iter : bool -> unit - method private cleanup : unit - method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t - method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t -end - -(** {6 Predefined engines} *) - -type ev_loop - (** Type of libev loops. *) - -(** Engine based on libev. If not compiled with libev support, the - creation of the class will raise {!Lwt_sys.Not_available}. *) -class libev : object - inherit t - - val loop : ev_loop - (** The libev loop used for this engine. *) - - method loop : ev_loop - (** Returns [loop]. *) -end - -(** Engine based on [Unix.select]. *) -class select : t - -(** Abstract class for engines based on a select-like function. *) -class virtual select_based : object - inherit t - - method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list - (** [select fds_r fds_w timeout] waits for either: - - - one of the file descriptor of [fds_r] to become readable - - one of the file descriptor of [fds_w] to become writable - - timeout to expire - - and returns the list of readable file descriptor and the list - of writable file descriptors. *) -end - -(** Abstract class for engines based on a poll-like function. *) -class virtual poll_based : object - inherit t - - method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list - (** [poll fds tiomeout], where [fds] is a list of tuples of the - form [(fd, check_readable, check_writable)], waits for either: - - - one of the file descriptor with [check_readable] set to - [true] to become readable - - one of the file descriptor with [check_writable] set to - [true] to become writable - - timeout to expire - - and returns the list of file descriptors with their readable - and writable status. *) -end - -(** {6 The current engine} *) - -val get : unit -> t - (** [get ()] returns the engine currently in use. *) - -val set : ?transfer : bool -> ?destroy : bool -> #t -> unit - (** [set ?transfer ?destroy engine] replaces the current engine by - the given one. - - If [transfer] is [true] (the default) all events from the - current engine are transferred to the new one. - - If [destroy] is [true] (the default) then the current engine is - destroyed before being replaced. *) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_gc.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_gc.ml deleted file mode 100644 index ff48236..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_gc.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_gc - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -let ensure_termination t = - if Lwt.state t = Lwt.Sleep then begin - let hook = Lwt_sequence.add_l (fun _ -> t) Lwt_main.exit_hooks in - (* Remove the hook when t has terminated *) - ignore (try_lwt t finally Lwt_sequence.remove hook; Lwt.return ()) - end - -let finaliser f x = - ensure_termination (f x) - -let finalise f = Gc.finalise (finaliser f) - -(* Exit hook for a finalise_or_exit *) -let foe_exit f weak _ = - match Weak.get weak 0 with - | None -> - (* The value has been garbage collected, normally this point - is never reached *) - Lwt.return () - | Some x -> - (* Just to avoid double finalisation *) - Weak.set weak 0 None; - f x - -(* Finaliser for a finalise_or_exit *) -let foe_finalise f hook weak x = - (* Remove the exit hook, it is not needed anymore *) - Lwt_sequence.remove hook; - (* This should not be necessary, i am just paranoid: *) - Weak.set weak 0 None; - (* Finally call the real finaliser: *) - finaliser f x - -let finalise_or_exit f x = - (* Create a weak pointer, so the exit-hook will prevent [x] from - being garbage collected: *) - let weak = Weak.create 1 in - Weak.set weak 0 (Some x); - let hook = Lwt_sequence.add_l (foe_exit f weak) Lwt_main.exit_hooks in - Gc.finalise (foe_finalise f hook weak) x diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_gc.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_gc.mli deleted file mode 100644 index 3adaa6f..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_gc.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_gc - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Interaction with the garbage collector *) - -(** This module offer a convenient way to add a finaliser launching a - thread to a value, without having to use [Lwt_unix.run] in the - finaliser. *) - -val finalise : ('a -> unit Lwt.t) -> 'a -> unit - (** [finalise f x] calls [f x] when [x] is garbage collected. If [f - x] yields, then Lwt will waits for its termination at the end of - the program. *) - -val finalise_or_exit : ('a -> unit Lwt.t) -> 'a -> unit - (** [finalise_or_exit f x] call [f x] when [x] is garbage collected - or (exclusively) when the program exit. *) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_io.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_io.ml deleted file mode 100644 index 201f476..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_io.ml +++ /dev/null @@ -1,1501 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_io - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt - -exception Channel_closed of string - -(* Minimum size for buffers: *) -let min_buffer_size = 16 - -let check_buffer_size fun_name buffer_size = - if buffer_size < min_buffer_size then - Printf.ksprintf invalid_arg "Lwt_io.%s: too small buffer size (%d)" fun_name buffer_size - else if buffer_size > Sys.max_string_length then - Printf.ksprintf invalid_arg "Lwt_io.%s: too big buffer size (%d)" fun_name buffer_size - else - () - -let default_buffer_size = ref 4096 - -(* +-----------------------------------------------------------------+ - | Types | - +-----------------------------------------------------------------+ *) - -type input -type output - -#if ocaml_version >= (3, 13) -type 'a mode = - | Input : input mode - | Output : output mode -#else -type 'a mode = - | Input - | Output -#endif - -let input : input mode = Input -let output : output mode = Output - -(* A channel state *) -type 'mode state = - | Busy_primitive - (* A primitive is running on the channel *) - - | Busy_atomic of 'mode channel - (* An atomic operations is being performed on the channel. The - argument is the temporary atomic wrapper. *) - - | Waiting_for_busy - (* A queued operation has not yet started. *) - - | Idle - (* The channel is unused *) - - | Closed - (* The channel has been closed *) - - | Invalid - (* The channel is a temporary channel created for an atomic - operation which has terminated. *) - -(* A wrapper, which ensures that io operations are atomic: *) -and 'mode channel = { - mutable state : 'mode state; - - channel : 'mode _channel; - (* The real channel *) - - mutable queued : unit Lwt.u Lwt_sequence.t; - (* Queued operations *) -} - -and 'mode _channel = { - mutable buffer : Lwt_bytes.t; - mutable length : int; - - mutable ptr : int; - (* Current position *) - - mutable max : int; - (* Position of the end of data int the buffer. It is equal to - [length] for output channels. *) - - abort_waiter : int Lwt.t; - (* Thread which is wakeup with an exception when the channel is - closed. *) - abort_wakener : int Lwt.u; - - mutable auto_flushing : bool; - (* Wether the auto-flusher is currently running or not *) - - main : 'mode channel; - (* The main wrapper *) - - close : unit Lwt.t Lazy.t; - (* Close function *) - - mode : 'mode mode; - (* The channel mode *) - - mutable offset : int64; - (* Number of bytes really read/written *) - - typ : typ; - (* Type of the channel. *) -} - -and typ = - | Type_normal of (Lwt_bytes.t -> int -> int -> int Lwt.t) * (int64 -> Unix.seek_command -> int64 Lwt.t) - (* The channel has been created with [make]. The first argument - is the refill/flush function and the second is the seek - function. *) - | Type_bytes - (* The channel has been created with [of_bytes]. *) - -type input_channel = input channel -type output_channel = output channel - -type direct_access = { - da_buffer : Lwt_bytes.t; - mutable da_ptr : int; - mutable da_max : int; - da_perform : unit -> int Lwt.t; -} - -let mode wrapper = wrapper.channel.mode - -(* +-----------------------------------------------------------------+ - | Creations, closing, locking, ... | - +-----------------------------------------------------------------+ *) - -module Outputs = Weak.Make(struct - type t = output_channel - let hash = Hashtbl.hash - let equal = ( == ) - end) - -(* Table of all opened output channels. On exit they are all - flushed: *) -let outputs = Outputs.create 32 - -#if ocaml_version >= (3, 13) -let position : type mode. mode channel -> int64 = fun wrapper -> -#else -let position wrapper = -#endif - let ch = wrapper.channel in - match ch.mode with - | Input -> - Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) - | Output -> - Int64.add ch.offset (Int64.of_int ch.ptr) - -#if ocaml_version >= (3, 13) -let name : type mode. mode _channel -> string = fun ch -> -#else -let name ch = -#endif - match ch.mode with - | Input -> "input" - | Output -> "output" - -let closed_channel ch = Channel_closed(name ch) -let invalid_channel ch = Failure(Printf.sprintf "temporary atomic %s channel no more valid" (name ch)) - -let is_busy ch = - match ch.state with - | Invalid -> - raise (invalid_channel ch.channel) - | Idle | Closed -> - false - | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> - true - -(* Flush/refill the buffer. No race condition could happen because - this function is always called atomically: *) -#if ocaml_version >= (3, 13) -let perform_io : type mode. mode _channel -> int Lwt.t = fun ch -> match ch.main.state with -#else -let perform_io ch = match ch.main.state with -#endif - | Busy_primitive | Busy_atomic _ -> begin - match ch.typ with - | Type_normal(perform_io, seek) -> - let ptr, len = match ch.mode with - | Input -> - (* Size of data in the buffer *) - let size = ch.max - ch.ptr in - (* If there are still data in the buffer, keep them: *) - if size > 0 then Lwt_bytes.unsafe_blit ch.buffer ch.ptr ch.buffer 0 size; - (* Update positions: *) - ch.ptr <- 0; - ch.max <- size; - (size, ch.length - size) - | Output -> - (0, ch.ptr) in - lwt n = pick [ch.abort_waiter; perform_io ch.buffer ptr len] in - (* Never trust user functions... *) - if n < 0 || n > len then - raise_lwt (Failure (Printf.sprintf "Lwt_io: invalid result of the [%s] function(request=%d,result=%d)" - (match ch.mode with Input -> "read" | Output -> "write") len n)) - else begin - (* Update the global offset: *) - ch.offset <- Int64.add ch.offset (Int64.of_int n); - (* Update buffer positions: *) - begin match ch.mode with - | Input -> - ch.max <- ch.max + n - | Output -> - (* Shift remaining data: *) - let len = len - n in - Lwt_bytes.unsafe_blit ch.buffer n ch.buffer 0 len; - ch.ptr <- len - end; - return n - end - - | Type_bytes -> begin - match ch.mode with - | Input -> - return 0 - | Output -> - raise_lwt (Failure "cannot flush a channel created with Lwt_io.of_string") - end - end - - | Closed -> - raise_lwt (closed_channel ch) - - | Invalid -> - raise_lwt (invalid_channel ch) - - | Idle | Waiting_for_busy -> - assert false - -let refill = perform_io -let flush_partial = perform_io - -let rec flush_total oc = - if oc.ptr > 0 then - lwt _ = flush_partial oc in - flush_total oc - else - return () - -let safe_flush_total oc = - try_lwt - flush_total oc - with - _ -> return () - -let deepest_wrapper ch = - let rec loop wrapper = - match wrapper.state with - | Busy_atomic wrapper -> - loop wrapper - | _ -> - wrapper - in - loop ch.main - -let auto_flush oc = - lwt () = Lwt.pause () in - let wrapper = deepest_wrapper oc in - match wrapper.state with - | Busy_primitive | Waiting_for_busy -> - (* The channel is used, cancel auto flushing. It will be - restarted when the channel returns to the [Idle] state: *) - oc.auto_flushing <- false; - return () - - | Busy_atomic _ -> - (* Cannot happen since we took the deepest wrapper: *) - assert false - - | Idle -> - oc.auto_flushing <- false; - wrapper.state <- Busy_primitive; - lwt () = safe_flush_total oc in - if wrapper.state = Busy_primitive then - wrapper.state <- Idle; - if not (Lwt_sequence.is_empty wrapper.queued) then - wakeup_later (Lwt_sequence.take_l wrapper.queued) (); - return () - - | Closed | Invalid -> - return () - -(* A ``locked'' channel is a channel in the state [Busy_primitive] or - [Busy_atomic] *) - -#if ocaml_version >= (3, 13) -let unlock : type m. m channel -> unit = fun wrapper -> match wrapper.state with -#else -let unlock wrapper = match wrapper.state with -#endif - | Busy_primitive | Busy_atomic _ -> - if Lwt_sequence.is_empty wrapper.queued then - wrapper.state <- Idle - else begin - wrapper.state <- Waiting_for_busy; - wakeup_later (Lwt_sequence.take_l wrapper.queued) () - end; - (* Launches the auto-flusher: *) - let ch = wrapper.channel in - if (* Launch the auto-flusher only if the channel is not busy: *) - (wrapper.state = Idle && - (* Launch the auto-flusher only for output channel: *) - (match ch.mode with Input -> false | Output -> true) && - (* Do not launch two auto-flusher: *) - not ch.auto_flushing && - (* Do not launch the auto-flusher if operations are queued: *) - Lwt_sequence.is_empty wrapper.queued) then begin - ch.auto_flushing <- true; - ignore (auto_flush ch) - end - - | Closed | Invalid -> - (* Do not change channel state if the channel has been closed *) - if not (Lwt_sequence.is_empty wrapper.queued) then - wakeup_later (Lwt_sequence.take_l wrapper.queued) () - - | Idle | Waiting_for_busy -> - (* We must never unlock an unlocked channel *) - assert false - -(* Wrap primitives into atomic io operations: *) -let primitive f wrapper = match wrapper.state with - | Idle -> - wrapper.state <- Busy_primitive; - try_lwt - f wrapper.channel - finally - unlock wrapper; - return () - - | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> - let (res, w) = task () in - let node = Lwt_sequence.add_r w wrapper.queued in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - lwt () = res in - begin match wrapper.state with - | Closed -> - (* The channel has been closed while we were waiting *) - unlock wrapper; - raise_lwt (closed_channel wrapper.channel) - - | Idle | Waiting_for_busy -> - wrapper.state <- Busy_primitive; - try_lwt - f wrapper.channel - finally - unlock wrapper; - return () - - | Invalid -> - raise_lwt (invalid_channel wrapper.channel) - - | Busy_primitive | Busy_atomic _ -> - assert false - end - - | Closed -> - raise_lwt (closed_channel wrapper.channel) - - | Invalid -> - raise_lwt (invalid_channel wrapper.channel) - -(* Wrap a sequence of io operations into an atomic operation: *) -let atomic f wrapper = match wrapper.state with - | Idle -> - let tmp_wrapper = { state = Idle; - channel = wrapper.channel; - queued = Lwt_sequence.create () } in - wrapper.state <- Busy_atomic tmp_wrapper; - try_lwt - f tmp_wrapper - finally - (* The temporary wrapper is no more valid: *) - tmp_wrapper.state <- Invalid; - unlock wrapper; - return () - - | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> - let (res, w) = task () in - let node = Lwt_sequence.add_r w wrapper.queued in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - lwt () = res in - begin match wrapper.state with - | Closed -> - (* The channel has been closed while we were waiting *) - unlock wrapper; - raise_lwt (closed_channel wrapper.channel) - - | Idle | Waiting_for_busy -> - let tmp_wrapper = { state = Idle; - channel = wrapper.channel; - queued = Lwt_sequence.create () } in - wrapper.state <- Busy_atomic tmp_wrapper; - try_lwt - f tmp_wrapper - finally - tmp_wrapper.state <- Invalid; - unlock wrapper; - return () - - | Invalid -> - raise_lwt (invalid_channel wrapper.channel) - - | Busy_primitive | Busy_atomic _ -> - assert false - end - - | Closed -> - raise_lwt (closed_channel wrapper.channel) - - | Invalid -> - raise_lwt (invalid_channel wrapper.channel) - -let rec abort wrapper = match wrapper.state with - | Busy_atomic tmp_wrapper -> - (* Close the depest opened wrapper: *) - abort tmp_wrapper - | Closed -> - (* Double close, just returns the same thing as before *) - Lazy.force wrapper.channel.close - | Invalid -> - raise_lwt (invalid_channel wrapper.channel) - | Idle | Busy_primitive | Waiting_for_busy -> - wrapper.state <- Closed; - (* Abort any current real reading/writing operation on the - channel: *) - wakeup_exn wrapper.channel.abort_wakener (closed_channel wrapper.channel); - Lazy.force wrapper.channel.close - -#if ocaml_version >= (3, 13) -let close : type mode. mode channel -> unit Lwt.t = fun wrapper -> -#else -let close wrapper = -#endif - let channel = wrapper.channel in - if channel.main != wrapper then - raise_lwt (Failure "Lwt_io.close: cannot close a channel obtained via Lwt_io.atomic") - else - match channel.mode with - | Input -> - (* Just close it now: *) - abort wrapper - | Output -> - try_lwt - (* Performs all pending actions, flush the buffer, then - close it: *) - primitive (fun channel -> safe_flush_total channel >> abort wrapper) wrapper - with _ -> - abort wrapper - -let flush_all () = - let wrappers = Outputs.fold (fun x l -> x :: l) outputs [] in - Lwt_list.iter_p - (fun wrapper -> - try_lwt - primitive safe_flush_total wrapper - with _ -> - return ()) - wrappers - -let () = - (* Flush all opened ouput channels on exit: *) - Lwt_main.at_exit flush_all - -let no_seek pos cmd = - raise_lwt (Failure "Lwt_io.seek: seek not supported on this channel") - -#if ocaml_version < (3, 13) -external unsafe_output : 'a channel -> output channel = "%identity" -#endif - -#if ocaml_version >= (3, 13) -let make : - type m. - ?buffer_size : int -> - ?close : (unit -> unit Lwt.t) -> - ?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) -> - mode : m mode -> - (Lwt_bytes.t -> int -> int -> int Lwt.t) -> - m channel = fun ?buffer_size ?(close=return) ?(seek=no_seek) ~mode perform_io -> -#else -let make ?buffer_size ?(close=return) ?(seek=no_seek) ~mode perform_io = -#endif - let size = - match buffer_size with - | None -> - !default_buffer_size - | Some size -> - check_buffer_size "Lwt_io.make" size; - size - in - let buffer = Lwt_bytes.create size and abort_waiter, abort_wakener = Lwt.wait () in - let rec ch = { - buffer = buffer; - length = size; - ptr = 0; - max = (match mode with - | Input -> 0 - | Output -> size); - close = lazy(try_lwt close ()); - abort_waiter = abort_waiter; - abort_wakener = abort_wakener; - main = wrapper; - auto_flushing = false; - mode = mode; - offset = 0L; - typ = Type_normal(perform_io, fun pos cmd -> try seek pos cmd with e -> raise_lwt e); - } and wrapper = { - state = Idle; - channel = ch; - queued = Lwt_sequence.create (); - } in -#if ocaml_version < (3, 13) - if mode = Output then Outputs.add outputs (unsafe_output wrapper); -#else - (match mode with - | Input -> () - | Output -> Outputs.add outputs wrapper); -#endif - wrapper - -let of_bytes ~mode bytes = - let length = Lwt_bytes.length bytes in - let abort_waiter, abort_wakener = Lwt.wait () in - let rec ch = { - buffer = bytes; - length = length; - ptr = 0; - max = length; - close = lazy(return ()); - abort_waiter = abort_waiter; - abort_wakener = abort_wakener; - main = wrapper; - (* Auto flush is set to [true] to prevent writing functions from - trying to launch the auto-fllushed. *) - auto_flushing = true; - mode = mode; - offset = 0L; - typ = Type_bytes; - } and wrapper = { - state = Idle; - channel = ch; - queued = Lwt_sequence.create (); - } in - wrapper - -let of_string ~mode str = of_bytes ~mode (Lwt_bytes.of_string str) - -#if ocaml_version >= (3, 13) -let of_fd : type m. ?buffer_size : int -> ?close : (unit -> unit Lwt.t) -> mode : m mode -> Lwt_unix.file_descr -> m channel = fun ?buffer_size ?close ~mode fd -> -#else -let of_fd ?buffer_size ?close ~mode fd = -#endif - let perform_io = match mode with - | Input -> Lwt_bytes.read fd - | Output -> Lwt_bytes.write fd - in - make - ?buffer_size - ~close:(match close with - | Some f -> f - | None -> (fun () -> Lwt_unix.close fd)) - ~seek:(fun pos cmd -> Lwt_unix.LargeFile.lseek fd pos cmd) - ~mode - perform_io - -#if ocaml_version >= (3, 13) -let of_unix_fd : type m. ?buffer_size : int -> ?close : (unit -> unit Lwt.t) -> mode : m mode -> Unix.file_descr -> m channel = fun ?buffer_size ?close ~mode fd -> -#else -let of_unix_fd ?buffer_size ?close ~mode fd = -#endif - of_fd ?buffer_size ?close ~mode (Lwt_unix.of_unix_file_descr fd) - -#if ocaml_version >= (3, 13) -let buffered : type m. m channel -> int = fun ch -> -#else -let buffered ch = -#endif - match ch.channel.mode with - | Input -> ch.channel.max - ch.channel.ptr - | Output -> ch.channel.ptr - -let buffer_size ch = ch.channel.length - -#if ocaml_version >= (3, 13) -let resize_buffer : type m. m channel -> int -> unit Lwt.t = fun wrapper len -> -#else -let resize_buffer wrapper len = -#endif - if len < min_buffer_size then invalid_arg "Lwt_io.resize_buffer"; - match wrapper.channel.typ with - | Type_bytes -> - raise_lwt (Failure "Lwt_io.resize_buffer: cannot resize the buffer of a channel created with Lwt_io.of_string") - | Type_normal _ -> -#if ocaml_version >= (3, 13) - let f : type m. m _channel -> unit Lwt.t = fun ch -> -#else - let f ch = -#endif - match ch.mode with - | Input -> - let unread_count = ch.max - ch.ptr in - (* Fail if we want to decrease the buffer size and there is - too much unread data in the buffer: *) - if len < unread_count then - raise_lwt (Failure "Lwt_io.resize_buffer: cannot decrease buffer size") - else begin - let buffer = Lwt_bytes.create len in - Lwt_bytes.unsafe_blit ch.buffer ch.ptr buffer 0 unread_count; - ch.buffer <- buffer; - ch.length <- len; - ch.ptr <- 0; - ch.max <- unread_count; - return () - end - | Output -> - (* If we decrease the buffer size, flush the buffer until - the number of buffered bytes fits into the new buffer: *) - let rec loop () = - if ch.ptr > len then - lwt _ = flush_partial ch in - loop () - else - return () - in - lwt () = loop () in - let buffer = Lwt_bytes.create len in - Lwt_bytes.unsafe_blit ch.buffer 0 buffer 0 ch.ptr; - ch.buffer <- buffer; - ch.length <- len; - ch.max <- len; - return () - in - primitive f wrapper - -(* +-----------------------------------------------------------------+ - | Byte-order | - +-----------------------------------------------------------------+ *) - -module ByteOrder = -struct - module type S = sig - val pos16_0 : int - val pos16_1 : int - val pos32_0 : int - val pos32_1 : int - val pos32_2 : int - val pos32_3 : int - val pos64_0 : int - val pos64_1 : int - val pos64_2 : int - val pos64_3 : int - val pos64_4 : int - val pos64_5 : int - val pos64_6 : int - val pos64_7 : int - end - - module LE = - struct - let pos16_0 = 0 - let pos16_1 = 1 - let pos32_0 = 0 - let pos32_1 = 1 - let pos32_2 = 2 - let pos32_3 = 3 - let pos64_0 = 0 - let pos64_1 = 1 - let pos64_2 = 2 - let pos64_3 = 3 - let pos64_4 = 4 - let pos64_5 = 5 - let pos64_6 = 6 - let pos64_7 = 7 - end - - module BE = - struct - let pos16_0 = 1 - let pos16_1 = 0 - let pos32_0 = 3 - let pos32_1 = 2 - let pos32_2 = 1 - let pos32_3 = 0 - let pos64_0 = 7 - let pos64_1 = 6 - let pos64_2 = 5 - let pos64_3 = 4 - let pos64_4 = 3 - let pos64_5 = 2 - let pos64_6 = 1 - let pos64_7 = 0 - end -end - -module Primitives = -struct - - (* This module contains all primitives operations. The operates - without protection regarding locking, they are wrapped after into - safe operations. *) - - (* +---------------------------------------------------------------+ - | Reading | - +---------------------------------------------------------------+ *) - - let rec read_char ic = - let ptr = ic.ptr in - if ptr = ic.max then - refill ic >>= function - | 0 -> raise_lwt End_of_file - | _ -> read_char ic - else begin - ic.ptr <- ptr + 1; - return (Lwt_bytes.unsafe_get ic.buffer ptr) - end - - let read_char_opt ic = - try_lwt - read_char ic >|= fun ch -> Some ch - with End_of_file -> - return None - - let read_line ic = - let buf = Buffer.create 128 in - let rec loop cr_read = - try_bind (fun _ -> read_char ic) - (function - | '\n' -> - return(Buffer.contents buf) - | '\r' -> - if cr_read then Buffer.add_char buf '\r'; - loop true - | ch -> - if cr_read then Buffer.add_char buf '\r'; - Buffer.add_char buf ch; - loop false) - (function - | End_of_file -> - if cr_read then Buffer.add_char buf '\r'; - return(Buffer.contents buf) - | exn -> - raise_lwt exn) - in - read_char ic >>= function - | '\r' -> loop true - | '\n' -> return "" - | ch -> Buffer.add_char buf ch; loop false - - let read_line_opt ic = - try_lwt - read_line ic >|= fun ch -> Some ch - with End_of_file -> - return None - - let unsafe_read_into ic str ofs len = - let avail = ic.max - ic.ptr in - if avail > 0 then begin - let len = min len avail in - Lwt_bytes.unsafe_blit_bytes_string ic.buffer ic.ptr str ofs len; - ic.ptr <- ic.ptr + len; - return len - end else begin - refill ic >>= fun n -> - let len = min len n in - Lwt_bytes.unsafe_blit_bytes_string ic.buffer 0 str ofs len; - ic.ptr <- len; - ic.max <- n; - return len - end - - let read_into ic str ofs len = - if ofs < 0 || len < 0 || ofs + len > String.length str then - raise_lwt (Invalid_argument (Printf.sprintf - "Lwt_io.read_into(ofs=%d,len=%d,str_len=%d)" - ofs len (String.length str))) - else begin - if len = 0 then - return 0 - else - unsafe_read_into ic str ofs len - end - - let rec unsafe_read_into_exactly ic str ofs len = - unsafe_read_into ic str ofs len >>= function - | 0 -> - raise_lwt End_of_file - | n -> - let len = len - n in - if len = 0 then - return () - else - unsafe_read_into_exactly ic str (ofs + n) len - - let read_into_exactly ic str ofs len = - if ofs < 0 || len < 0 || ofs + len > String.length str then - raise_lwt (Invalid_argument (Printf.sprintf - "Lwt_io.read_into_exactly(ofs=%d,len=%d,str_len=%d)" - ofs len (String.length str))) - else begin - if len = 0 then - return () - else - unsafe_read_into_exactly ic str ofs len - end - - let rev_concat len l = - let buf = String.create len in - let _ = - List.fold_left - (fun ofs str -> - let len = String.length str in - let ofs = ofs - len in - String.unsafe_blit str 0 buf ofs len; - ofs) - len l - in - buf - - let rec read_all ic total_len acc = - let len = ic.max - ic.ptr in - let str = String.create len in - Lwt_bytes.unsafe_blit_bytes_string ic.buffer ic.ptr str 0 len; - ic.ptr <- ic.max; - refill ic >>= function - | 0 -> - return (rev_concat (len + total_len) (str :: acc)) - | n -> - read_all ic (len + total_len) (str :: acc) - - let read count ic = - match count with - | None -> - read_all ic 0 [] - | Some len -> - let str = String.create len in - lwt real_len = unsafe_read_into ic str 0 len in - if real_len < len then - return (String.sub str 0 real_len) - else - return str - - let read_value ic = - let header = String.create 20 in - lwt () = unsafe_read_into_exactly ic header 0 20 in - let bsize = Marshal.data_size header 0 in - let buffer = String.create (20 + bsize) in - String.unsafe_blit header 0 buffer 0 20; - lwt () = unsafe_read_into_exactly ic buffer 20 bsize in - return (Marshal.from_string buffer 0) - - (* +---------------------------------------------------------------+ - | Writing | - +---------------------------------------------------------------+ *) - - let flush = flush_total - - let rec write_char oc ch = - let ptr = oc.ptr in - if ptr < oc.length then begin - oc.ptr <- ptr + 1; - Lwt_bytes.unsafe_set oc.buffer ptr ch; - return () - end else - lwt _ = flush_partial oc in - write_char oc ch - - let rec unsafe_write_from oc str ofs len = - let avail = oc.length - oc.ptr in - if avail >= len then begin - Lwt_bytes.unsafe_blit_string_bytes str ofs oc.buffer oc.ptr len; - oc.ptr <- oc.ptr + len; - return 0 - end else begin - Lwt_bytes.unsafe_blit_string_bytes str ofs oc.buffer oc.ptr avail; - oc.ptr <- oc.length; - lwt _ = flush_partial oc in - let len = len - avail in - if oc.ptr = 0 then begin - if len = 0 then - return 0 - else - (* Everything has been written, try to write more: *) - unsafe_write_from oc str (ofs + avail) len - end else - (* Not everything has been written, just what is - remaining: *) - return len - end - - let write_from oc str ofs len = - if ofs < 0 || len < 0 || ofs + len > String.length str then - raise_lwt (Invalid_argument (Printf.sprintf - "Lwt_io.write_from(ofs=%d,len=%d,str_len=%d)" - ofs len (String.length str))) - else begin - if len = 0 then - return 0 - else - unsafe_write_from oc str ofs len >>= fun remaining -> return (len - remaining) - end - - let rec unsafe_write_from_exactly oc str ofs len = - unsafe_write_from oc str ofs len >>= function - | 0 -> - return () - | n -> - unsafe_write_from_exactly oc str (ofs + len - n) n - - let write_from_exactly oc str ofs len = - if ofs < 0 || len < 0 || ofs + len > String.length str then - raise_lwt (Invalid_argument (Printf.sprintf - "Lwt_io.write_from_exactly(ofs=%d,len=%d,str_len=%d)" - ofs len (String.length str))) - else begin - if len = 0 then - return () - else - unsafe_write_from_exactly oc str ofs len - end - - let write oc str = - unsafe_write_from_exactly oc str 0 (String.length str) - - let write_line oc str = - lwt () = unsafe_write_from_exactly oc str 0 (String.length str) in - write_char oc '\n' - - let write_value oc ?(flags=[]) x = - write oc (Marshal.to_string x flags) - - (* +---------------------------------------------------------------+ - | Low-level access | - +---------------------------------------------------------------+ *) - - let rec read_block_unsafe ic size f = - if ic.max - ic.ptr < size then - refill ic >>= function - | 0 -> - raise_lwt End_of_file - | _ -> - read_block_unsafe ic size f - else begin - let ptr = ic.ptr in - ic.ptr <- ptr + size; - f ic.buffer ptr - end - - let rec write_block_unsafe oc size f = - if oc.max - oc.ptr < size then - lwt _ = flush_partial oc in - write_block_unsafe oc size f - else begin - let ptr = oc.ptr in - oc.ptr <- ptr + size; - f oc.buffer ptr - end - -#if ocaml_version >= (3, 13) - let block : type m. m _channel -> int -> (Lwt_bytes.t -> int -> 'a Lwt.t) -> 'a Lwt.t = fun ch size f -> -#else - let block ch size f = -#endif - if size < 0 || size > min_buffer_size then - raise_lwt (Invalid_argument(Printf.sprintf "Lwt_io.block(size=%d)" size)) - else - if ch.max - ch.ptr >= size then begin - let ptr = ch.ptr in - ch.ptr <- ptr + size; - f ch.buffer ptr - end else - match ch.mode with - | Input -> - read_block_unsafe ch size f - | Output -> - write_block_unsafe ch size f - - let perform token da ch = - if !token then begin - if da.da_max <> ch.max || da.da_ptr < ch.ptr || da.da_ptr > ch.max then - raise_lwt (Invalid_argument "Lwt_io.direct_access.perform") - else begin - ch.ptr <- da.da_ptr; - lwt count = perform_io ch in - da.da_ptr <- ch.ptr; - da.da_max <- ch.max; - return count - end - end else - raise_lwt (Failure "Lwt_io.direct_access.perform: this function can not be called outside Lwt_io.direct_access") - - let direct_access ch f = - let token = ref true in - let rec da = { - da_ptr = ch.ptr; - da_max = ch.max; - da_buffer = ch.buffer; - da_perform = (fun _ -> perform token da ch); - } in - lwt x = f da in - token := false; - if da.da_max <> ch.max || da.da_ptr < ch.ptr || da.da_ptr > ch.max then - raise_lwt (Failure "Lwt_io.direct_access: invalid result of [f]") - else begin - ch.ptr <- da.da_ptr; - return x - end - - module MakeNumberIO(ByteOrder : ByteOrder.S) = - struct - open ByteOrder - - (* +-------------------------------------------------------------+ - | Reading numbers | - +-------------------------------------------------------------+ *) - - let get buffer ptr = Char.code (Lwt_bytes.unsafe_get buffer ptr) - - let read_int ic = - read_block_unsafe ic 4 - (fun buffer ptr -> - let v0 = get buffer (ptr + pos32_0) - and v1 = get buffer (ptr + pos32_1) - and v2 = get buffer (ptr + pos32_2) - and v3 = get buffer (ptr + pos32_3) in - let v = v0 lor (v1 lsl 8) lor (v2 lsl 16) lor (v3 lsl 24) in - if v3 land 0x80 = 0 then - return v - else - return (v - (1 lsl 32))) - - let read_int16 ic = - read_block_unsafe ic 2 - (fun buffer ptr -> - let v0 = get buffer (ptr + pos16_0) - and v1 = get buffer (ptr + pos16_1) in - let v = v0 lor (v1 lsl 8) in - if v1 land 0x80 = 0 then - return v - else - return (v - (1 lsl 16))) - - let read_int32 ic = - read_block_unsafe ic 4 - (fun buffer ptr -> - let v0 = get buffer (ptr + pos32_0) - and v1 = get buffer (ptr + pos32_1) - and v2 = get buffer (ptr + pos32_2) - and v3 = get buffer (ptr + pos32_3) in - return (Int32.logor - (Int32.logor - (Int32.of_int v0) - (Int32.shift_left (Int32.of_int v1) 8)) - (Int32.logor - (Int32.shift_left (Int32.of_int v2) 16) - (Int32.shift_left (Int32.of_int v3) 24)))) - - let read_int64 ic = - read_block_unsafe ic 8 - (fun buffer ptr -> - let v0 = get buffer (ptr + pos64_0) - and v1 = get buffer (ptr + pos64_1) - and v2 = get buffer (ptr + pos64_2) - and v3 = get buffer (ptr + pos64_3) - and v4 = get buffer (ptr + pos64_4) - and v5 = get buffer (ptr + pos64_5) - and v6 = get buffer (ptr + pos64_6) - and v7 = get buffer (ptr + pos64_7) in - return (Int64.logor - (Int64.logor - (Int64.logor - (Int64.of_int v0) - (Int64.shift_left (Int64.of_int v1) 8)) - (Int64.logor - (Int64.shift_left (Int64.of_int v2) 16) - (Int64.shift_left (Int64.of_int v3) 24))) - (Int64.logor - (Int64.logor - (Int64.shift_left (Int64.of_int v4) 32) - (Int64.shift_left (Int64.of_int v5) 40)) - (Int64.logor - (Int64.shift_left (Int64.of_int v6) 48) - (Int64.shift_left (Int64.of_int v7) 56))))) - - let read_float32 ic = read_int32 ic >>= fun x -> return (Int32.float_of_bits x) - let read_float64 ic = read_int64 ic >>= fun x -> return (Int64.float_of_bits x) - - (* +-------------------------------------------------------------+ - | Writing numbers | - +-------------------------------------------------------------+ *) - - let set buffer ptr x = Lwt_bytes.unsafe_set buffer ptr (Char.unsafe_chr x) - - let write_int oc v = - write_block_unsafe oc 4 - (fun buffer ptr -> - set buffer (ptr + pos32_0) v; - set buffer (ptr + pos32_1) (v lsr 8); - set buffer (ptr + pos32_2) (v lsr 16); - set buffer (ptr + pos32_3) (v asr 24); - return ()) - - let write_int16 oc v = - write_block_unsafe oc 2 - (fun buffer ptr -> - set buffer (ptr + pos16_0) v; - set buffer (ptr + pos16_1) (v lsr 8); - return ()) - - let write_int32 oc v = - write_block_unsafe oc 4 - (fun buffer ptr -> - set buffer (ptr + pos32_0) (Int32.to_int v); - set buffer (ptr + pos32_1) (Int32.to_int (Int32.shift_right v 8)); - set buffer (ptr + pos32_2) (Int32.to_int (Int32.shift_right v 16)); - set buffer (ptr + pos32_3) (Int32.to_int (Int32.shift_right v 24)); - return ()) - - let write_int64 oc v = - write_block_unsafe oc 8 - (fun buffer ptr -> - set buffer (ptr + pos64_0) (Int64.to_int v); - set buffer (ptr + pos64_1) (Int64.to_int (Int64.shift_right v 8)); - set buffer (ptr + pos64_2) (Int64.to_int (Int64.shift_right v 16)); - set buffer (ptr + pos64_3) (Int64.to_int (Int64.shift_right v 24)); - set buffer (ptr + pos64_4) (Int64.to_int (Int64.shift_right v 32)); - set buffer (ptr + pos64_5) (Int64.to_int (Int64.shift_right v 40)); - set buffer (ptr + pos64_6) (Int64.to_int (Int64.shift_right v 48)); - set buffer (ptr + pos64_7) (Int64.to_int (Int64.shift_right v 56)); - return ()) - - let write_float32 oc v = write_int32 oc (Int32.bits_of_float v) - let write_float64 oc v = write_int64 oc (Int64.bits_of_float v) - end - - (* +---------------------------------------------------------------+ - | Random access | - +---------------------------------------------------------------+ *) - - let do_seek seek pos = - lwt offset = seek pos Unix.SEEK_SET in - if offset <> pos then - raise_lwt (Failure "Lwt_io.set_position: seek failed") - else - return () - -#if ocaml_version >= (3, 13) - let set_position : type m. m _channel -> int64 -> unit Lwt.t = fun ch pos -> match ch.typ, ch.mode with -#else - let set_position ch pos = match ch.typ, ch.mode with -#endif - | Type_normal(perform_io, seek), Output -> - lwt () = flush_total ch in - lwt () = do_seek seek pos in - ch.offset <- pos; - return () - | Type_normal(perform_io, seek), Input -> - let current = Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) in - if pos >= current && pos <= ch.offset then begin - ch.ptr <- ch.max - (Int64.to_int (Int64.sub ch.offset pos)); - return () - end else begin - lwt () = do_seek seek pos in - ch.offset <- pos; - ch.ptr <- 0; - ch.max <- 0; - return () - end - | Type_bytes, _ -> - if pos < 0L || pos > Int64.of_int ch.length then - raise_lwt (Failure "Lwt_io.set_position: out of bounds") - else begin - ch.ptr <- Int64.to_int pos; - return () - end - - let length ch = match ch.typ with - | Type_normal(perform_io, seek) -> - lwt len = seek 0L Unix.SEEK_END in - lwt () = do_seek seek ch.offset in - return len - | Type_bytes -> - return (Int64.of_int ch.length) -end - -(* +-----------------------------------------------------------------+ - | Primitive operations | - +-----------------------------------------------------------------+ *) - -let read_char wrapper = - let channel = wrapper.channel in - let ptr = channel.ptr in - (* Speed-up in case a character is available in the buffer. It - increases performances by 10x. *) - if wrapper.state = Idle && ptr < channel.max then begin - channel.ptr <- ptr + 1; - return (Lwt_bytes.unsafe_get channel.buffer ptr) - end else - primitive Primitives.read_char wrapper - -let read_char_opt wrapper = - let channel = wrapper.channel in - let ptr = channel.ptr in - if wrapper.state = Idle && ptr < channel.max then begin - channel.ptr <- ptr + 1; - return (Some(Lwt_bytes.unsafe_get channel.buffer ptr)) - end else - primitive Primitives.read_char_opt wrapper - -let read_line ic = primitive Primitives.read_line ic -let read_line_opt ic = primitive Primitives.read_line_opt ic -let read ?count ic = primitive (fun ic -> Primitives.read count ic) ic -let read_into ic str ofs len = primitive (fun ic -> Primitives.read_into ic str ofs len) ic -let read_into_exactly ic str ofs len = primitive (fun ic -> Primitives.read_into_exactly ic str ofs len) ic -let read_value ic = primitive Primitives.read_value ic - -let flush oc = primitive Primitives.flush oc - -let write_char wrapper x = - let channel = wrapper.channel in - let ptr = channel.ptr in - if wrapper.state = Idle && ptr < channel.max then begin - channel.ptr <- ptr + 1; - Lwt_bytes.unsafe_set channel.buffer ptr x; - (* Fast launching of the auto flusher: *) - if not channel.auto_flushing then begin - channel.auto_flushing <- true; - ignore (auto_flush channel); - return () - end else - return () - end else - primitive (fun oc -> Primitives.write_char oc x) wrapper - -let write oc str = primitive (fun oc -> Primitives.write oc str) oc -let write_line oc x = primitive (fun oc -> Primitives.write_line oc x) oc -let write_from oc str ofs len = primitive (fun oc -> Primitives.write_from oc str ofs len) oc -let write_from_exactly oc str ofs len = primitive (fun oc -> Primitives.write_from_exactly oc str ofs len) oc -let write_value oc ?flags x = primitive (fun oc -> Primitives.write_value oc ?flags x) oc - -let block ch size f = primitive (fun ch -> Primitives.block ch size f) ch -let direct_access ch f = primitive (fun ch -> Primitives.direct_access ch f) ch - -let set_position ch pos = primitive (fun ch -> Primitives.set_position ch pos) ch -let length ch = primitive Primitives.length ch - -module type NumberIO = sig - val read_int : input_channel -> int Lwt.t - val read_int16 : input_channel -> int Lwt.t - val read_int32 : input_channel -> int32 Lwt.t - val read_int64 : input_channel -> int64 Lwt.t - val read_float32 : input_channel -> float Lwt.t - val read_float64 : input_channel -> float Lwt.t - val write_int : output_channel -> int -> unit Lwt.t - val write_int16 : output_channel -> int -> unit Lwt.t - val write_int32 : output_channel -> int32 -> unit Lwt.t - val write_int64 : output_channel -> int64 -> unit Lwt.t - val write_float32 : output_channel -> float -> unit Lwt.t - val write_float64 : output_channel -> float -> unit Lwt.t -end - -module MakeNumberIO(ByteOrder : ByteOrder.S) = -struct - module Primitives = Primitives.MakeNumberIO(ByteOrder) - - let read_int ic = primitive Primitives.read_int ic - let read_int16 ic = primitive Primitives.read_int16 ic - let read_int32 ic = primitive Primitives.read_int32 ic - let read_int64 ic = primitive Primitives.read_int64 ic - let read_float32 ic = primitive Primitives.read_float32 ic - let read_float64 ic = primitive Primitives.read_float64 ic - - let write_int oc x = primitive (fun oc -> Primitives.write_int oc x) oc - let write_int16 oc x = primitive (fun oc -> Primitives.write_int16 oc x) oc - let write_int32 oc x = primitive (fun oc -> Primitives.write_int32 oc x) oc - let write_int64 oc x = primitive (fun oc -> Primitives.write_int64 oc x) oc - let write_float32 oc x = primitive (fun oc -> Primitives.write_float32 oc x) oc - let write_float64 oc x = primitive (fun oc -> Primitives.write_float64 oc x) oc -end - -module LE = MakeNumberIO(ByteOrder.LE) -module BE = MakeNumberIO(ByteOrder.BE) - -type byte_order = Lwt_sys.byte_order = Little_endian | Big_endian -let system_byte_order = Lwt_sys.byte_order - -include (val (match system_byte_order with - | Little_endian -> (module LE : NumberIO) - | Big_endian -> (module BE : NumberIO)) : NumberIO) - -(* +-----------------------------------------------------------------+ - | Other | - +-----------------------------------------------------------------+ *) - -let read_chars ic = Lwt_stream.from (fun _ -> read_char_opt ic) -let write_chars oc chars = Lwt_stream.iter_s (fun char -> write_char oc char) chars -let read_lines ic = Lwt_stream.from (fun _ -> read_line_opt ic) -let write_lines oc lines = Lwt_stream.iter_s (fun line -> write_line oc line) lines - -let zero = - make - ~mode:input - ~buffer_size:min_buffer_size - (fun str ofs len -> Lwt_bytes.fill str ofs len '\x00'; return len) - -let null = - make - ~mode:output - ~buffer_size:min_buffer_size - (fun str ofs len -> return len) - -(* Do not close standard ios on close, otherwise uncaught exceptions - will not be printed *) -let stdin = of_fd ~mode:input Lwt_unix.stdin -let stdout = of_fd ~mode:output Lwt_unix.stdout -let stderr = of_fd ~mode:output Lwt_unix.stderr - -let fprint oc txt = write oc txt -let fprintl oc txt = write_line oc txt -let fprintf oc fmt = Printf.ksprintf (fun txt -> write oc txt) fmt -let fprintlf oc fmt = Printf.ksprintf (fun txt -> write_line oc txt) fmt - -let print txt = write stdout txt -let printl txt = write_line stdout txt -let printf fmt = Printf.ksprintf print fmt -let printlf fmt = Printf.ksprintf printl fmt - -let eprint txt = write stderr txt -let eprintl txt = write_line stderr txt -let eprintf fmt = Printf.ksprintf eprint fmt -let eprintlf fmt = Printf.ksprintf eprintl fmt - -let pipe ?buffer_size _ = - let fd_r, fd_w = Lwt_unix.pipe () in - (of_fd ?buffer_size ~mode:input fd_r, of_fd ?buffer_size ~mode:output fd_w) - -type file_name = string - -#if ocaml_version >= (3, 13) -let open_file : type m. ?buffer_size : int -> ?flags : Unix.open_flag list -> ?perm : Unix.file_perm -> mode : m mode -> file_name -> m channel Lwt.t = fun ?buffer_size ?flags ?perm ~mode filename -> -#else -let open_file ?buffer_size ?flags ?perm ~mode filename = -#endif - let flags = match flags, mode with - | Some l, _ -> - l - | None, Input -> - [Unix.O_RDONLY; Unix.O_NONBLOCK] - | None, Output -> - [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK] - and perm = match perm, mode with - | Some p, _ -> - p - | None, Input -> - 0 - | None, Output -> - 0o666 - in - lwt fd = Lwt_unix.openfile filename flags perm in - return (of_fd ?buffer_size ~mode fd) - -let with_file ?buffer_size ?flags ?perm ~mode filename f = - lwt ic = open_file ?buffer_size ?flags ?perm ~mode filename in - try_lwt - f ic - finally - close ic - -let file_length filename = with_file ~mode:input filename length - -let open_connection ?buffer_size sockaddr = - let fd = Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in - let close = lazy begin - try_lwt - Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; - return () - with Unix.Unix_error(Unix.ENOTCONN, _, _) -> - (* This may happen if the server closed the connection before us *) - return () - finally - Lwt_unix.close fd - end in - try_lwt - lwt () = Lwt_unix.connect fd sockaddr in - (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); - return (make ?buffer_size - ~close:(fun _ -> Lazy.force close) - ~mode:input (Lwt_bytes.read fd), - make ?buffer_size - ~close:(fun _ -> Lazy.force close) - ~mode:output (Lwt_bytes.write fd)) - with exn -> - lwt () = Lwt_unix.close fd in - raise_lwt exn - -let with_connection ?buffer_size sockaddr f = - lwt ic, oc = open_connection ?buffer_size sockaddr in - try_lwt - f (ic, oc) - finally - close ic <&> close oc - -type server = { - shutdown : unit Lazy.t; -} - -let shutdown_server server = Lazy.force server.shutdown - -let establish_server ?buffer_size ?(backlog=5) sockaddr f = - let sock = Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in - Lwt_unix.setsockopt sock Unix.SO_REUSEADDR true; - Lwt_unix.bind sock sockaddr; - Lwt_unix.listen sock backlog; - let abort_waiter, abort_wakener = wait () in - let abort_waiter = abort_waiter >> return `Shutdown in - let rec loop () = - pick [Lwt_unix.accept sock >|= (fun x -> `Accept x); abort_waiter] >>= function - | `Accept(fd, addr) -> - (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); - let close = lazy begin - Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; - Lwt_unix.close fd - end in - f (of_fd ?buffer_size ~mode:input ~close:(fun () -> Lazy.force close) fd, - of_fd ?buffer_size ~mode:output ~close:(fun () -> Lazy.force close) fd); - loop () - | `Shutdown -> - lwt () = Lwt_unix.close sock in - match sockaddr with - | Unix.ADDR_UNIX path when path <> "" && path.[0] <> '\x00' -> - Unix.unlink path; - return () - | _ -> - return () - in - ignore (loop ()); - { shutdown = lazy(wakeup abort_wakener `Shutdown) } - -let ignore_close ch = - ignore (close ch) - -let make_stream f lazy_ic = - let lazy_ic = - lazy(lwt ic = Lazy.force lazy_ic in - Gc.finalise ignore_close ic; - return ic) - in - Lwt_stream.from (fun _ -> - lwt ic = Lazy.force lazy_ic in - lwt x = f ic in - if x = None then - lwt () = close ic in - return x - else - return x) - -let lines_of_file filename = - make_stream read_line_opt (lazy(open_file ~mode:input filename)) - -let lines_to_file filename lines = - with_file ~mode:output filename (fun oc -> write_lines oc lines) - -let chars_of_file filename = - make_stream read_char_opt (lazy(open_file ~mode:input filename)) - -let chars_to_file filename chars = - with_file ~mode:output filename (fun oc -> write_chars oc chars) - -let hexdump_stream oc stream = write_lines oc (Lwt_stream.hexdump stream) -let hexdump oc buf = hexdump_stream oc (Lwt_stream.of_string buf) - -let set_default_buffer_size size = - check_buffer_size "set_default_buffer_size" size; - default_buffer_size := size -let default_buffer_size _ = !default_buffer_size diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_io.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_io.mli deleted file mode 100644 index ccac330..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_io.mli +++ /dev/null @@ -1,522 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_io - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Buffered byte channels *) - -(** A {b channel} is a high-level object for performing IOs. It allow - to read/write things from/to the outside worlds in an efficient - way, by minimising the number of system calls. - - An {b output channel} is a channel that can be used to send data - and an {b input channel} is a channel that can used to receive - data. - - If you are familiar with buffered channels you may be familiar too - with the {b flush} operation. Note that byte channles of this - modules are automatically flushed when there is nothing else to do - (i.e. before the program goes into idle), so this means that you - no longer have to write: - - {[ - eprintf "log message\n"; - flush stderr; - ]} - - to have you messages displayed. - - Note about errors: input functions of this module raise - [End_of_file] when the end-of-file is reached (i.e. when the read - function returns [0]). Other exceptions are ones caused by the - backend read/write functions, such as [Unix.Unix_error]. -*) - -exception Channel_closed of string - (** Exception raised when a channel is closed. The parameter is a - description of the channel. *) - -(** {6 Types} *) - -type 'mode channel - (** Type of buffered byte channels *) - -type input - (** Input mode *) - -type output - (** Output mode *) - -(** Channel mode *) -#if ocaml_version >= (3, 13) -type 'a mode = - | Input : input mode - | Output : output mode -#else -type 'a mode = - private - | Input - | Output -#endif - -val input : input mode - (** [input] input mode representation *) - -val output : output mode - (** [output] output mode representation *) - -type input_channel = input channel - (** Type of input channels *) - -type output_channel = output channel - (** Type of output channels *) - -val mode : 'a channel -> 'a mode - (** [mode ch] returns the mode of a channel *) - -(** {6 Well-known instances} *) - -val stdin : input_channel - (** The standard input, it reads data from {!Lwt_unix.stdin} *) - -val stdout : output_channel - (** The standard output, it writes data to {!Lwt_unix.stdout} *) - -val stderr : output_channel - (** The standard output for error messages, it writes data to - {!Lwt_unix.stderr} *) - -val zero : input_channel - (** Inputs which returns always ['\x00'] *) - -val null : output_channel - (** Output which drops everything *) - -(** {6 Channels creation/manipulation} *) - -val pipe : ?buffer_size : int -> unit -> input_channel * output_channel - (** [pipe ?buffer_size ()] creates a pipe using {!Lwt_unix.pipe} and - makes two channels from the two returned file descriptors *) - -val make : - ?buffer_size : int -> - ?close : (unit -> unit Lwt.t) -> - ?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) -> - mode : 'mode mode -> - (Lwt_bytes.t -> int -> int -> int Lwt.t) -> 'mode channel - (** [make ?buffer_size ?close ~mode perform_io] is the - main function for creating new channels. - - @param buffer_size size of the internal buffer. It must be - between 16 and [Sys.max_string_length] - - @param close close function of the channel. It defaults to - [Lwt.return] - - @param seek same meaning as [Unix.lseek] - - @param mode either {!input} or {!output} - - @param perform_io is the read or write function. It is called - when more input is needed or when the buffer need to be - flushed. *) - -val of_bytes : mode : 'mode mode -> Lwt_bytes.t -> 'mode channel - (** Create a channel from a byte array. Reading/writing is done - directly on the provided array. *) - -val of_fd : ?buffer_size : int -> ?close : (unit -> unit Lwt.t) -> mode : 'mode mode -> Lwt_unix.file_descr -> 'mode channel - (** [of_fd ?buffer_size ?close ~mode fd] creates a channel from a - file descriptor. - - @param close defaults to closing the file descriptor. *) - -val of_unix_fd : ?buffer_size : int -> ?close : (unit -> unit Lwt.t) -> mode : 'mode mode -> Unix.file_descr -> 'mode channel - (** [of_unix_fd ?buffer_size ?close ~mode fd] is a short-hand for: - - [of_fd ?buffer_size ?close (Lwt_unix.of_unix_file_descr fd)] *) - -val close : 'a channel -> unit Lwt.t - (** [close ch] closes the given channel. If [ch] is an output - channel, it performs all pending actions, flush it and close - it. If [ch] is an input channel, it just close it immediatly. - - [close] returns the result of the close function of the - channel. Multiple calls to [close] will return exactly the same - value. - - Note: you cannot use [close] on channel obtained with an - {!atomic}. *) - -val abort : 'a channel -> unit Lwt.t - (** [abort ch] abort current operations and close the channel - immediatly. *) - -val atomic : ('a channel -> 'b Lwt.t) -> ('a channel -> 'b Lwt.t) - (** [atomic f] transforms a sequence of io operations into one - single atomic io operation. - - Note: - - the channel passed to [f] is invalid after [f] terminates - - [atomic] can be called inside another [atomic] *) - -val file_length : string -> int64 Lwt.t - (** Returns the length of a file *) - -val buffered : 'a channel -> int - (** [buffered oc] returns the number of bytes in the buffer *) - -val flush : output_channel -> unit Lwt.t - (** [flush oc] performs all pending writes on [oc] *) - -val flush_all : unit -> unit Lwt.t - (** [flush_all ()] flushes all open output channels *) - -val buffer_size : 'a channel -> int - (** Returns the size of the internal buffer. *) - -val resize_buffer : 'a channel -> int -> unit Lwt.t - (** Resize the internal buffer to the given size *) - -val is_busy : 'a channel -> bool - (** [is_busy channel] returns whether the given channel is currently - busy. A channel is busy when there is at least one job using it - that has not yet terminated. *) - -(** {6 Random access} *) - -val position : 'a channel -> int64 - (** [position ch] Returns the current position in the channel. *) - -val set_position : 'a channel -> int64 -> unit Lwt.t - (** [set_position ch pos] Sets the position in the output channel. This - does not work if the channel do not support random access. *) - -val length : 'a channel -> int64 Lwt.t - (** Returns the length of the channel in bytes *) - -(** {6 Reading} *) - -(** Note: except for functions dealing with streams ({!read_chars} and - {!read_lines}) all functions are {b atomic}. *) - -val read_char : input_channel -> char Lwt.t - (** [read_char ic] reads the next character of [ic]. - - @raise End_of_file if the end of the file is reached *) - -val read_char_opt : input_channel -> char option Lwt.t - (** Same as {!read_byte} but does not raises [End_of_file] on end of - input *) - -val read_chars : input_channel -> char Lwt_stream.t - (** [read_chars ic] returns a stream holding all characters of - [ic] *) - -val read_line : input_channel -> string Lwt.t - (** [read_line ic] reads one complete line from [ic] and returns it - without the end of line. End of line is either ["\n"] or - ["\r\n"]. - - If the end of line is reached before reading any character, - [End_of_file] is raised. If it is reached before reading an end - of line but characters have already been read, they are - returned. *) - -val read_line_opt : input_channel -> string option Lwt.t - (** Same as {!read_line} but do not raise [End_of_file] on end of - input. *) - -val read_lines : input_channel -> string Lwt_stream.t - (** [read_lines ic] returns a stream holding all lines of [ic] *) - -val read : ?count : int -> input_channel -> string Lwt.t - (** [read ?count ic] reads at most [len] characters from [ic]. It - returns [""] if the end of input is reached. If [count] is not - specified, it reads all bytes until the end of input. *) - -val read_into : input_channel -> string -> int -> int -> int Lwt.t - (** [read_into ic buffer offset length] reads up to [length] bytes, - stores them in [buffer] at offset [offset], and returns the - number of bytes read. - - Note: [read_into] does not raise [End_of_file], it returns a - length of [0] instead. *) - -val read_into_exactly : input_channel -> string -> int -> int -> unit Lwt.t - (** [read_into_exactly ic buffer offset length] reads exactly - [length] bytes and stores them in [buffer] at offset [offset]. - - @raise End_of_file on end of input *) - -val read_value : input_channel -> 'a Lwt.t - (** [read_value ic] reads a marshaled value from [ic] *) - -(** {6 Writing} *) - -(** Note: as for reading functions, all functions except - {!write_chars} and {!write_lines} are {b atomic}. - - For example if you use {!write_line} in to different threads, the - two operations will be serialized, and lines cannot be mixed. -*) - -val write_char : output_channel -> char -> unit Lwt.t - (** [write_char oc char] writes [char] on [oc] *) - -val write_chars : output_channel -> char Lwt_stream.t -> unit Lwt.t - (** [write_chars oc chars] writes all characters of [chars] on - [oc] *) - -val write : output_channel -> string -> unit Lwt.t - (** [write oc str] writes all characters of [str] on [oc] *) - -val write_line : output_channel -> string -> unit Lwt.t - (** [write_line oc str] writes [str] on [oc] followed by a - new-line. *) - -val write_lines : output_channel -> string Lwt_stream.t -> unit Lwt.t - (** [write_lines oc lines] writes all lines of [lines] to [oc] *) - -val write_from : output_channel -> string -> int -> int -> int Lwt.t - (** [write_from oc buffer offset length] writes up to [length] bytes - to [oc], from [buffer] at offset [offset] and returns the number - of bytes actually written *) - -val write_from_exactly : output_channel -> string -> int -> int -> unit Lwt.t - (** [write_from_exactly oc buffer offset length] writes all [length] - bytes from [buffer] at offset [offset] to [oc] *) - -val write_value : output_channel -> ?flags : Marshal.extern_flags list -> 'a -> unit Lwt.t - (** [write_value oc ?flags x] marshals the value [x] to [oc] *) - -(** {6 Printing} *) - -(** These functions are basically helpers. Also you may prefer the - using the name {!printl} rather than {!write_line} because it is - shorter. - - The general name of a printing function is [print]. - - Where [] is one of: - - ['f'], which means that the function takes as argument a channel - - nothing, which means that the function prints on {!stdout} - - ['e'], which means that the function prints on {!stderr} - - and [] is a combination of: - - ['l'] which means that a new-line character is printed after the message - - ['f'] which means that the function takes as argument a {b format} instead - of a string -*) - -val fprint : output_channel -> string -> unit Lwt.t -val fprintl : output_channel -> string -> unit Lwt.t -val fprintf : output_channel -> ('a, unit, string, unit Lwt.t) format4 -> 'a -val fprintlf : output_channel -> ('a, unit, string, unit Lwt.t) format4 -> 'a -val print : string -> unit Lwt.t -val printl : string -> unit Lwt.t -val printf : ('a, unit, string, unit Lwt.t) format4 -> 'a -val printlf : ('a, unit, string, unit Lwt.t) format4 -> 'a -val eprint : string -> unit Lwt.t -val eprintl : string -> unit Lwt.t -val eprintf : ('a, unit, string, unit Lwt.t) format4 -> 'a -val eprintlf : ('a, unit, string, unit Lwt.t) format4 -> 'a - -(** {6 Utilities} *) - -val hexdump_stream : output_channel -> char Lwt_stream.t -> unit Lwt.t - (** [hexdump_stream oc byte_stream] produces the same output as the - command [hexdump -C]. *) - -val hexdump : output_channel -> string -> unit Lwt.t - (** [hexdump oc str = hexdump_stream oc (Lwt_stream.of_string str)] *) - -(** {6 File utilities} *) - -type file_name = string - (** Type of file names *) - -val open_file : - ?buffer_size : int -> - ?flags : Unix.open_flag list -> - ?perm : Unix.file_perm -> - mode : 'a mode -> - file_name -> 'a channel Lwt.t - (** [open_file ?buffer_size ?flags ?perm ~mode filename] open the - file with name [filename] and returns a channel for - reading/writing it. - - @raise Unix.Unix_error on error. - *) - -val with_file : - ?buffer_size : int -> - ?flags : Unix.open_flag list -> - ?perm : Unix.file_perm -> - mode : 'a mode -> - file_name -> ('a channel -> 'b Lwt.t) -> 'b Lwt.t - (** [with_file ?buffer_size ?flags ?perm ~mode filename f] open a - file and passes the channel to [f]. It is ensured that the - channel is closed when [f ch] terminates (even if it fails). *) - -val open_connection : ?buffer_size : int -> Unix.sockaddr -> (input_channel * output_channel) Lwt.t - (** [open_connection ?buffer_size ~mode addr] open a connection to - the given address and returns two channels for using it. - - The connection is completly closed when you close both - channels. - - @raise Unix.Unix_error on error. - *) - -val with_connection : ?buffer_size : int -> Unix.sockaddr -> (input_channel * output_channel -> 'a Lwt.t) -> 'a Lwt.t - (** [with_connection ?buffer_size ~mode addr f] open a connection to - the given address and passes the channels to [f] *) - -type server - (** Type of a server *) - -val establish_server : ?buffer_size : int -> ?backlog : int -> Unix.sockaddr -> (input_channel * output_channel -> unit) -> server - (** [establich_server ?buffer_size ?backlog sockaddr f] creates a - server which will listen for incomming connections. New - connections are passed to [f]. Note that [f] must not raise any - exception. - - [backlog] is the argument passed to [Lwt_unix.listen] *) - -val shutdown_server : server -> unit - (** Shutdown the given server *) - -val lines_of_file : file_name -> string Lwt_stream.t - (** [lines_of_file name] returns a stream of all lines of the file - with name [name]. The file is automatically closed when all - lines have been read. *) - -val lines_to_file : file_name -> string Lwt_stream.t -> unit Lwt.t - (** [lines_to_file name lines] writes all lines of [lines] to - [files] *) - -val chars_of_file : file_name -> char Lwt_stream.t - (** [chars_of_file name] returns a stream of all characters of the - file with name [name]. As for {!lines_of_file} the file is - closed when all characters have been read. *) - -val chars_to_file : file_name -> char Lwt_stream.t -> unit Lwt.t - (** [chars_to_file name chars] writes all characters of [chars] to - [name] *) - -(** {6 Input/output of integers} *) - -(** Common interface for reading/writing integers in binary *) -module type NumberIO = sig - - (** {8 Reading} *) - - val read_int : input_channel -> int Lwt.t - (** Reads a 32-bits integer as an ocaml int *) - - val read_int16 : input_channel -> int Lwt.t - val read_int32 : input_channel -> int32 Lwt.t - val read_int64 : input_channel -> int64 Lwt.t - - val read_float32 : input_channel -> float Lwt.t - (** Reads an IEEE single precision floating point value *) - - val read_float64 : input_channel -> float Lwt.t - (** Reads an IEEE double precision floating point value *) - - (** {8 Writing} *) - - val write_int : output_channel -> int -> unit Lwt.t - (** Writes an ocaml int as a 32-bits integer *) - - val write_int16 : output_channel -> int -> unit Lwt.t - val write_int32 : output_channel -> int32 -> unit Lwt.t - val write_int64 : output_channel -> int64 -> unit Lwt.t - - val write_float32 : output_channel -> float -> unit Lwt.t - (** Writes an IEEE single precision floating point value *) - - val write_float64 : output_channel -> float -> unit Lwt.t - (** Writes an IEEE double precision floating point value *) -end - -module LE : NumberIO - (** Reading/writing of numbers in little-endian *) - -module BE : NumberIO - (** Reading/writing of numbers in big-endian *) - -include NumberIO -(** Reading/writing of numbers in the system endianness. *) - -type byte_order = Lwt_sys.byte_order = Little_endian | Big_endian - (** Type of byte order *) - -val system_byte_order : byte_order - (** Same as {!Lwt_sys.byte_order}. *) - -(** {6 Low-level access to the internal buffer} *) - -val block : 'a channel -> int -> (Lwt_bytes.t -> int -> 'b Lwt.t) -> 'b Lwt.t - (** [block ch size f] pass to [f] the internal buffer and an - offset. The buffer contains [size] chars at [offset]. [f] may - reads or writes these chars. [size] must verify [0 <= size <= - 16] *) - -(** Informations for accessing directly to the internal buffer of a - channel *) -type direct_access = { - da_buffer : Lwt_bytes.t; - (** The internal buffer *) - mutable da_ptr : int; - (** The pointer to: - - the beginning of free space for output channels - - the beginning of data for input channels *) - mutable da_max : int; - (** The maximum offset *) - da_perform : unit -> int Lwt.t; - (** - for input channels: - refill the buffer and returns how many bytes have been read - - for output channels: - flush partially the buffer and returns how many bytes have been written *) -} - -val direct_access : 'a channel -> (direct_access -> 'b Lwt.t) -> 'b Lwt.t - (** [direct_access ch f] pass to [f] a {!direct_access} - structure. [f] must use it and update [da_ptr] to reflect how - many bytes have been read/written. *) - -(** {6 Misc} *) - -val default_buffer_size : unit -> int - (** Return the default size for buffers. Channels that are created - without specific size use this one. *) - -val set_default_buffer_size : int -> unit - (** Change the default buffer size. - - @raise Invalid_argument if the given size is smaller than [16] - or greater than [Sys.max_string_length] *) - -(**/**) - -val of_string : mode : 'mode mode -> string -> 'mode channel - (* Deprecated *) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_libev_stubs.c b/server/thirdparty/lwt-2.3.2/src/unix/lwt_libev_stubs.c deleted file mode 100644 index 6fb3517..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_libev_stubs.c +++ /dev/null @@ -1,211 +0,0 @@ -/* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_unix_stubs - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - */ - -/* Stubs for libev */ - -#include "lwt_config.h" - -#if defined(HAVE_LIBEV) - -#include -#include -#include -#include -#include -#include -#include -#include - -#include "lwt_unix.h" - -/* +-----------------------------------------------------------------+ - | Loops | - +-----------------------------------------------------------------+ */ - -static int compare_loops(value a, value b) -{ - return (int)(Data_custom_val(a) - Data_custom_val(b)); -} - -static long hash_loop(value loop) -{ - return (long)Data_custom_val(loop); -} - -static struct custom_operations loop_ops = { - "lwt.libev.loop", - custom_finalize_default, - compare_loops, - hash_loop, - custom_serialize_default, - custom_deserialize_default -}; - -CAMLprim value lwt_libev_init() -{ - struct ev_loop *loop = ev_loop_new(EVFLAG_FORKCHECK); - if (!loop) caml_failwith("lwt_libev_init"); - value result = caml_alloc_custom(&loop_ops, sizeof(struct ev_loop*), 0, 1); - Ev_loop_val(result) = loop; - return result; -} - -CAMLprim value lwt_libev_stop(value loop) -{ - ev_loop_destroy(Ev_loop_val(loop)); - return Val_unit; -} - -static int lwt_libev_in_blocking_section = 0; - -#define LWT_LIBEV_CHECK \ - if (lwt_libev_in_blocking_section) { \ - lwt_libev_in_blocking_section = 0; \ - caml_leave_blocking_section(); \ - } - -CAMLprim value lwt_libev_loop(value loop, value block) -{ - caml_enter_blocking_section(); - lwt_libev_in_blocking_section = 1; - ev_loop(Ev_loop_val(loop), Bool_val(block) ? EVLOOP_ONESHOT : EVLOOP_ONESHOT | EVLOOP_NONBLOCK); - LWT_LIBEV_CHECK; - return Val_unit; -} - -CAMLprim value lwt_libev_unloop(value loop) -{ - ev_unloop(Ev_loop_val(loop), EVUNLOOP_ONE); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | Watchers | - +-----------------------------------------------------------------+ */ - -#define Ev_io_val(v) *(struct ev_io**)Data_custom_val(v) -#define Ev_timer_val(v) *(struct ev_timer**)Data_custom_val(v) - -static int compare_watchers(value a, value b) -{ - return (int)(Data_custom_val(a) - Data_custom_val(b)); -} - -static long hash_watcher(value watcher) -{ - return (long)Data_custom_val(watcher); -} - -static struct custom_operations watcher_ops = { - "lwt.libev.watcher", - custom_finalize_default, - compare_watchers, - hash_watcher, - custom_serialize_default, - custom_deserialize_default -}; - -/* +-----------------------------------------------------------------+ - | IO watchers | - +-----------------------------------------------------------------+ */ - -static void handle_io(struct ev_loop *loop, ev_io *watcher, int revents) -{ - LWT_LIBEV_CHECK; - caml_callback((value)watcher->data, Val_unit); -} - -static value lwt_libev_io_init(struct ev_loop *loop, int fd, int event, value callback) -{ - CAMLparam1(callback); - CAMLlocal1(result); - /* Create and initialise the watcher */ - struct ev_io* watcher = lwt_unix_new(struct ev_io); - ev_io_init(watcher, handle_io, fd, event); - /* Wrap the watcher into a custom caml value */ - result = caml_alloc_custom(&watcher_ops, sizeof(struct ev_io*), 0, 1); - Ev_io_val(result) = watcher; - /* Store the callback in the watcher, and register it as a root */ - watcher->data = (void*)callback; - caml_register_generational_global_root((value*)(&(watcher->data))); - /* Start the event */ - ev_io_start(loop, watcher); - CAMLreturn(result); -} - -CAMLprim value lwt_libev_readable_init(value loop, value fd, value callback) -{ - return lwt_libev_io_init(Ev_loop_val(loop), FD_val(fd), EV_READ, callback); -} - -CAMLprim value lwt_libev_writable_init(value loop, value fd, value callback) -{ - return lwt_libev_io_init(Ev_loop_val(loop), FD_val(fd), EV_WRITE, callback); -} - -CAMLprim value lwt_libev_io_stop(value loop, value val_watcher) -{ - struct ev_io* watcher = Ev_io_val(val_watcher); - caml_remove_generational_global_root((value*)(&(watcher->data))); - ev_io_stop(Ev_loop_val(loop), watcher); - free(watcher); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | Timer watchers | - +-----------------------------------------------------------------+ */ - -static void handle_timer(struct ev_loop *loop, ev_timer *watcher, int revents) -{ - LWT_LIBEV_CHECK; - caml_callback((value)watcher->data, Val_unit); -} - -CAMLprim value lwt_libev_timer_init(value loop, value delay, value repeat, value callback) -{ - CAMLparam2(delay, callback); - CAMLlocal1(result); - /* Create and initialise the watcher */ - struct ev_timer* watcher = lwt_unix_new(struct ev_timer); - ev_timer_init(watcher, handle_timer, Double_val(delay), Bool_val(repeat)); - /* Wrap the watcher into a custom caml value */ - result = caml_alloc_custom(&watcher_ops, sizeof(struct ev_timer*), 0, 1); - Ev_timer_val(result) = watcher; - /* Store the callback in the watcher, and register it as a root */ - watcher->data = (void*)callback; - caml_register_generational_global_root((value*)(&(watcher->data))); - /* Start the event */ - ev_timer_start(Ev_loop_val(loop), watcher); - CAMLreturn(result); -} - -CAMLprim value lwt_libev_timer_stop(value loop, value val_watcher) -{ - struct ev_timer* watcher = Ev_timer_val(val_watcher); - caml_remove_generational_global_root((value*)(&(watcher->data))); - ev_timer_stop(Ev_loop_val(loop), watcher); - free(watcher); - return Val_unit; -} - -#endif diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_log.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_log.ml deleted file mode 100644 index e9542f5..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_log.ml +++ /dev/null @@ -1,559 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_log - * Copyright (C) 2002 Shawn Wagner - * 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(* This code is an adaptation of [syslog-ocaml] *) - -open Lwt - -let program_name = Filename.basename Sys.argv.(0) - -(* Errors happening in this module are always logged to [stderr]: *) -let log_intern fmt = - Printf.ksprintf (fun msg -> ignore_result (Lwt_io.eprintlf "%s: Lwt_log: %s" program_name msg)) fmt - -(* +-----------------------------------------------------------------+ - | Log levels | - +-----------------------------------------------------------------+ *) - -type level = - | Debug - | Info - | Notice - | Warning - | Error - | Fatal - -let string_of_level = function - | Debug -> "debug" - | Info -> "info" - | Notice -> "notice" - | Warning -> "warning" - | Error -> "error" - | Fatal -> "fatal" - -(* +-----------------------------------------------------------------+ - | Patterns and rules | - +-----------------------------------------------------------------+ *) - -type pattern = string list - (* A pattern is represented by a list of literals: - - For example ["foo*bar*"] is represented by ["foo"; "bar"; ""]. *) - -let sub_equal str ofs patt = - let str_len = String.length str and patt_len = String.length patt in - let rec loop ofs ofs_patt = - ofs_patt = patt_len || (str.[ofs] = patt.[ofs_patt] && loop (ofs + 1) (ofs_patt + 1)) - in - ofs + patt_len <= str_len && loop ofs 0 - -let pattern_match pattern string = - let length = String.length string in - let rec loop offset pattern = - if offset = length then - pattern = [] || pattern = [""] - else - match pattern with - | [] -> - false - | literal :: pattern -> - let literal_length = String.length literal in - let max_offset = length - literal_length in - let rec search offset = - offset <= max_offset - && ((sub_equal string offset literal && loop (offset + literal_length) pattern) - || search (offset + 1)) - in - search offset - in - match pattern with - | [] -> - string = "" - | literal :: pattern -> - sub_equal string 0 literal && loop (String.length literal) pattern - -let split pattern = - let len = String.length pattern in - let rec loop ofs = - if ofs = len then - [""] - else - match try Some(String.index_from pattern ofs '*') with Not_found -> None with - | Some ofs' -> - String.sub pattern ofs (ofs' - ofs) :: loop (ofs' + 1) - | None -> - [String.sub pattern ofs (len - ofs)] - in - loop 0 - -let rules = ref ( - match try Some(Sys.getenv "LWT_LOG") with Not_found -> None with - | Some str -> - let rec loop = function - | [] -> - [] - | (pattern, level) :: rest -> - let pattern = split pattern in - match String.lowercase level with - | "debug" -> (pattern, Debug) :: loop rest - | "info" -> (pattern, Info) :: loop rest - | "notice" -> (pattern, Notice) :: loop rest - | "warning" -> (pattern, Warning) :: loop rest - | "error" -> (pattern, Error) :: loop rest - | "fatal" -> (pattern, Fatal) :: loop rest - | level -> log_intern "invalid log level (%s)" level; loop rest - in - loop (Lwt_log_rules.rules (Lexing.from_string str)) - | None -> - [] -) - -(* +-----------------------------------------------------------------+ - | Sections | - +-----------------------------------------------------------------+ *) - -module Section = -struct - type t = { - name : string; - mutable level : level; - mutable modified : bool; - } - - type section = t - - module Sections = Weak.Make(struct - type t = section - let equal a b = a.name = b.name - let hash s = Hashtbl.hash s.name - end) - - let sections = Sections.create 32 - - let find_level name = - let rec loop = function - | [] -> - Notice - | (pattern, level) :: rest -> - if pattern_match pattern name then - level - else - loop rest - in - loop !rules - - let recompute_levels () = - Sections.iter - (fun section -> - if not section.modified then - section.level <- find_level section.name) - sections - - let make name = - let section = { name = name; level = Notice; modified = false } in - try - Sections.find sections section - with Not_found -> - section.level <- find_level name; - Sections.add sections section; - section - - let name section = section.name - - let main = make "main" - - let level section = section.level - - let set_level section level = - section.level <- level; - section.modified <- true - - let reset_level section = - if section.modified then begin - section.modified <- false; - section.level <- find_level section.name - end -end - -type section = Section.t - -let add_rule pattern level = - rules := (split pattern, level) :: !rules; - Section.recompute_levels () - -let append_rule pattern level = - rules := !rules @ [(split pattern, level)]; - Section.recompute_levels () - -(* +-----------------------------------------------------------------+ - | Loggers | - +-----------------------------------------------------------------+ *) - -exception Logger_closed - -type logger = { - mutable lg_closed : bool; - lg_output : section -> level -> string list -> unit Lwt.t; - lg_close : unit Lwt.t Lazy.t; -} - -let close logger = - logger.lg_closed <- true; - Lazy.force logger.lg_close - -let make ~output ~close = - { - lg_closed = false; - lg_output = output; - lg_close = Lazy.lazy_from_fun close; - } - -let broadcast loggers = - make - ~output:(fun section level lines -> - Lwt_list.iter_p (fun logger -> logger.lg_output section level lines) loggers) - ~close:return - -let dispatch f = - make - ~output:(fun section level lines -> (f section level).lg_output section level lines) - ~close:return - -(* +-----------------------------------------------------------------+ - | Templates | - +-----------------------------------------------------------------+ *) - -type template = string - -let location_key = Lwt.new_key () - -let date_string time = - let tm = Unix.localtime time in - let month_string = - match tm.Unix.tm_mon with - | 0 -> "Jan" - | 1 -> "Feb" - | 2 -> "Mar" - | 3 -> "Apr" - | 4 -> "May" - | 5 -> "Jun" - | 6 -> "Jul" - | 7 -> "Aug" - | 8 -> "Sep" - | 9 -> "Oct" - | 10 -> "Nov" - | 11 -> "Dec" - | _ -> Printf.ksprintf failwith "Lwt_log.ascdate: invalid month, %d" tm.Unix.tm_mon - in - Printf.sprintf "%s %2d %02d:%02d:%02d" month_string tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec - -let render ~buffer ~template ~section ~level ~message = - let time = lazy(Unix.gettimeofday ()) in - let file, line, column = - match Lwt.get location_key with - | Some loc -> loc - | None -> ("", -1, -1) - in - Buffer.add_substitute buffer - (function - | "date" -> date_string (Lazy.force time) - | "milliseconds" -> String.sub (Printf.sprintf "%.4f" (fst (modf (Lazy.force time)))) 2 4 - | "name" -> program_name - | "pid" -> string_of_int (Unix.getpid ()) - | "message" -> message - | "level" -> string_of_level level - | "section" -> Section.name section - | "loc-file" -> file - | "loc-line" -> string_of_int line - | "loc-column" -> string_of_int column - | var -> Printf.ksprintf invalid_arg "Lwt_log.render_buffer: unknown variable %S" var) - template - -(* +-----------------------------------------------------------------+ - | Predefined loggers | - +-----------------------------------------------------------------+ *) - -let null = - make - ~output:(fun section level lines -> return ()) - ~close:return - -let channel ?(template="$(name): $(section): $(message)") ~close_mode ~channel () = - make - ~output:(fun section level lines -> - Lwt_io.atomic begin fun oc -> - let buf = Buffer.create 42 in - lwt () = - Lwt_list.iter_s - (fun line -> - Buffer.clear buf; - render ~buffer:buf ~template ~section ~level ~message:line; - Buffer.add_char buf '\n'; - Lwt_io.write oc (Buffer.contents buf)) - lines - in - Lwt_io.flush oc - end channel) - ~close:(match close_mode with - | `Keep -> return - | `Close -> (fun () -> Lwt_io.close channel)) - -let default = - ref(channel ~close_mode:`Keep ~channel:Lwt_io.stderr ()) - -let file ?(template="$(date): $(section): $(message)") ?(mode=`Append) ?(perm=0o640) ~file_name () = - let flags = match mode with - | `Append -> - [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND; Unix.O_NONBLOCK] - | `Truncate -> - [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK] in - lwt fd = Lwt_unix.openfile file_name flags 0o666 in - Lwt_unix.set_close_on_exec fd; - let oc = Lwt_io.of_fd ~mode:Lwt_io.output fd in - return (channel ~template ~close_mode:`Close ~channel:oc ()) - -let level_code = function - | Fatal -> 0 - | Error -> 3 - | Warning -> 4 - | Notice -> 5 - | Info -> 6 - | Debug -> 7 - -type syslog_facility = - [ `Auth | `Authpriv | `Cron | `Daemon | `FTP | `Kernel - | `Local0 | `Local1 | `Local2 | `Local3 | `Local4 | `Local5 | `Local6 | `Local7 - | `LPR | `Mail | `News | `Syslog | `User | `UUCP | `NTP | `Security | `Console ] - -let facility_code = function - | `Kernel -> 0 - | `User -> 1 - | `Mail -> 2 - | `Daemon -> 3 - | `Auth -> 4 - | `Syslog -> 5 - | `LPR -> 6 - | `News -> 7 - | `UUCP -> 8 - | `Cron -> 9 - | `Authpriv -> 10 - | `FTP -> 11 - | `NTP -> 12 - | `Security -> 13 - | `Console -> 14 - | `Local0 -> 16 - | `Local1 -> 17 - | `Local2 -> 18 - | `Local3 -> 19 - | `Local4 -> 20 - | `Local5 -> 21 - | `Local6 -> 22 - | `Local7 -> 23 - -type syslog_connection_type = STREAM | DGRAM - -let shutdown fd = - Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; - Lwt_unix.close fd - -(* Try to find a socket in [paths]. For each path it check that the - file is a socket and try to establish connection in DGRAM mode then in - STREAM mode. *) -let syslog_connect paths = - let rec loop = function - | [] -> - (* No working socket found *) - log_intern "no working socket found in {%s}; is syslogd running?" - (String.concat ", " (List.map (Printf.sprintf "\"%s\"") paths)); - raise_lwt (Sys_error(Unix.error_message Unix.ENOENT)) - | path :: paths -> - begin try - return (Some (Unix.stat path).Unix.st_kind) - with - | Unix.Unix_error(Unix.ENOENT, _, _) -> - return None - | Unix.Unix_error(error, _, _) -> - log_intern "can not stat \"%s\": %s" path (Unix.error_message error); - return None - end >>= function - | None -> - loop paths - | Some Unix.S_SOCK -> begin - (* First, we try with a dgram socket : *) - let fd = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_DGRAM 0 in - try_lwt - lwt () = Lwt_unix.connect fd (Unix.ADDR_UNIX path) in - Lwt_unix.set_close_on_exec fd; - return (DGRAM, fd) - with - | Unix.Unix_error(Unix.EPROTOTYPE, _, _) -> begin - lwt () = Lwt_unix.close fd in - (* Then try with a stream socket: *) - let fd = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - try_lwt - lwt () = Lwt_unix.connect fd (Unix.ADDR_UNIX path) in - Lwt_unix.set_close_on_exec fd; - return (STREAM, fd) - with Unix.Unix_error(error, _, _) -> - lwt () = Lwt_unix.close fd in - log_intern "can not connect to \"%s\": %s" path (Unix.error_message error); - loop paths - end - | Unix.Unix_error(error, _, _) -> - lwt () = Lwt_unix.close fd in - log_intern "can not connect to \"%s\": %s" path (Unix.error_message error); - loop paths - end - | Some _ -> - log_intern "\"%s\" is not a socket" path; - loop paths - in - loop paths - -(* Write the whole contents of a string on the given file - descriptor: *) -let write_string fd str = - let len = String.length str in - let rec aux start_ofs = - if start_ofs = len then - return () - else - lwt n = Lwt_unix.write fd str start_ofs (len - start_ofs) in - if n <> 0 then - aux (start_ofs + n) - else - return () - in - aux 0 - -let truncate buf max = - if Buffer.length buf > max then begin - let suffix = "" in - let len_suffix = String.length suffix in - let str = Buffer.sub buf 0 max in - StringLabels.blit ~src:suffix ~src_pos:0 ~dst:str ~dst_pos:(max - len_suffix) ~len:len_suffix; - str - end else - Buffer.contents buf - -let syslog ?(template="$(date) $(name)[$(pid)]: $(section): $(message)") ?(paths=["/dev/log"; "/var/run/log"]) ~facility () = - let syslog_socket = ref None and mutex = Lwt_mutex.create () in - let get_syslog () = match !syslog_socket with - | Some x -> - return x - | None -> - lwt x = syslog_connect paths in - syslog_socket := Some x; - return x - in - make - ~output:(fun section level lines -> - Lwt_mutex.with_lock mutex - (fun () -> - let buf = Buffer.create 42 in - let make_line socket_type msg = - Buffer.clear buf; - Printf.bprintf buf "<%d>" ((facility_code facility lsl 3) lor level_code level); - render ~buffer:buf ~template ~section ~level ~message:msg; - if socket_type = STREAM then Buffer.add_char buf '\x00'; - truncate buf 1024 - in - let rec print socket_type fd = function - | [] -> - return () - | line :: lines -> - try_lwt - lwt () = write_string fd (make_line socket_type line) in - print socket_type fd lines - with Unix.Unix_error(_, _, _) -> - (* Try to reconnect *) - lwt () = shutdown fd in - syslog_socket := None; - lwt socket_type, fd = get_syslog () in - lwt () = write_string fd (make_line socket_type line) in - print socket_type fd lines - in - lwt socket_type, fd = get_syslog () in - print socket_type fd lines)) - ~close:(fun () -> - match !syslog_socket with - | None -> - return () - | Some(socket_type, fd) -> - shutdown fd) - -(* +-----------------------------------------------------------------+ - | Logging functions | - +-----------------------------------------------------------------+ *) - -let split str = - let len = String.length str in - let rec aux i = - if i >= len then - [] - else - let j = try String.index_from str i '\n' with Not_found -> String.length str in - String.sub str i (j - i) :: aux (j + 1) - in - aux 0 - -let log ?exn ?(section=Section.main) ?location ?logger ~level message = - let logger = match logger with - | None -> !default - | Some logger -> logger - in - if logger.lg_closed then - raise_lwt Logger_closed - else if level >= section.Section.level then - match exn with - | None -> - Lwt.with_value location_key location (fun () -> logger.lg_output section level (split message)) - | Some exn -> - let message = message ^ ": " ^ Printexc.to_string exn in - let message = - if Printexc.backtrace_status () then - match Printexc.get_backtrace () with - | "" -> message - | backtrace -> message ^ "\nbacktrace:\n" ^ backtrace - else - message - in - Lwt.with_value location_key location (fun () -> logger.lg_output section level (split message)) - else - return () - -let log_f ?exn ?section ?location ?logger ~level format = - Printf.ksprintf (log ?exn ?section ?location ?logger ~level) format - -let debug ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Debug msg -let debug_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (debug ?exn ?section ?location ?logger) fmt -let info ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Info msg -let info_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (info ?exn ?section ?location ?logger) fmt -let notice ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Notice msg -let notice_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (notice ?exn ?section ?location ?logger) fmt -let warning ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Warning msg -let warning_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (warning ?exn ?section ?location ?logger) fmt -let error ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Error msg -let error_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (error ?exn ?section ?location ?logger) fmt -let fatal ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Fatal msg -let fatal_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (fatal ?exn ?section ?location ?logger) fmt diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_log.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_log.mli deleted file mode 100644 index 6c203ef..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_log.mli +++ /dev/null @@ -1,316 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_log - * Copyright (C) 2002 Shawn Wagner - * 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Logging facility *) - -(** This module provides functions to deal with logging. - It support: - - - logging to the syslog daemon - - logging to a channel (stderr, stdout, ...) - - logging to a file - - logging to multiple destination at the same time -*) - -(** {6 Types} *) - -(** Type of log levels. A level determines the importance of a - message *) -type level = - | Debug - (** Debugging message. They can be automatically removed by the - syntax extension. *) - | Info - (** Informational message. Suitable to be displayed when the - program is in verbose mode. *) - | Notice - (** Same as {!Info}, but is displayed by default. *) - | Warning - (** Something strange happend *) - | Error - (** An error message, which should not means the end of the - program. *) - | Fatal - (** A fatal error happened, in most cases the program will end - after a fatal error. *) - -type logger - (** Type of a logger. A logger is responsible for dispatching messages - and storing them somewhere. - - Lwt provides loggers sending log messages to a file, syslog, - ... but you can also create you own logger. *) - -type section - (** Each logging message has a section. Sections can be used to - structure your logs. For example you can choose different - loggers according to the section. - - Each section carries a level, and messages with a lower log - level than than the section level will be dropped. - - Section levels are initialised using the [LWT_LOG] environment - variable, which must contains one or more rules of the form - [pattern -> level] separated by ";". Where [pattern] is a string - that may contain [*]. - - For example, if [LWT_LOG] contains: - {[ - access -> warning; - foo[*] -> error - ]} - then the level of the section ["access"] is {!Warning} and the - level of any section matching ["foo[*]"] is {!Error}. - - If the pattern is omited in a rule then the pattern ["*"] is - used instead, so [LWT_LOG] may just contains ["debug"] for - instance. - - If [LWT_LOG] is not defined then the rule ["* -> notice"] is - used instead. *) - -val add_rule : string -> level -> unit - (** [add_rule pattern level] adds a rule for sections logging - levels. The rule is added before all other rules. It takes - effect immediatly and affect all sections for which the level - has not been set explicitly with {!Section.set_level}. [pattern] - may contains [*]. For example: - - {[ - Lwt_log.add_rule "lwt*" Lwt_log.Info - ]} - *) - -val append_rule : string -> level -> unit - (** [append_rule pattern level] adds the given rule after all other - rules. For example to set the default fallback rule: - - {[ - Lwt_log.append_rule "*" Lwt_log.Info - ]} - *) - -(** {6 Logging functions} *) - -val log : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> level : level -> string -> unit Lwt.t - (** [log ?section ?logger ~level message] logs a message. - - [section] defaults to {!Section.main}. If [logger] is not - specified, then the default one is used instead (see - {!default}). - - If [exn] is provided, then its string representation - (= [Printexc.to_string exn]) will be append to the message, and if - possible the backtrace will also be logged. - - [location] contains the location of the logging directive, it is - of the form [(file_name, line, column)]. *) - -val log_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> level : level -> ('a, unit, string, unit Lwt.t) format4 -> 'a - (** [log_f] is the same as [log] except that it takes a format - string *) - -(** The following functions are the same as {!log} except that their - name determines which level is used. - - For example {!info msg} is the same as {!log ~level:Info msg}. -*) - -val debug : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t -val debug_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a - -val info : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t -val info_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a - -val notice : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t -val notice_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a - -val warning : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t -val warning_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a - -val error : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t -val error_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a - -val fatal : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t -val fatal_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a - -(** Sections *) -module Section : sig - type t = section - - val make : string -> section - (** [make name] creates a section with the given name. Two calls - to {!make} with the same name will return the same section - object. *) - - val name : section -> string - (** [name section] returns the name of [section]. *) - - val main : section - (** The main section. It is the section used by default when no - one is provided. *) - - val level : section -> level - (** [level section] returns the logging level of [section]. *) - - val set_level : section -> level -> unit - (** [set_level section] sets the logging level of the given - section. Modifications of rules using {!add_rule} won't affect - the level of this section after this operation. *) - - val reset_level : section -> unit - (** [reset_level section] resets the level of [section] to its - default value, i.e. to the value obtained by applying - rules. *) -end - -(** {6 Log templates} *) - -type template = string - (** A template is for generating log messages. - - It is a string which may contains variables of the form - [$(var)], where [var] is one of: - - - [date] which will be replaced with the current date - - [milliseconds] which will be replaced by the fractionnal part - of the current unix time - - [name] which will be replaced by the program name - - [pid] which will be replaced by the pid of the program - - [message] which will be replaced by the message emited - - [level] which will be replaced by a string representation of - the level - - [section] which will be replaced by the name of the - message's section - - [loc-file] which will be replaced by the file name of the - calling logging function - - [loc-line] which will be replaced by the line number of the - calling logging function - - [loc-column] which will be replaced by the column number of - the calling logging function - - For example: - - ["$(name): $(message)"] - - ["$(date) $(name)[$(pid)]: $(message)"] - - ["$(date).$(milliseconds) $(name)[$(pid)]: $(message)"] - - ["$(date): $(loc-file): $(loc-line): $(loc-column): $(message)"] - *) - -val render : buffer : Buffer.t -> template : template -> section : section -> level : level -> message : string -> unit - (** [render ~buffer ~template ~section ~level ~message] instantiate - all variables of [template], and store the result in - [buffer]. The location is obtained from threads local - storage. *) - -val location_key : (string * int * int) Lwt.key - (** The key for storing current location. *) - -(** {6 Loggers} *) - -exception Logger_closed - (** Exception raised when trying to use a closed logger *) - -val make : output : (section -> level -> string list -> unit Lwt.t) -> close : (unit -> unit Lwt.t) -> logger - (** [make ~output ~close] creates a new logger. - - @param output is used to write logs. It is a function which - receive a section, a level and a list lines that must be logged - together. - @param close is used to close the logger. *) - -val close : logger -> unit Lwt.t - (** Close the given logger *) - -val default : logger ref - (** The default logger. It is used as default when no one is - specified. Initially, it sends messages to the standard output - for error messages. *) - -val broadcast : logger list -> logger - (** [broadcast loggers] is a logger which send messages to all the - given loggers. - - Note: closing a broadcast logger does not close its - components. *) - -val dispatch : (section -> level -> logger) -> logger - (** [dispatch f] is a logger which dispatch logging instructions to - different logger according to their level and/or section. - - Here is an example: - - {[ - let access_logger = Lwt_log.file "access.log" - and error_logger = Lwt_log.file "error.log" in - - Lwt_log.dispatch - (fun section level -> - match Lwt_log.Section.name section, level with - | "access", _ -> access_logger - | _, Lwt_log.Error -> error_logger) - ]} - *) - -(** {6 Predefined loggers} *) - -val null : logger - (** Logger which drops everything *) - -(** Syslog facility. Look at the SYSLOG(3) man page for a description - of syslog facilities *) -type syslog_facility = - [ `Auth | `Authpriv | `Cron | `Daemon | `FTP | `Kernel - | `Local0 | `Local1 | `Local2 | `Local3 | `Local4 | `Local5 | `Local6 | `Local7 - | `LPR | `Mail | `News | `Syslog | `User | `UUCP | `NTP | `Security | `Console ] - -val syslog : ?template : template -> ?paths : string list -> facility : syslog_facility -> unit -> logger - (** [syslog ?template ?paths ~facility ()] creates an logger - which send message to the system logger. - - @param paths is a list of path to try for the syslogd socket. It - default to [\["/dev/log"; "/var/run/log"\]]. - @param template defaults to ["$(date) $(name)[$(pid)]: $(section): $(message)"] - *) - -val file : ?template : template -> ?mode : [ `Truncate | `Append ] -> ?perm : Unix.file_perm -> file_name : string -> unit -> logger Lwt.t - (** [desf_file ?template ?mode ?perm ~file_name ()] creates an - logger which will write messages to [file_name]. - - - if [mode = `Truncate] then the file is truncated and previous - contents will be lost. - - - if [mode = `Append], new messages will be appended at the end - of the file - - @param mode defaults to [`Append] - @param template defaults to ["$(date): $(section): $(message)"] - *) - -val channel :?template : template -> close_mode : [ `Close | `Keep ] -> channel : Lwt_io.output_channel -> unit -> logger - (** [channel ?template ~close_mode ~channel ()] creates a logger - from a channel. - - If [close_mode = `Close] then [channel] is closed when the - logger is closed, otherwise it is left open. - - @param template defaults to ["$(name): $(section): $(message)"] *) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mli deleted file mode 100644 index 024e066..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_log_rules - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Logging rules parsing *) - -val rules : Lexing.lexbuf -> (string * string) list - (** [parse lexbuf] returns the list of rules contained in - [lexbuf] *) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mll b/server/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mll deleted file mode 100644 index d5db4fa..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mll +++ /dev/null @@ -1,49 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_log_rules - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -{ - let invalid () = - Printf.eprintf "%s: invalid contents of the LWT_LOG variable\n%!" (Filename.basename Sys.argv.(0)) -} - -let space = [' ' '\t' '\n'] -let pattern = [^ ' ' '\t' '\n']+ -let level = ['a'-'z' 'A'-'Z']+ - -rule rules = parse - | space* (pattern as pattern) space* "->" space* (level as level) - { (pattern, level) :: semi_colon_and_rules lexbuf } - | space* (level as level) - { ("*", level) :: semi_colon_and_rules lexbuf } - | space* eof - { [] } - | "" - { invalid (); [] } - -and semi_colon_and_rules = parse - | space* ";" - { rules lexbuf } - | space* eof - { [] } - | "" - { invalid (); [] } - diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_main.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_main.ml deleted file mode 100644 index fd5a7d7..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_main.ml +++ /dev/null @@ -1,74 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_main - * Copyright (C) 2009-2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt - -let enter_iter_hooks = Lwt_sequence.create () -let leave_iter_hooks = Lwt_sequence.create () -let yielded = Lwt_sequence.create () - -let yield () = - let waiter, wakener = task () in - let node = Lwt_sequence.add_l wakener yielded in - on_cancel waiter (fun () -> Lwt_sequence.remove node); - waiter - -let rec run t = - (* Wakeup paused threads now. *) - Lwt.wakeup_paused (); - match Lwt.poll t with - | Some x -> - x - | None -> - (* Call enter hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) enter_iter_hooks; - (* Do the main loop call. *) - Lwt_engine.iter (Lwt.paused_count () = 0 && Lwt_sequence.is_empty yielded); - (* Wakeup paused threads again. *) - Lwt.wakeup_paused (); - (* Wakeup yielded threads now. *) - if not (Lwt_sequence.is_empty yielded) then begin - let tmp = Lwt_sequence.create () in - Lwt_sequence.transfer_r yielded tmp; - Lwt_sequence.iter_l (fun wakener -> wakeup wakener ()) tmp - end; - (* Call leave hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) leave_iter_hooks; - run t - -let exit_hooks = Lwt_sequence.create () - -let rec call_hooks () = - match Lwt_sequence.take_opt_l exit_hooks with - | None -> - return () - | Some f -> - lwt () = - try_lwt - f () - with exn -> - return () - in - call_hooks () - -let () = at_exit (fun () -> run (call_hooks ())) -let at_exit f = ignore (Lwt_sequence.add_l f exit_hooks) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_main.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_main.mli deleted file mode 100644 index c48e80c..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_main.mli +++ /dev/null @@ -1,61 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_main - * Copyright (C) 2009-2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Main loop and event queue *) - -(** This module controls the ``main-loop'' of Lwt. *) - -val run : 'a Lwt.t -> 'a - (** [run t] calls the Lwt scheduler repeatedly until [t] terminates, - then returns the value returned by the thread. It [t] fails with - an exception, this exception is raised. - - Note that you should avoid using [run] inside threads - - The calling threads will not resume before [run] - returns. - - Successive invocations of [run] are serialized: an - invocation of [run] will not terminate before all - subsequent invocations are terminated. - - Note also that it is not safe to call [run] in a function - registered with [Pervasives.at_exit], use the {!at_exit} - function of this module instead. *) - -val yield : unit -> unit Lwt.t - (** [yield ()] is a threads which suspends itself and then resumes - as soon as possible and terminates. *) - -val enter_iter_hooks : (unit -> unit) Lwt_sequence.t - (** Functions that are called before the main iteration. *) - -val leave_iter_hooks : (unit -> unit) Lwt_sequence.t - (** Functions that are called after the main iteration. *) - -val exit_hooks : (unit -> unit Lwt.t) Lwt_sequence.t - (** Sets of functions executed just before the program exit. - - Notes: - - each hook is called exactly one time - - exceptions raised by hooks are ignored *) - -val at_exit : (unit -> unit Lwt.t) -> unit - (** [at_exit hook] adds hook at the left of [exit_hooks]*) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_process.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_process.ml deleted file mode 100644 index 8c4d42c..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_process.ml +++ /dev/null @@ -1,328 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_process - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt - -type command = string * string array - -let shell cmd = ("/bin/sh", [| "/bin/sh"; "-c"; cmd |]) - -type redirection = - [ `Keep - | `Dev_null - | `Close - | `FD_copy of Unix.file_descr - | `FD_move of Unix.file_descr ] - -(* +-----------------------------------------------------------------+ - | Spawing commands | - +-----------------------------------------------------------------+ *) - -let redirect fd redirection = match redirection with - | `Keep -> - () - | `Dev_null -> - Unix.close fd; - let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR] 0o666 in - if fd <> dev_null then begin - Unix.dup2 dev_null fd; - Unix.close dev_null - end - | `Close -> - Unix.close fd - | `FD_copy fd' -> - Unix.dup2 fd' fd - | `FD_move fd' -> - Unix.dup2 fd' fd; - Unix.close fd' - -let spawn (prog, args) env ?(stdin:redirection=`Keep) ?(stdout:redirection=`Keep) ?(stderr:redirection=`Keep) toclose = - match Lwt_unix.fork() with - | 0 -> - redirect Unix.stdin stdin; - redirect Unix.stdout stdout; - redirect Unix.stderr stderr; - List.iter Unix.close toclose; - begin - try - match env with - | None -> - Unix.execvp prog args - | Some env -> - Unix.execvpe prog args env - with _ -> - (* Prevent hooks from running, otherwise thay may use - notifications and the result would be unspecified. *) - Lwt_sequence.iter_node_l Lwt_sequence.remove Lwt_main.exit_hooks; - exit 127 - end - | id -> - let close = function - | `FD_move fd -> - Unix.close fd - | _ -> - () - in - close stdin; - close stdout; - close stderr; - id - -type state = - | Running - | Exited of Unix.process_status - -let status (pid, status, rusage) = status -let rusage (pid, status, rusage) = rusage - -class virtual common timeout (w : (int * Unix.process_status * Lwt_unix.resource_usage) Lwt.t) pid = - let status = lazy(w >|= status) and rusage = lazy(w >|= rusage) in -object(self) - - method virtual close : Unix.process_status Lwt.t - - method pid = pid - - method state = match Lwt.poll w with - | None -> Running - | Some(pid, status, rusage) -> Exited status - - method kill signum = match Lwt.poll w with - | None -> Unix.kill pid signum - | Some _ -> () - - method status = Lazy.force status - method rusage = Lazy.force rusage - - initializer - match timeout with - | None -> - () - | Some dt -> - Lwt.ignore_result begin - try_lwt - lwt _ = Lwt.pick [Lwt_unix.timeout dt; w] in - return () - with - | Lwt_unix.Timeout -> - (try Unix.kill pid Sys.sigkill with _ -> ()); - (try_lwt self#close >> return () with _ -> return ()) - | _ -> - return () - end -end - -class process_none ?timeout ?env ?stdin ?stdout ?stderr cmd = - let pid = spawn cmd env ?stdin ?stdout ?stderr [] in - let w = Lwt_unix.wait4 [] pid in - let close = lazy(w >|= status) in -object - inherit common timeout w pid - method close = Lazy.force close -end - -class process_in ?timeout ?env ?stdin ?stderr cmd = - let stdout_r, stdout_w = Unix.pipe () in - let pid = spawn cmd env ?stdin ~stdout:(`FD_move stdout_w) ?stderr [stdout_r] in - let stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r - and w = Lwt_unix.wait4 [] pid in - let close = lazy(Lwt_io.close stdout >> w >|= status) in -object - inherit common timeout w pid - method close = Lazy.force close - method stdout = stdout -end - -class process_out ?timeout ?env ?stdout ?stderr cmd = - let stdin_r, stdin_w = Unix.pipe () in - let pid = spawn cmd env ~stdin:(`FD_move stdin_r) ?stdout ?stderr [stdin_w] in - let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w - and w = Lwt_unix.wait4 [] pid in - let close = lazy (Lwt_io.close stdin >> w >|= status) in -object - inherit common timeout w pid - method close = Lazy.force close - method stdin = stdin -end - -class process ?timeout ?env ?stderr cmd = - let stdin_r, stdin_w = Unix.pipe () - and stdout_r, stdout_w = Unix.pipe () in - let pid = spawn cmd env ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ?stderr [stdin_w; stdout_r] in - let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w - and stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r - and w = Lwt_unix.wait4 [] pid in - let close = lazy(Lwt_io.close stdin <&> Lwt_io.close stdout >> w >|= status) in -object - inherit common timeout w pid - method close = Lazy.force close - method stdin = stdin - method stdout = stdout -end - -class process_full ?timeout ?env cmd = - let stdin_r, stdin_w = Unix.pipe () - and stdout_r, stdout_w = Unix.pipe () - and stderr_r, stderr_w = Unix.pipe () in - let pid = spawn cmd env ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ~stderr:(`FD_move stderr_w) [stdin_w; stdout_r; stderr_r] in - let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w - and stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r - and stderr = Lwt_io.of_unix_fd ~mode:Lwt_io.input stderr_r - and w = Lwt_unix.wait4 [] pid in - let close = lazy(join [Lwt_io.close stdin; Lwt_io.close stdout; Lwt_io.close stderr] >> w >|= status) in -object - inherit common timeout w pid - method close = Lazy.force close - method stdin = stdin - method stdout = stdout - method stderr = stderr -end - -let open_process_none ?timeout ?env ?stdin ?stdout ?stderr cmd = new process_none ?timeout ?env ?stdin ?stdout ?stderr cmd -let open_process_in ?timeout ?env ?stdin ?stderr cmd = new process_in ?timeout ?env ?stdin ?stderr cmd -let open_process_out ?timeout ?env ?stdout ?stderr cmd = new process_out ?timeout ?env ?stdout ?stderr cmd -let open_process ?timeout ?env ?stderr cmd = new process ?timeout ?env ?stderr cmd -let open_process_full ?timeout ?env cmd = new process_full ?timeout ?env cmd - -let make_with backend ?timeout ?env cmd f = - let process = backend ?timeout ?env cmd in - try_lwt - f process - finally - lwt _ = process#close in - return () - -let with_process_none ?timeout ?env ?stdin ?stdout ?stderr cmd f = make_with (open_process_none ?stdin ?stdout ?stderr) ?timeout ?env cmd f -let with_process_in ?timeout ?env ?stdin ?stderr cmd f = make_with (open_process_in ?stdin ?stderr) ?timeout ?env cmd f -let with_process_out ?timeout ?env ?stdout ?stderr cmd f = make_with (open_process_out ?stdout ?stderr) ?timeout ?env cmd f -let with_process ?timeout ?env ?stderr cmd f = make_with (open_process ?stderr) ?timeout ?env cmd f -let with_process_full ?timeout ?env cmd f = make_with open_process_full ?timeout ?env cmd f - -(* +-----------------------------------------------------------------+ - | High-level functions | - +-----------------------------------------------------------------+ *) - -let exec ?timeout ?env ?stdin ?stdout ?stderr cmd = (open_process_none ?timeout ?env ?stdin ?stdout ?stderr cmd)#close - -let ingore_close ch = - ignore (Lwt_io.close ch) - -let recv_chars pr = - let ic = pr#stdout in - Gc.finalise ingore_close ic; - Lwt_stream.from (fun _ -> - lwt x = Lwt_io.read_char_opt ic in - if x = None then begin - lwt () = Lwt_io.close ic in - return x - end else - return x) - -let recv_lines pr = - let ic = pr#stdout in - Gc.finalise ingore_close ic; - Lwt_stream.from (fun _ -> - lwt x = Lwt_io.read_line_opt ic in - if x = None then begin - lwt () = Lwt_io.close ic in - return x - end else - return x) - -let recv pr = - let ic = pr#stdout in - try_lwt - Lwt_io.read ic - finally - Lwt_io.close ic >> return () - -let recv_line pr = - let ic = pr#stdout in - try_lwt - Lwt_io.read_line ic - finally - Lwt_io.close ic - -(* Receiving *) - -let pread ?timeout ?env ?stdin ?stderr cmd = - recv (open_process_in ?timeout ?env ?stdin ?stderr cmd) - -let pread_chars ?timeout ?env ?stdin ?stderr cmd = - recv_chars (open_process_in ?timeout ?env ?stdin ?stderr cmd) - -let pread_line ?timeout ?env ?stdin ?stderr cmd = - recv_line (open_process_in ?timeout ?env ?stdin ?stderr cmd) - -let pread_lines ?timeout ?env ?stdin ?stderr cmd = - recv_lines (open_process_in ?timeout ?env ?stdin ?stderr cmd) - -(* Sending *) - -let send f pr data = - let oc = pr#stdin in - try_lwt - f oc data - finally - Lwt_io.close oc - -let pwrite ?timeout ?env ?stdout ?stderr cmd text = - send Lwt_io.write (open_process_out ?timeout ?env ?stdout ?stderr cmd) text - -let pwrite_chars ?timeout ?env ?stdout ?stderr cmd chars = - send Lwt_io.write_chars (open_process_out ?timeout ?env ?stdout ?stderr cmd) chars - -let pwrite_line ?timeout ?env ?stdout ?stderr cmd line = - send Lwt_io.write_line (open_process_out ?timeout ?env ?stdout ?stderr cmd) line - -let pwrite_lines ?timeout ?env ?stdout ?stderr cmd lines = - send Lwt_io.write_lines (open_process_out ?timeout ?env ?stdout ?stderr cmd) lines - -(* Mapping *) - -(* Dump something to a command: *) -let dump f pr data = - let oc = pr#stdin in - ignore_result (try_lwt - f oc data - finally - Lwt_io.close oc) - -let pmap ?timeout ?env ?stderr cmd text = - let pr = open_process ?timeout ?env ?stderr cmd in - dump Lwt_io.write pr text; - recv pr - -let pmap_chars ?timeout ?env ?stderr cmd chars = - let pr = open_process ?timeout ?env ?stderr cmd in - dump Lwt_io.write_chars pr chars; - recv_chars pr - -let pmap_line ?timeout ?env ?stderr cmd line = - let pr = open_process ?timeout ?env ?stderr cmd in - dump Lwt_io.write_line pr line; - recv_line pr - -let pmap_lines ?timeout ?env ?stderr cmd lines = - let pr = open_process ?timeout ?env ?stderr cmd in - dump Lwt_io.write_lines pr lines; - recv_lines pr diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_process.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_process.mli deleted file mode 100644 index 4ee6633..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_process.mli +++ /dev/null @@ -1,296 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.output_channelsigen.org/lwt - * Module Lwt_process - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Process management *) - -(** This modules allow you to spawn processes and communicate with them. *) - -type command = string * string array - (** A command is a program name with a list of arguments *) - -val shell : string -> command - (** A command executed with ["/bin/sh"] *) - -(** All the following functions take an optionnal argument - [timeout]. If specified, after expiration, the process will be - sent a [Unix.sigkill] signal and channels will be closed. *) - -(** {6 High-level functions} *) - -(** {8 Redirections} *) - -(** A file descriptor redirection. It describe how standard file - descriptors are redirected in the child process. *) -type redirection = - [ `Keep - (** The file descriptor is left unchanged *) - | `Dev_null - (** Connect the file descriptor to [/dev/null] *) - | `Close - (** The file descriptor is closed *) - | `FD_copy of Unix.file_descr - (** The file descriptor is replaced by the given - one *) - | `FD_move of Unix.file_descr - (** The file descriptor is replaced by the given one, which is - then closed. *) ] - -(** Note: all optionnal redirection argumetns default to [`Keep] *) - -(** {8 Executing} *) - -val exec : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> Unix.process_status Lwt.t - (** Executes the given command and returns its exit status. *) - -(** {8 Receiving} *) - -val pread : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> string Lwt.t -val pread_chars : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> char Lwt_stream.t -val pread_line : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> string Lwt.t -val pread_lines : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> string Lwt_stream.t - -(** {8 Sending} *) - -val pwrite : - ?timeout : float -> - ?env : string array -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> string -> unit Lwt.t -val pwrite_chars : - ?timeout : float -> - ?env : string array -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> char Lwt_stream.t -> unit Lwt.t -val pwrite_line : - ?timeout : float -> - ?env : string array -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> string -> unit Lwt.t -val pwrite_lines : - ?timeout : float -> - ?env : string array -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> string Lwt_stream.t -> unit Lwt.t - -(** {8 Mapping} *) - -val pmap : - ?timeout : float -> - ?env : string array -> - ?stderr : redirection -> - command -> string -> string Lwt.t -val pmap_chars : - ?timeout : float -> - ?env : string array -> - ?stderr : redirection -> - command -> char Lwt_stream.t -> char Lwt_stream.t -val pmap_line : - ?timeout : float -> - ?env : string array -> - ?stderr : redirection -> - command -> string -> string Lwt.t -val pmap_lines : - ?timeout : float -> - ?env : string array -> - ?stderr : redirection -> - command -> string Lwt_stream.t -> string Lwt_stream.t - -(** {6 Spawning processes} *) - -(** State of a sub-process *) -type state = - | Running - (** The process is still running *) - | Exited of Unix.process_status - (** The process has exited *) - -class process_none : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> -object - method pid : int - (** Pid of the sub-process *) - - method state : state - (** Return the state of the process *) - - method kill : int -> unit - (** [kill signum] sends [signum] to the process if it is still - running *) - - method status : Unix.process_status Lwt.t - (** Threads which wait for the sub-process to exit then returns its - exit status *) - - method rusage : Lwt_unix.resource_usage Lwt.t - (** Threads which wait for the sub-process to exit then returns - its resource usages *) - - method close : Unix.process_status Lwt.t - (** Closes the process and returns its exit status. This close all - channels used to communicate with the process *) -end - -val open_process_none : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> process_none -val with_process_none : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> (process_none -> 'a Lwt.t) -> 'a Lwt.t - -class process_in : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> -object - inherit process_none - - method stdout : Lwt_io.input_channel - (** The standard output of the process *) -end - -val open_process_in : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> process_in -val with_process_in : - ?timeout : float -> - ?env : string array -> - ?stdin : redirection -> - ?stderr : redirection -> - command -> (process_in -> 'a Lwt.t) -> 'a Lwt.t - -class process_out : - ?timeout : float -> - ?env : string array -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> -object - inherit process_none - - method stdin : Lwt_io.output_channel - (** The standard input of the process *) -end - -val open_process_out : - ?timeout : float -> - ?env : string array -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> process_out -val with_process_out : - ?timeout : float -> - ?env : string array -> - ?stdout : redirection -> - ?stderr : redirection -> - command -> (process_out -> 'a Lwt.t) -> 'a Lwt.t - -class process : - ?timeout : float -> - ?env : string array -> - ?stderr : redirection -> - command -> -object - inherit process_none - - method stdin : Lwt_io.output_channel - method stdout : Lwt_io.input_channel -end - -val open_process : - ?timeout : float -> - ?env : string array -> - ?stderr : redirection -> - command -> process -val with_process : - ?timeout : float -> - ?env : string array -> - ?stderr : redirection -> - command -> (process -> 'a Lwt.t) -> 'a Lwt.t - -class process_full : - ?timeout : float -> - ?env : string array -> - command -> -object - inherit process_none - - method stdin : Lwt_io.output_channel - method stdout : Lwt_io.input_channel - method stderr : Lwt_io.input_channel -end - -val open_process_full : - ?timeout : float -> - ?env : string array -> - command -> process_full -val with_process_full : - ?timeout : float -> - ?env : string array -> - command -> (process_full -> 'a Lwt.t) -> 'a Lwt.t diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_sys.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_sys.ml deleted file mode 100644 index 4ce61cd..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_sys.ml +++ /dev/null @@ -1,63 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_sys - * Copyright (C) 2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -#include "src/unix/lwt_config.ml" - -exception Not_available of string - -let () = Callback.register_exception "lwt:not-available" (Not_available "") - -let windows = Sys.os_type <> "Unix" - -type feature = - [ `wait4 - | `get_cpu - | `get_affinity - | `set_affinity - | `recv_msg - | `send_msg - | `fd_passing - | `get_credentials - | `mincore - | `madvise - | `fdatasync - | `libev ] - -let have = function - | `wait4 - | `recv_msg - | `send_msg - | `mincore - | `madvise -> not windows - | `get_cpu -> <:optcomp< HAVE_GETCPU >> - | `get_affinity - | `set_affinity -> <:optcomp< HAVE_AFFINITY >> - | `fd_passing -> <:optcomp< HAVE_FD_PASSING >> - | `get_credentials -> <:optcomp< HAVE_GET_CREDENTIALS >> - | `fdatasync -> <:optcomp< HAVE_FDATASYNC >> - | `libev -> <:optcomp< HAVE_LIBEV >> - -type byte_order = Little_endian | Big_endian - -external get_byte_order : unit -> byte_order = "lwt_unix_system_byte_order" - -let byte_order = get_byte_order () diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_sys.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_sys.mli deleted file mode 100644 index ceebafa..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_sys.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_sys - * Copyright (C) 2011 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** System informations. *) - -exception Not_available of string - (** [Not_available(feature)] is an exception that may be raised when - a feature is not available on the current system. *) - -val windows : bool - (** [true] iff running on windows. *) - -(** Features that can be tested. *) -type feature = - [ `wait4 - | `get_cpu - | `get_affinity - | `set_affinity - | `recv_msg - | `send_msg - | `fd_passing - | `get_credentials - | `mincore - | `madvise - | `fdatasync - | `libev ] - -val have : feature -> bool - (** Test whether the given feature is available on the current - system. *) - -type byte_order = Little_endian | Big_endian - (** Type of byte order *) - -val byte_order : byte_order - (** The byte order used by the computer running the program. *) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.ml deleted file mode 100644 index d3cf42e..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.ml +++ /dev/null @@ -1,133 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_throttle - * Copyright (C) 2008 Stphane Glondu - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt - -module type S = sig - type key - type t - - val create : rate:int -> max:int -> n:int -> t - val wait : t -> key -> bool Lwt.t -end - -let section = Lwt_log.Section.make "Lwt_throttle" - -module Make (H : Hashtbl.HashedType) : (S with type key = H.t) = struct - module MH = Hashtbl.Make(H) - - type key = H.t - type elt = { - mutable consumed : int; - queue : bool Lwt.u Queue.t; - } - - type t = { - rate : int; - max : int; (* maximum number of waiting threads *) - mutable waiting : int; - table : elt MH.t; - mutable cleaning : unit Lwt.t option; - } - - let create ~rate ~max ~n = - if rate < 1 || max < 1 || n < 0 then - invalid_arg "Lwt_throttle.S.create" - else { - rate = rate; - max = max; - waiting = 0; - table = MH.create n; - cleaning = None; - } - - let update_key t key elt (old_waiting,to_run) = - let rec update to_run = function - | 0 -> 0, Queue.length elt.queue, to_run - | i -> - try - let to_run = (Queue.take elt.queue)::to_run in - update to_run (i-1) - with - | Queue.Empty -> i, 0, to_run - in - let not_consumed, waiting, to_run = update to_run t.rate in - let consumed = t.rate - not_consumed in - if consumed = 0 - then - (* there is no waiting threads for this key: we can clean the table *) - MH.remove t.table key - else elt.consumed <- consumed; - (old_waiting+waiting, to_run) - - let rec clean_table t = - let waiting,to_run = MH.fold (update_key t) t.table (0,[]) in - t.waiting <- waiting; - if waiting = 0 && to_run = [] - then - (* the table is empty: we do not need to clean in 1 second *) - t.cleaning <- None - else launch_cleaning t; - List.iter (fun u -> wakeup u true) to_run - - and launch_cleaning t = - t.cleaning <- - let t = - lwt () = Lwt_unix.sleep 1. in - try_lwt - clean_table t; - return (); - with - | exn -> Lwt_log.fatal ~exn ~section "internal error" - in - Some t - - let really_wait t elt = - let w,u = Lwt.task () in - if t.max > t.waiting - then (Queue.add u elt.queue; - t.waiting <- succ t.waiting; - w) - else return false - - let wait t key = - let res = - try - let elt = MH.find t.table key in - if elt.consumed >= t.rate - then really_wait t elt - else (elt.consumed <- succ elt.consumed; - return true) - with - | Not_found -> - let elt = { consumed = 1; - queue = Queue.create () } in - MH.add t.table key elt; - return true - in - (match t.cleaning with - | None -> launch_cleaning t - | Some _ -> ()); - res - -end diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.mli deleted file mode 100644 index 94ad925..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.mli +++ /dev/null @@ -1,47 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_throttle - * Copyright (C) 2008 Stphane Glondu - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Rate limiters *) - -(** This module defines rate limiters. A rate limiter is parametrized - by its limit and a maximum waiting time. The [wait] function will - collaboratively hang for a delay necessary to respect the - limit. If that delay exceeds the maximum waiting time, [wait] - returns [false]; otherwise it returns [true]. *) - -module type S = sig - type key - type t - - val create : rate:int -> max:int -> n:int -> t - (** - @param rate maximum number of connections per second - @param max maximum waiting time (in seconds) - @param n initial size of the hash table - *) - - val wait : t -> key -> bool Lwt.t - (** @return [false] if maximum reached, [true] else *) -end - -module Make (H : Hashtbl.HashedType) : S with type key = H.t diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.ml deleted file mode 100644 index 7baa2e0..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.ml +++ /dev/null @@ -1,127 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_timeout - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -let section = Lwt_log.Section.make "lwt(timeout)" - -type t = - { mutable delay : int; action : unit -> unit; - mutable prev : t; mutable next : t } - -let make delay action = - let rec x = { delay = delay; action = action; prev = x; next = x } in - x - -let lst_empty () = make (-1) (fun () -> ()) - -let lst_remove x = - let p = x.prev in - let n = x.next in - p.next <- n; - n.prev <- p; - x.next <- x; - x.prev <- x - -let lst_insert p x = - let n = p.next in - p.next <- x; - x.prev <- p; - x.next <- n; - n.prev <- x - -let lst_in_list x = x.next != x - -let lst_is_empty set = set.next == set - -let lst_peek s = let x = s.next in lst_remove x; x - -(****) - -let count = ref 0 - -let buckets = ref [||] - -let curr = ref 0 - -let stopped = ref true - -let size l = - let len = Array.length !buckets in - if l >= len then begin - let b = Array.init (l + 1) (fun _ -> lst_empty ()) in - Array.blit !buckets !curr b 0 (len - !curr); - Array.blit !buckets 0 b (len - !curr) !curr; - buckets := b; curr := 0; - end - -(****) - -let handle_exn = - ref - (fun exn -> - ignore (Lwt_log.error ~section ~exn "uncaught exception after timeout"); - exit 1) - -let set_exn_handler f = handle_exn := f - -let rec loop () = - stopped := false; - Lwt.bind (Lwt_unix.sleep 1.) (fun () -> - let s = !buckets.(!curr) in - while not (lst_is_empty s) do - let x = lst_peek s in - decr count; -(*XXX Should probably report any exception *) - try - x.action () - with e -> !handle_exn e - done; - curr := (!curr + 1) mod (Array.length !buckets); - if !count > 0 then loop () else begin stopped := true; Lwt.return () end) - -let start x = - let in_list = lst_in_list x in - let slot = (!curr + x.delay) mod (Array.length !buckets) in - lst_remove x; - lst_insert !buckets.(slot) x; - if not in_list then begin - incr count; - if !count = 1 && !stopped then ignore (loop ()) - end - -let create delay action = - if delay < 1 then invalid_arg "Lwt_timeout.create"; - let x = make delay action in - size delay; - x - -let stop x = - if lst_in_list x then begin - lst_remove x; - decr count - end - -let change x delay = - if delay < 1 then invalid_arg "Lwt_timeout.change"; - x.delay <- delay; - size delay; - if lst_in_list x then start x diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.mli deleted file mode 100644 index 314fe17..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.mli +++ /dev/null @@ -1,47 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_timeout - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Timeouts *) - -type t - -val set_exn_handler : (exn -> unit) -> unit -(** set the default handler for exception occurring after a timeout. - The function lauched after a timeout should not raise any exception. - That's why the default handler will exit the program. -*) - -val create : int -> (unit -> unit) -> t -(** [create n f] defines a new timeout with [n] seconds duration. [f] is - the function to be called after the timeout. - That function must not raise any exception. -*) - -val start : t -> unit -(** starts a timeout. *) - -val stop : t -> unit -(** stops a timeout. *) - -val change : t -> int -> unit -(** changes the duration of a timeout. *) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix.h b/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix.h deleted file mode 100644 index 995dcbb..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix.h +++ /dev/null @@ -1,218 +0,0 @@ -/* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Header lwt_unix - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - */ - -#ifndef __LWT_UNIX_H -#define __LWT_UNIX_H - -#include -#include - -/* Detect the target OS */ -#if defined(_WIN32) || defined(_WIN64) -# define LWT_ON_WINDOWS -#endif - -/* The macro to get the file-descriptor from a value. */ -#if defined(LWT_ON_WINDOWS) -# define FD_val(value) win_CRT_fd_of_filedescr(value) -#else -# define FD_val(value) Int_val(value) -#endif - -/* Macro to extract a libev loop from a caml value. */ -#define Ev_loop_val(value) *(struct ev_loop**)Data_custom_val(value) - -/* +-----------------------------------------------------------------+ - | Utils | - +-----------------------------------------------------------------+ */ - -/* Allocate the given amount of memory and abort the program if there - is no free memory left. */ -void *lwt_unix_malloc(size_t size); - -/* Same as [strdup] and abort hte program if there is not memory - left. */ -char *lwt_unix_strdup(char *string); - -/* Helper for allocating structures. */ -#define lwt_unix_new(type) (type*)lwt_unix_malloc(sizeof(type)) - -/* Raise [Lwt_unix.Not_available]. */ -void lwt_unix_not_available(char const *feature) Noreturn; - -/* +-----------------------------------------------------------------+ - | Notifications | - +-----------------------------------------------------------------+ */ - -/* Sends a notification for the given id. */ -void lwt_unix_send_notification(int id); - -/* +-----------------------------------------------------------------+ - | Threading | - +-----------------------------------------------------------------+ */ - -#if defined(LWT_ON_WINDOWS) - -typedef DWORD lwt_unix_thread; -typedef CRITICAL_SECTION lwt_unix_mutex; -typedef struct lwt_unix_condition lwt_unix_condition; - -#else - -#include - -typedef pthread_t lwt_unix_thread; -typedef pthread_mutex_t lwt_unix_mutex; -typedef pthread_cond_t lwt_unix_condition; - -#endif - -/* Launch a thread in detached mode. */ -void lwt_unix_launch_thread(void* (*start)(void*), void* data); - -/* Return a handle to the currently running thread. */ -lwt_unix_thread lwt_unix_thread_self(); - -/* Returns whether two thread handles refer to the same thread. */ -int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2); - -/* Initialises a mutex. */ -void lwt_unix_mutex_init(lwt_unix_mutex *mutex); - -/* Destroy a mutex. */ -void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex); - -/* Lock a mutex. */ -void lwt_unix_mutex_lock(lwt_unix_mutex *mutex); - -/* Unlock a mutex. */ -void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex); - -/* Initialises a condition variable. */ -void lwt_unix_condition_init(lwt_unix_condition *condition); - -/* Destroy a condition variable. */ -void lwt_unix_condition_destroy(lwt_unix_condition *condition); - -/* Signal a condition variable. */ -void lwt_unix_condition_signal(lwt_unix_condition *condition); - -/* Broadcast a signal on a condition variable. */ -void lwt_unix_condition_broadcast(lwt_unix_condition *condition); - -/* Wait for a signal on a condition variable. */ -void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex); - -/* +-----------------------------------------------------------------+ - | Detached jobs | - +-----------------------------------------------------------------+ */ - -/* How job are executed. */ -enum lwt_unix_async_method { - /* Synchronously. */ - LWT_UNIX_ASYNC_METHOD_NONE = 0, - - /* Asynchronously, on another thread. */ - LWT_UNIX_ASYNC_METHOD_DETACH = 1, - - /* Asynchronously, on the main thread, switcing to another thread if - necessary. */ - LWT_UNIX_ASYNC_METHOD_SWITCH = 2 -}; - -/* Type of job execution modes. */ -typedef enum lwt_unix_async_method lwt_unix_async_method; - -/* State of a job. */ -enum lwt_unix_job_state { - /* The job has not yet started. */ - LWT_UNIX_JOB_STATE_PENDING, - - /* The job is running. */ - LWT_UNIX_JOB_STATE_RUNNING, - - /* The job is done. */ - LWT_UNIX_JOB_STATE_DONE, - - /* The job has been canceled. */ - LWT_UNIX_JOB_STATE_CANCELED -}; - -/* A job descriptor. */ -struct lwt_unix_job { - /* The next job in the queue. */ - struct lwt_unix_job *next; - - /* Id used to notify the main thread in case the job do not - terminate immediatly. */ - int notification_id; - - /* The function to call to do the work. */ - void (*worker)(struct lwt_unix_job *job); - - /* State of the job. */ - enum lwt_unix_job_state state; - - /* Is the main thread still waiting for the job ? */ - int fast; - - /* Mutex to protect access to [state] and [fast]. */ - lwt_unix_mutex mutex; - - /* Thread running the job. */ - lwt_unix_thread thread; - - /* The async method in used by the job. */ - lwt_unix_async_method async_method; -}; - -/* Type of job descriptors. */ -typedef struct lwt_unix_job* lwt_unix_job; - -/* Type of worker functions. */ -typedef void (*lwt_unix_job_worker)(lwt_unix_job job); - -/* Allocate a caml custom value for the given job. */ -value lwt_unix_alloc_job(lwt_unix_job job); - -/* Free resourecs allocated for this job and free it. */ -void lwt_unix_free_job(lwt_unix_job job); - -/* Define not implement methods. */ -#define LWT_UNIX_JOB_NOT_IMPLEMENTED(name) \ - CAMLprim value lwt_unix_##name##_job() \ - { \ - caml_invalid_argument("not implemented"); \ - } \ - \ - CAMLprim value lwt_unix_##name##_result() \ - { \ - caml_invalid_argument("not implemented"); \ - } \ - \ - CAMLprim value lwt_unix_##name##_free() \ - { \ - caml_invalid_argument("not implemented"); \ - } - - -#endif /* __LWT_UNIX_H */ diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix.ml b/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix.ml deleted file mode 100644 index 7acc69c..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix.ml +++ /dev/null @@ -1,2681 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_unix - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * 2009 Jrmie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -#include "src/unix/lwt_config.ml" - -open Lwt - -(* +-----------------------------------------------------------------+ - | Configuration | - +-----------------------------------------------------------------+ *) - -type async_method = - | Async_none - | Async_detach - | Async_switch - -let default_async_method_var = ref Async_detach - -let () = - try - match Sys.getenv "LWT_ASYNC_METHOD" with - | "none" -> - default_async_method_var := Async_none - | "detach" -> - default_async_method_var := Async_detach - | "switch" -> - default_async_method_var := Async_switch - | str -> - Printf.eprintf - "%s: invalid lwt async method: '%s', must be 'none', 'detach' or 'switch'\n%!" - (Filename.basename Sys.executable_name) str - with Not_found -> - () - -let default_async_method () = !default_async_method_var -let set_default_async_method am = default_async_method_var := am - -let async_method_key = Lwt.new_key () - -let async_method () = - match Lwt.get async_method_key with - | Some am -> am - | None -> !default_async_method_var - -let with_async_none f = - with_value async_method_key (Some Async_none) f - -let with_async_detach f = - with_value async_method_key (Some Async_detach) f - -let with_async_switch f = - with_value async_method_key (Some Async_switch) f - -(* +-----------------------------------------------------------------+ - | Notifications management | - +-----------------------------------------------------------------+ *) - -(* Informations about a notifier *) -type notifier = { - notify_handler : unit -> unit; - (* The callback *) - - notify_once : bool; - (* Whether to remove the notifier after the reception of the first - notification *) -} - -module Notifiers = Hashtbl.Make(struct - type t = int - let equal (x : int) (y : int) = x = y - let hash (x : int) = x - end) - -let notifiers = Notifiers.create 1024 - -let current_notification_id = ref 0 - -let rec find_free_id id = - if Notifiers.mem notifiers id then - find_free_id (id + 1) - else - id - -let make_notification ?(once=false) f = - let id = find_free_id (!current_notification_id + 1) in - current_notification_id := id; - Notifiers.add notifiers id { notify_once = once; notify_handler = f }; - id - -let stop_notification id = - Notifiers.remove notifiers id - -let set_notification id f = - let notifier = Notifiers.find notifiers id in - Notifiers.replace notifiers id { notifier with notify_handler = f } - -(* +-----------------------------------------------------------------+ - | Sleepers | - +-----------------------------------------------------------------+ *) - -let sleep delay = - let waiter, wakener = Lwt.task () in - let ev = Lwt_engine.on_timer delay false (fun ev -> Lwt_engine.stop_event ev; Lwt.wakeup wakener ()) in - Lwt.on_cancel waiter (fun () -> Lwt_engine.stop_event ev); - waiter - -let yield = Lwt_main.yield - -let auto_yield timeout = - let limit = ref (Unix.gettimeofday () +. timeout) in - fun () -> - let current = Unix.gettimeofday () in - if current >= !limit then begin - limit := current +. timeout; - yield (); - end else - return () - -exception Timeout - -let timeout d = sleep d >> Lwt.fail Timeout - -let with_timeout d f = Lwt.pick [timeout d; Lwt.apply f ()] - -(* +-----------------------------------------------------------------+ - | Jobs | - +-----------------------------------------------------------------+ *) - -type 'a job - -external start_job : 'a job -> async_method -> bool = "lwt_unix_start_job" - (* Starts the given job with given parameters. It returns [true] - if the job is already terminated. *) - -external check_job : 'a job -> int -> bool = "lwt_unix_check_job" "noalloc" - (* Check whether that a job has terminated or not. If it has not - yet terminated, it is marked so it will send a notification - when it finishes. *) - -external cancel_job : 'a job -> unit = "lwt_unix_cancel_job" "noalloc" - (* Cancel the thread of the given job. *) - -(* All running jobs. *) -let jobs = Lwt_sequence.create () - -(* Cancel all running jobs. *) -let rec cancel_jobs () = - match Lwt_sequence.take_opt_l jobs with - | Some w -> cancel w; cancel_jobs () - | None -> () - -let wait_for_jobs () = - join (Lwt_sequence.fold_l (fun w l -> w :: l) jobs []) - -let execute_job ?async_method ~job ~result ~free = - let async_method = - match async_method with - | Some am -> am - | None -> - match Lwt.get async_method_key with - | Some am -> am - | None -> !default_async_method_var - in - (* Starts the job. *) - let job_done = start_job job async_method in - let w = - lwt status = - if job_done then - return None - else - (* Create the notification for asynchronous wakeup. *) - let id = make_notification ~once:true ignore in - try_lwt - (* Give some time to the job before we fallback to - asynchronous notification. *) - lwt () = pause () in - if check_job job id then begin - stop_notification id; - return None - end else - return (Some id) - with Canceled as exn -> - cancel_job job; - (* Free resources when the job terminates. *) - if check_job job id then begin - stop_notification id; - free job - end else - set_notification id (fun () -> free job); - raise_lwt exn - in - match status with - | None -> - (* The job has already terminated, read and return the result - immediatly. *) - let thread = - try - return (result job) - with exn -> - fail exn - in - free job; - thread - | Some id -> - (* The job has not terminated, setup the notification for the - asynchronous wakeup. *) - let waiter, wakener = task () in - set_notification id - (fun () -> - begin - try - wakeup wakener (result job); - with exn -> - wakeup_exn wakener exn - end; - free job); - on_cancel waiter - (fun () -> - cancel_job job; - set_notification id (fun () -> free job)); - waiter - in - if state w = Sleep then begin - (* Add the job to the sequence of all jobs. *) - let node = Lwt_sequence.add_l (w >> return ()) jobs in - (* Remove it on termination. *) - on_termination w (fun () -> Lwt_sequence.remove node) - end; - w - -(* +-----------------------------------------------------------------+ - | File descriptor wrappers | - +-----------------------------------------------------------------+ *) - -type state = Opened | Closed | Aborted of exn - -type file_descr = { - fd : Unix.file_descr; - (* The underlying unix file descriptor *) - - mutable state: state; - (* The state of the file descriptor *) - - mutable set_flags : bool; - (* Whether to set file flags *) - - mutable blocking : bool Lwt.t Lazy.t; - (* Is the file descriptor in blocking or non-blocking mode *) - - mutable event_readable : Lwt_engine.event option; - (* The event used to check the file descriptor for readability. *) - - mutable event_writable : Lwt_engine.event option; - (* The event used to check the file descriptor for writability. *) - - hooks_readable : (unit -> unit) Lwt_sequence.t; - (* Hooks to call when the file descriptor becomes readable. *) - - hooks_writable : (unit -> unit) Lwt_sequence.t; - (* Hooks to call when the file descriptor becomes writable. *) -} - -#if windows - -external is_socket : Unix.file_descr -> bool = "lwt_unix_is_socket" "noalloc" - -let is_blocking ?blocking ?(set_flags=true) fd = - if is_socket fd then - match blocking, set_flags with - | Some state, false -> - lazy(return state) - | Some true, true -> - Unix.clear_nonblock fd; - lazy(return true) - | Some false, true -> - Unix.set_nonblock fd; - lazy(return false) - | None, false -> - lazy(return false) - | None, true -> - Unix.set_nonblock fd; - lazy(return false) - else - match blocking with - | Some state -> - lazy(return state) - | None -> - lazy(return true) - -#else - -external guess_blocking_job : Unix.file_descr -> [ `unix_guess_blocking ] job = "lwt_unix_guess_blocking_job" -external guess_blocking_result : [ `unix_guess_blocking ] job -> bool = "lwt_unix_guess_blocking_result" "noalloc" -external guess_blocking_free : [ `unix_guess_blocking ] job -> unit = "lwt_unix_guess_blocking_free" "noalloc" - -let guess_blocking fd = - execute_job (guess_blocking_job fd) guess_blocking_result guess_blocking_free - -let is_blocking ?blocking ?(set_flags=true) fd = - match blocking, set_flags with - | Some state, false -> - lazy(return state) - | Some true, true -> - Unix.clear_nonblock fd; - lazy(return true) - | Some false, true -> - Unix.set_nonblock fd; - lazy(return false) - | None, false -> - lazy(guess_blocking fd) - | None, true -> - lazy(guess_blocking fd >>= function - | true -> - Unix.clear_nonblock fd; - return true - | false -> - Unix.set_nonblock fd; - return false) - -#endif - -let mk_ch ?blocking ?(set_flags=true) fd = { - fd = fd; - state = Opened; - set_flags = set_flags; - blocking = is_blocking ?blocking ~set_flags fd; - event_readable = None; - event_writable = None; - hooks_readable = Lwt_sequence.create (); - hooks_writable = Lwt_sequence.create (); -} - -let rec check_descriptor ch = - match ch.state with - | Opened -> - () - | Aborted e -> - raise e - | Closed -> - raise (Unix.Unix_error (Unix.EBADF, "check_descriptor", "")) - -let state ch = ch.state - -let blocking ch = - check_descriptor ch; - Lazy.force ch.blocking - -let set_blocking ?(set_flags=true) ch blocking = - check_descriptor ch; - ch.set_flags <- set_flags; - ch.blocking <- is_blocking ~blocking ~set_flags ch.fd - -#if windows - -let stub_readable fd = Unix.select [fd] [] [] (-1.0) <> ([], [], []) -let stub_writable fd = Unix.select [] [fd] [] (-1.0) <> ([], [], []) - -#else - -external stub_readable : Unix.file_descr -> bool = "lwt_unix_readable" -external stub_writable : Unix.file_descr -> bool = "lwt_unix_writable" - -#endif - -let readable ch = - check_descriptor ch; - stub_readable ch.fd - -let writable ch = - check_descriptor ch; - stub_writable ch.fd - -let set_state ch st = - ch.state <- st - -let clear_events ch = - Lwt_sequence.iter_node_l (fun node -> Lwt_sequence.remove node; Lwt_sequence.get node ()) ch.hooks_readable; - Lwt_sequence.iter_node_l (fun node -> Lwt_sequence.remove node; Lwt_sequence.get node ()) ch.hooks_writable; - begin - match ch.event_readable with - | Some ev -> - ch.event_readable <- None; - Lwt_engine.stop_event ev - | None -> - () - end; - begin - match ch.event_writable with - | Some ev -> - ch.event_writable <- None; - Lwt_engine.stop_event ev - | None -> - () - end - -let abort ch e = - if ch.state <> Closed then begin - set_state ch (Aborted e); - clear_events ch - end - -let unix_file_descr ch = ch.fd - -let of_unix_file_descr = mk_ch - -let stdin = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stdin -let stdout = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stdout -let stderr = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stderr - -(* +-----------------------------------------------------------------+ - | Actions on file descriptors | - +-----------------------------------------------------------------+ *) - -type io_event = Read | Write - -exception Retry -exception Retry_write -exception Retry_read - -type 'a outcome = - | Success of 'a - | Exn of exn - | Requeued of io_event - -(* Wait a bit, then stop events that are no more used. *) -let stop_events ch = - on_success - (pause ()) - (fun () -> - if Lwt_sequence.is_empty ch.hooks_readable then begin - match ch.event_readable with - | Some ev -> - ch.event_readable <- None; - Lwt_engine.stop_event ev - | None -> - () - end; - if Lwt_sequence.is_empty ch.hooks_writable then begin - match ch.event_writable with - | Some ev -> - ch.event_writable <- None; - Lwt_engine.stop_event ev - | None -> - () - end) - -let register_readable ch = - if ch.event_readable = None then - ch.event_readable <- Some(Lwt_engine.on_readable ch.fd (fun _ -> Lwt_sequence.iter_l (fun f -> f ()) ch.hooks_readable)) - -let register_writable ch = - if ch.event_writable = None then - ch.event_writable <- Some(Lwt_engine.on_writable ch.fd (fun _ -> Lwt_sequence.iter_l (fun f -> f ()) ch.hooks_writable)) - -(* Retry a queued syscall, [wakener] is the thread to wakeup if the - action succeeds: *) -let rec retry_syscall node event ch wakener action = - let res = - try - check_descriptor ch; - Success(action ()) - with - | Retry - | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) - | Sys_blocked_io -> - (* EINTR because we are catching SIG_CHLD hence the system - call might be interrupted to handle the signal; this lets - us restart the system call eventually. *) - Requeued event - | Retry_read -> - Requeued Read - | Retry_write -> - Requeued Write - | e -> - Exn e - in - match res with - | Success v -> - Lwt_sequence.remove !node; - stop_events ch; - Lwt.wakeup wakener v - | Exn e -> - Lwt_sequence.remove !node; - stop_events ch; - Lwt.wakeup_exn wakener e - | Requeued event' -> - if event <> event' then begin - Lwt_sequence.remove !node; - stop_events ch; - match event' with - | Read -> - node := Lwt_sequence.add_r (fun () -> retry_syscall node Read ch wakener action) ch.hooks_readable ; - register_readable ch - | Write -> - node := Lwt_sequence.add_r (fun () -> retry_syscall node Write ch wakener action) ch.hooks_writable; - register_writable ch - end - -let dummy = Lwt_sequence.add_r ignore (Lwt_sequence.create ()) - -let register_action event ch action = - let waiter, wakener = Lwt.task () in - match event with - | Read -> - let node = ref dummy in - node := Lwt_sequence.add_r (fun () -> retry_syscall node Read ch wakener action) ch.hooks_readable; - on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); - register_readable ch; - waiter - | Write -> - let node = ref dummy in - node := Lwt_sequence.add_r (fun () -> retry_syscall node Write ch wakener action) ch.hooks_writable; - on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); - register_writable ch; - waiter - -(* Wraps a system call *) -let wrap_syscall event ch action = - try - check_descriptor ch; - lwt blocking = Lazy.force ch.blocking in - if not blocking || (event = Read && stub_readable ch.fd) || (event = Write && stub_writable ch.fd) then - return (action ()) - else - register_action event ch action - with - | Retry - | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) - | Sys_blocked_io -> - (* The action could not be completed immediatly, register it: *) - register_action event ch action - | Retry_read -> - register_action Read ch action - | Retry_write -> - register_action Write ch action - | e -> - raise_lwt e - -(* +-----------------------------------------------------------------+ - | Basic file input/output | - +-----------------------------------------------------------------+ *) - -type open_flag = - Unix.open_flag = - | O_RDONLY - | O_WRONLY - | O_RDWR - | O_NONBLOCK - | O_APPEND - | O_CREAT - | O_TRUNC - | O_EXCL - | O_NOCTTY - | O_DSYNC - | O_SYNC - | O_RSYNC - -#if windows - -let openfile name flags perms = - return (of_unix_file_descr (Unix.openfile name flags perms)) - -#else - -external open_job : string -> Unix.open_flag list -> int -> [ `unix_open ] job = "lwt_unix_open_job" -external open_result : [ `unix_open ] job -> Unix.file_descr * bool = "lwt_unix_open_result" -external open_free : [ `unix_open ] job -> unit = "lwt_unix_open_free" "noalloc" - -let openfile name flags perms = - lwt fd, blocking = - execute_job - (open_job name flags perms) - open_result - open_free - in - return (of_unix_file_descr ~blocking fd) - -#endif - -#if windows - -let close ch = - if ch.state = Closed then check_descriptor ch; - set_state ch Closed; - clear_events ch; - return (Unix.close ch.fd) - -#else - -external close_job : Unix.file_descr -> [ `unix_close ] job = "lwt_unix_close_job" -external close_result : [ `unix_close ] job -> unit = "lwt_unix_close_result" -external close_free : [ `unix_close ] job -> unit = "lwt_unix_close_free" "noalloc" - -let close ch = - if ch.state = Closed then check_descriptor ch; - set_state ch Closed; - clear_events ch; - execute_job (close_job ch.fd) close_result close_free - -#endif - -let wait_read ch = - try_lwt - if readable ch then - return () - else - register_action Read ch ignore - -external stub_read : Unix.file_descr -> string -> int -> int -> int = "lwt_unix_read" -external read_job : Unix.file_descr -> int -> [ `unix_read ] job = "lwt_unix_read_job" -external read_result : [ `unix_read ] job -> string -> int -> int = "lwt_unix_read_result" -external read_free : [ `unix_read ] job -> unit = "lwt_unix_read_free" "noalloc" - -let read ch buf pos len = - if pos < 0 || len < 0 || pos > String.length buf - len then - invalid_arg "Lwt_unix.read" - else - Lazy.force ch.blocking >>= function - | true -> - lwt () = wait_read ch in - execute_job (read_job ch.fd len) (fun job -> read_result job buf pos) read_free - | false -> - wrap_syscall Read ch (fun () -> stub_read ch.fd buf pos len) - -let wait_write ch = - try_lwt - if writable ch then - return () - else - register_action Write ch ignore - -external stub_write : Unix.file_descr -> string -> int -> int -> int = "lwt_unix_write" -external write_job : Unix.file_descr -> string -> int -> int -> [ `unix_write ] job = "lwt_unix_write_job" -external write_result : [ `unix_write ] job -> int = "lwt_unix_write_result" -external write_free : [ `unix_write ] job -> unit = "lwt_unix_write_free" "noalloc" - -let write ch buf pos len = - if pos < 0 || len < 0 || pos > String.length buf - len then - invalid_arg "Lwt_unix.write" - else - Lazy.force ch.blocking >>= function - | true -> - lwt () = wait_write ch in - execute_job (write_job ch.fd buf pos len) write_result write_free - | false -> - wrap_syscall Write ch (fun () -> stub_write ch.fd buf pos len) - -(* +-----------------------------------------------------------------+ - | Seeking and truncating | - +-----------------------------------------------------------------+ *) - -type seek_command = - Unix.seek_command = - | SEEK_SET - | SEEK_CUR - | SEEK_END - -#if windows - -let lseek ch offset whence = - check_descriptor ch; - return (Unix.lseek ch.fd offset whence) - -#else - -external lseek_job : Unix.file_descr -> int -> Unix.seek_command -> [ `unix_lseek ] job = "lwt_unix_lseek_job" -external lseek_result : [ `unix_lseek ] job -> int = "lwt_unix_lseek_result" -external lseek_free : [ `unix_lseek ] job -> unit = "lwt_unix_lseek_free" - -let lseek ch offset whence = - check_descriptor ch; - execute_job (lseek_job ch.fd offset whence) lseek_result lseek_free - -#endif - -#if windows - -let truncate name offset = - return (Unix.truncate name offset) - -#else - -external truncate_job : string -> int -> [ `unix_truncate ] job = "lwt_unix_truncate_job" -external truncate_result : [ `unix_truncate ] job -> unit = "lwt_unix_truncate_result" -external truncate_free : [ `unix_truncate ] job -> unit = "lwt_unix_truncate_free" - -let truncate name offset = - execute_job (truncate_job name offset) truncate_result truncate_free - -#endif - -#if windows - -let ftruncate ch offset = - check_descriptor ch; - return (Unix.ftruncate ch.fd offset) - -#else - -external ftruncate_job : Unix.file_descr -> int -> [ `unix_ftruncate ] job = "lwt_unix_ftruncate_job" -external ftruncate_result : [ `unix_ftruncate ] job -> unit = "lwt_unix_ftruncate_result" -external ftruncate_free : [ `unix_ftruncate ] job -> unit = "lwt_unix_ftruncate_free" - -let ftruncate ch offset = - check_descriptor ch; - execute_job (ftruncate_job ch.fd offset) ftruncate_result ftruncate_free - -#endif - -(* +-----------------------------------------------------------------+ - | Syncing | - +-----------------------------------------------------------------+ *) - -external fsync_job : Unix.file_descr -> [ `unix_fsync ] job = "lwt_unix_fsync_job" -external fsync_result : [ `unix_fsync ] job -> unit = "lwt_unix_fsync_result" -external fsync_free : [ `unix_fsync ] job -> unit = "lwt_unix_fsync_free" - -let fsync ch = - check_descriptor ch; - execute_job (fsync_job ch.fd) fsync_result fsync_free - -#if HAVE_FDATASYNC - -external fdatasync_job : Unix.file_descr -> [ `unix_fdatasync ] job = "lwt_unix_fdatasync_job" -external fdatasync_result : [ `unix_fdatasync ] job -> unit = "lwt_unix_fdatasync_result" -external fdatasync_free : [ `unix_fdatasync ] job -> unit = "lwt_unix_fdatasync_free" - -let fdatasync ch = - check_descriptor ch; - execute_job (fdatasync_job ch.fd) fdatasync_result fdatasync_free - -#else - -let fdatasync ch = - fail (Lwt_sys.Not_available "fdatasync") - -#endif - -(* +-----------------------------------------------------------------+ - | File status | - +-----------------------------------------------------------------+ *) - -type file_perm = Unix.file_perm - -type file_kind = - Unix.file_kind = - | S_REG - | S_DIR - | S_CHR - | S_BLK - | S_LNK - | S_FIFO - | S_SOCK - -type stats = - Unix.stats = - { - st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int; - st_atime : float; - st_mtime : float; - st_ctime : float; - } - -#if windows - -let stat name = - return (Unix.stat name) - -#else - -external stat_job : string -> [ `unix_stat ] job = "lwt_unix_stat_job" -external stat_result : [ `unix_stat ] job -> Unix.stats = "lwt_unix_stat_result" -external stat_free : [ `unix_stat ] job -> unit = "lwt_unix_stat_free" - -let stat name = - execute_job (stat_job name) stat_result stat_free - -#endif - -#if windows - -let lstat name = - return (Unix.lstat name) - -#else - -external lstat_job : string -> [ `unix_lstat ] job = "lwt_unix_lstat_job" -external lstat_result : [ `unix_lstat ] job -> Unix.stats = "lwt_unix_lstat_result" -external lstat_free : [ `unix_lstat ] job -> unit = "lwt_unix_lstat_free" - -let lstat name = - execute_job (lstat_job name) lstat_result lstat_free - -#endif - -#if windows - -let fstat ch = - check_descriptor ch; - return (Unix.fstat ch.fd) - -#else - -external fstat_job : Unix.file_descr -> [ `unix_fstat ] job = "lwt_unix_fstat_job" -external fstat_result : [ `unix_fstat ] job -> Unix.stats = "lwt_unix_fstat_result" -external fstat_free : [ `unix_fstat ] job -> unit = "lwt_unix_fstat_free" - -let fstat ch = - check_descriptor ch; - execute_job (fstat_job ch.fd) fstat_result fstat_free - -#endif - -#if windows - -let isatty ch = - check_descriptor ch; - return (Unix.isatty ch.fd) - -#else - -external isatty_job : Unix.file_descr -> [ `unix_isatty ] job = "lwt_unix_isatty_job" -external isatty_result : [ `unix_isatty ] job -> bool = "lwt_unix_isatty_result" -external isatty_free : [ `unix_isatty ] job -> unit = "lwt_unix_isatty_free" - -let isatty ch = - check_descriptor ch; - execute_job (isatty_job ch.fd) isatty_result isatty_free - -#endif - -(* +-----------------------------------------------------------------+ - | File operations on large files | - +-----------------------------------------------------------------+ *) - -module LargeFile = -struct - - type stats = - Unix.LargeFile.stats = - { - st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int64; - st_atime : float; - st_mtime : float; - st_ctime : float; - } - -#if windows - - let lseek ch offset whence = - check_descriptor ch; - return (Unix.LargeFile.lseek ch.fd offset whence) - -#else - - external lseek_job : Unix.file_descr -> int64 -> Unix.seek_command -> [ `unix_lseek ] job = "lwt_unix_lseek_64_job" - external lseek_result : [ `unix_lseek ] job -> int64 = "lwt_unix_lseek_64_result" - external lseek_free : [ `unix_lseek ] job -> unit = "lwt_unix_lseek_64_free" - - let lseek ch offset whence = - check_descriptor ch; - execute_job (lseek_job ch.fd offset whence) lseek_result lseek_free - -#endif - -#if windows - - let truncate name offset = - return (Unix.LargeFile.truncate name offset) - -#else - - external truncate_job : string -> int64 -> [ `unix_truncate ] job = "lwt_unix_truncate_64_job" - external truncate_result : [ `unix_truncate ] job -> unit = "lwt_unix_truncate_64_result" - external truncate_free : [ `unix_truncate ] job -> unit = "lwt_unix_truncate_64_free" - - let truncate name offset = - execute_job (truncate_job name offset) truncate_result truncate_free - -#endif - -#if windows - - let ftruncate ch offset = - check_descriptor ch; - return (Unix.LargeFile.ftruncate ch.fd offset) - -#else - - external ftruncate_job : Unix.file_descr -> int64 -> [ `unix_ftruncate ] job = "lwt_unix_ftruncate_64_job" - external ftruncate_result : [ `unix_ftruncate ] job -> unit = "lwt_unix_ftruncate_64_result" - external ftruncate_free : [ `unix_ftruncate ] job -> unit = "lwt_unix_ftruncate_64_free" - - let ftruncate ch offset = - check_descriptor ch; - execute_job (ftruncate_job ch.fd offset) ftruncate_result ftruncate_free - -#endif - -#if windows - - let stat name = - return (Unix.LargeFile.stat name) - -#else - - external stat_job : string -> [ `unix_stat ] job = "lwt_unix_stat_64_job" - external stat_result : [ `unix_stat ] job -> Unix.LargeFile.stats = "lwt_unix_stat_64_result" - external stat_free : [ `unix_stat ] job -> unit = "lwt_unix_stat_64_free" - - let stat name = - execute_job (stat_job name) stat_result stat_free - -#endif - -#if windows - - let lstat name = - return (Unix.LargeFile.lstat name) - -#else - - external lstat_job : string -> [ `unix_lstat ] job = "lwt_unix_lstat_64_job" - external lstat_result : [ `unix_lstat ] job -> Unix.LargeFile.stats = "lwt_unix_lstat_64_result" - external lstat_free : [ `unix_lstat ] job -> unit = "lwt_unix_lstat_64_free" - - let lstat name = - execute_job (lstat_job name) lstat_result lstat_free - -#endif - -#if windows - - let fstat ch = - check_descriptor ch; - return (Unix.LargeFile.fstat ch.fd) - -#else - - external fstat_job : Unix.file_descr -> [ `unix_fstat ] job = "lwt_unix_fstat_64_job" - external fstat_result : [ `unix_fstat ] job -> Unix.LargeFile.stats = "lwt_unix_fstat_64_result" - external fstat_free : [ `unix_fstat ] job -> unit = "lwt_unix_fstat_64_free" - - let fstat ch = - check_descriptor ch; - execute_job (fstat_job ch.fd) fstat_result fstat_free - -#endif - -end - -(* +-----------------------------------------------------------------+ - | Operations on file names | - +-----------------------------------------------------------------+ *) - -#if windows - -let unlink name = - return (Unix.unlink name) - -#else - -external unlink_job : string -> [ `unix_unlink ] job = "lwt_unix_unlink_job" -external unlink_result : [ `unix_unlink ] job -> unit = "lwt_unix_unlink_result" -external unlink_free : [ `unix_unlink ] job -> unit = "lwt_unix_unlink_free" - -let unlink name = - execute_job (unlink_job name) unlink_result unlink_free - -#endif - -#if windows - -let rename name1 name2 = - return (Unix.rename name1 name2) - -#else - -external rename_job : string -> string -> [ `unix_rename ] job = "lwt_unix_rename_job" -external rename_result : [ `unix_rename ] job -> unit = "lwt_unix_rename_result" -external rename_free : [ `unix_rename ] job -> unit = "lwt_unix_rename_free" - -let rename name1 name2 = - execute_job (rename_job name1 name2) rename_result rename_free - -#endif - -#if windows - -let link name1 name2 = - return (Unix.link name1 name2) - -#else - -external link_job : string -> string -> [ `unix_link ] job = "lwt_unix_link_job" -external link_result : [ `unix_link ] job -> unit = "lwt_unix_link_result" -external link_free : [ `unix_link ] job -> unit = "lwt_unix_link_free" - -let link name1 name2 = - execute_job (link_job name1 name2) link_result link_free - -#endif - -(* +-----------------------------------------------------------------+ - | File permissions and ownership | - +-----------------------------------------------------------------+ *) - -#if windows - -let chmod name perms = - return (Unix.chmod name perms) - -#else - -external chmod_job : string -> Unix.file_perm -> [ `unix_chmod ] job = "lwt_unix_chmod_job" -external chmod_result : [ `unix_chmod ] job -> unit = "lwt_unix_chmod_result" -external chmod_free : [ `unix_chmod ] job -> unit = "lwt_unix_chmod_free" - -let chmod name perms = - execute_job (chmod_job name perms) chmod_result chmod_free - -#endif - -#if windows - -let fchmod ch perms = - check_descriptor ch; - return (Unix.fchmod ch.fd perms) - -#else - -external fchmod_job : Unix.file_descr -> Unix.file_perm -> [ `unix_fchmod ] job = "lwt_unix_fchmod_job" -external fchmod_result : [ `unix_fchmod ] job -> unit = "lwt_unix_fchmod_result" -external fchmod_free : [ `unix_fchmod ] job -> unit = "lwt_unix_fchmod_free" - -let fchmod ch perms = - check_descriptor ch; - execute_job (fchmod_job ch.fd perms) fchmod_result fchmod_free - -#endif - -#if windows - -let chown name uid gid = - return (Unix.chown name uid gid) - -#else - -external chown_job : string -> int -> int -> [ `unix_chown ] job = "lwt_unix_chown_job" -external chown_result : [ `unix_chown ] job -> unit = "lwt_unix_chown_result" -external chown_free : [ `unix_chown ] job -> unit = "lwt_unix_chown_free" - -let chown name uid gid = - execute_job (chown_job name uid gid) chown_result chown_free - -#endif - -#if windows - -let fchown ch uid gid = - check_descriptor ch; - return (Unix.fchown ch.fd uid gid) - -#else - -external fchown_job : Unix.file_descr -> int -> int -> [ `unix_fchown ] job = "lwt_unix_fchown_job" -external fchown_result : [ `unix_fchown ] job -> unit = "lwt_unix_fchown_result" -external fchown_free : [ `unix_fchown ] job -> unit = "lwt_unix_fchown_free" - -let fchown ch uid gid = - check_descriptor ch; - execute_job (fchown_job ch.fd uid gid) fchown_result fchown_free - -#endif - -type access_permission = - Unix.access_permission = - | R_OK - | W_OK - | X_OK - | F_OK - -#if windows - -let access name perms = - return (Unix.access name perms) - -#else - -external access_job : string -> Unix.access_permission list -> [ `unix_access ] job = "lwt_unix_access_job" -external access_result : [ `unix_access ] job -> unit = "lwt_unix_access_result" -external access_free : [ `unix_access ] job -> unit = "lwt_unix_access_free" - -let access name perms = - execute_job (access_job name perms) access_result access_free - -#endif - -(* +-----------------------------------------------------------------+ - | Operations on file descriptors | - +-----------------------------------------------------------------+ *) - -let dup ch = - check_descriptor ch; - let fd = Unix.dup ch.fd in - { - fd = fd; - state = Opened; - set_flags = ch.set_flags; - blocking = - if ch.set_flags then - lazy(Lazy.force ch.blocking >>= function - | true -> - Unix.clear_nonblock fd; - return true - | false -> - Unix.set_nonblock fd; - return false) - else - ch.blocking; - event_readable = None; - event_writable = None; - hooks_readable = Lwt_sequence.create (); - hooks_writable = Lwt_sequence.create (); - } - -let dup2 ch1 ch2 = - check_descriptor ch1; - Unix.dup2 ch1.fd ch2.fd; - ch2.set_flags <- ch1.set_flags; - ch2.blocking <- ( - if ch2.set_flags then - lazy(Lazy.force ch1.blocking >>= function - | true -> - Unix.clear_nonblock ch2.fd; - return true - | false -> - Unix.set_nonblock ch2.fd; - return false) - else - ch1.blocking - ) - -let set_close_on_exec ch = - check_descriptor ch; - Unix.set_close_on_exec ch.fd - -let clear_close_on_exec ch = - check_descriptor ch; - Unix.clear_close_on_exec ch.fd - -(* +-----------------------------------------------------------------+ - | Directories | - +-----------------------------------------------------------------+ *) - -#if windows - -let mkdir name perms = - return (Unix.mkdir name perms) - -#else - -external mkdir_job : string -> Unix.file_perm -> [ `unix_mkdir ] job = "lwt_unix_mkdir_job" -external mkdir_result : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_result" -external mkdir_free : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_free" - -let mkdir name perms = - execute_job (mkdir_job name perms) mkdir_result mkdir_free - -#endif - -#if windows - -let rmdir name = - return (Unix.rmdir name) - -#else - -external rmdir_job : string -> [ `unix_rmdir ] job = "lwt_unix_rmdir_job" -external rmdir_result : [ `unix_rmdir ] job -> unit = "lwt_unix_rmdir_result" -external rmdir_free : [ `unix_rmdir ] job -> unit = "lwt_unix_rmdir_free" - -let rmdir name = - execute_job (rmdir_job name) rmdir_result rmdir_free - -#endif - -#if windows - -let chdir name = - return (Unix.chdir name) - -#else - -external chdir_job : string -> [ `unix_chdir ] job = "lwt_unix_chdir_job" -external chdir_result : [ `unix_chdir ] job -> unit = "lwt_unix_chdir_result" -external chdir_free : [ `unix_chdir ] job -> unit = "lwt_unix_chdir_free" - -let chdir name = - execute_job (chdir_job name) chdir_result chdir_free - -#endif - -#if windows - -let chroot name = - return (Unix.chroot name) - -#else - -external chroot_job : string -> [ `unix_chroot ] job = "lwt_unix_chroot_job" -external chroot_result : [ `unix_chroot ] job -> unit = "lwt_unix_chroot_result" -external chroot_free : [ `unix_chroot ] job -> unit = "lwt_unix_chroot_free" - -let chroot name = - execute_job (chroot_job name) chroot_result chroot_free - -#endif - -type dir_handle = Unix.dir_handle - -#if windows - -let opendir name = - return (Unix.opendir name) - -#else - -external opendir_job : string -> [ `unix_opendir ] job = "lwt_unix_opendir_job" -external opendir_result : [ `unix_opendir ] job -> Unix.dir_handle = "lwt_unix_opendir_result" -external opendir_free : [ `unix_opendir ] job -> unit = "lwt_unix_opendir_free" - -let opendir name = - execute_job (opendir_job name) opendir_result opendir_free - -#endif - -#if windows - -let readdir handle = - return (Unix.readdir handle) - -#else - -external readdir_job : Unix.dir_handle -> [ `unix_readdir ] job = "lwt_unix_readdir_job" -external readdir_result : [ `unix_readdir ] job -> string = "lwt_unix_readdir_result" -external readdir_free : [ `unix_readdir ] job -> unit = "lwt_unix_readdir_free" - -let readdir handle = - execute_job (readdir_job handle) readdir_result readdir_free - -#endif - -#if windows - -let readdir_n handle count = - if count < 0 then - fail (Invalid_argument "Lwt_uinx.readdir_n") - else - let array = Array.make count "" in - let rec fill i = - if i = count then - return array - else - match try array.(i) <- Unix.readdir handle; true with End_of_file -> false with - | true -> - fill (i + 1) - | false -> - return (Array.sub array 0 i) - in - fill 0 - -#else - -external readdir_n_job : Unix.dir_handle -> int -> [ `unix_readdir_n ] job = "lwt_unix_readdir_n_job" -external readdir_n_result : [ `unix_readdir_n ] job -> string array = "lwt_unix_readdir_n_result" -external readdir_n_free : [ `unix_readdir_n ] job -> unit = "lwt_unix_readdir_n_free" - -let readdir_n handle count = - if count < 0 then - fail (Invalid_argument "Lwt_uinx.readdir_n") - else - execute_job (readdir_n_job handle count) readdir_n_result readdir_n_free - -#endif - -#if windows - -let rewinddir handle = - return (Unix.rewinddir handle) - -#else - -external rewinddir_job : Unix.dir_handle -> [ `unix_rewinddir ] job = "lwt_unix_rewinddir_job" -external rewinddir_result : [ `unix_rewinddir ] job -> unit = "lwt_unix_rewinddir_result" -external rewinddir_free : [ `unix_rewinddir ] job -> unit = "lwt_unix_rewinddir_free" - -let rewinddir handle = - execute_job (rewinddir_job handle) rewinddir_result rewinddir_free - -#endif - -#if windows - -let closedir handle = - return (Unix.closedir handle) - -#else - -external closedir_job : Unix.dir_handle -> [ `unix_closedir ] job = "lwt_unix_closedir_job" -external closedir_result : [ `unix_closedir ] job -> unit = "lwt_unix_closedir_result" -external closedir_free : [ `unix_closedir ] job -> unit = "lwt_unix_closedir_free" - -let closedir handle = - execute_job (closedir_job handle) closedir_result closedir_free - -#endif - -type list_directory_state = - | LDS_not_started - | LDS_listing of Unix.dir_handle - | LDS_done - -let cleanup_dir_handle state = - match !state with - | LDS_listing handle -> - ignore (closedir handle) - | LDS_not_started | LDS_done -> - () - -let files_of_directory path = - let state = ref LDS_not_started in - Lwt_stream.concat - (Lwt_stream.from - (fun () -> - match !state with - | LDS_not_started -> - lwt handle = opendir path in - lwt entries = - try_lwt - readdir_n handle 1024 - with exn -> - lwt () = closedir handle in - raise exn - in - if Array.length entries < 1024 then begin - state := LDS_done; - lwt () = closedir handle in - return (Some(Lwt_stream.of_array entries)) - end else begin - state := LDS_listing handle; - Gc.finalise cleanup_dir_handle state; - return (Some(Lwt_stream.of_array entries)) - end - | LDS_listing handle -> - lwt entries = - try_lwt - readdir_n handle 1024 - with exn -> - lwt () = closedir handle in - raise exn - in - if Array.length entries < 1024 then begin - state := LDS_done; - lwt () = closedir handle in - return (Some(Lwt_stream.of_array entries)) - end else - return (Some(Lwt_stream.of_array entries)) - | LDS_done -> - return None)) - -(* +-----------------------------------------------------------------+ - | Pipes and redirections | - +-----------------------------------------------------------------+ *) - -let pipe () = - let (out_fd, in_fd) = Unix.pipe() in - (mk_ch ~blocking:Lwt_sys.windows out_fd, mk_ch ~blocking:Lwt_sys.windows in_fd) - -let pipe_in () = - let (out_fd, in_fd) = Unix.pipe() in - (mk_ch ~blocking:Lwt_sys.windows out_fd, in_fd) - -let pipe_out () = - let (out_fd, in_fd) = Unix.pipe() in - (out_fd, mk_ch ~blocking:Lwt_sys.windows in_fd) - -#if windows - -let mkfifo name perms = - return (Unix.mkfifo name perms) - -#else - -external mkfifo_job : string -> Unix.file_perm -> [ `unix_mkfifo ] job = "lwt_unix_mkfifo_job" -external mkfifo_result : [ `unix_mkfifo ] job -> unit = "lwt_unix_mkfifo_result" -external mkfifo_free : [ `unix_mkfifo ] job -> unit = "lwt_unix_mkfifo_free" - -let mkfifo name perms = - execute_job (mkfifo_job name perms) mkfifo_result mkfifo_free - -#endif - -(* +-----------------------------------------------------------------+ - | Symbolic links | - +-----------------------------------------------------------------+ *) - -#if windows - -let symlink name1 name2 = - return (Unix.symlink name1 name2) - -#else - -external symlink_job : string -> string -> [ `unix_symlink ] job = "lwt_unix_symlink_job" -external symlink_result : [ `unix_symlink ] job -> unit = "lwt_unix_symlink_result" -external symlink_free : [ `unix_symlink ] job -> unit = "lwt_unix_symlink_free" - -let symlink name1 name2 = - execute_job (symlink_job name1 name2) symlink_result symlink_free - -#endif - -#if windows - -let readlink name = - return (Unix.readlink name) - -#else - -external readlink_job : string -> [ `unix_readlink ] job = "lwt_unix_readlink_job" -external readlink_result : [ `unix_readlink ] job -> string = "lwt_unix_readlink_result" -external readlink_free : [ `unix_readlink ] job -> unit = "lwt_unix_readlink_free" - -let readlink name = - execute_job (readlink_job name) readlink_result readlink_free - -#endif - -(* +-----------------------------------------------------------------+ - | Locking | - +-----------------------------------------------------------------+ *) - -type lock_command = - Unix.lock_command = - | F_ULOCK - | F_LOCK - | F_TLOCK - | F_TEST - | F_RLOCK - | F_TRLOCK - -#if windows - -let lockf ch cmd size = - check_descriptor ch; - return (Unix.lockf ch.fd cmd size) - -#else - -external lockf_job : Unix.file_descr -> Unix.lock_command -> int -> [ `unix_lockf ] job = "lwt_unix_lockf_job" -external lockf_result : [ `unix_lockf ] job -> unit = "lwt_unix_lockf_result" -external lockf_free : [ `unix_lockf ] job -> unit = "lwt_unix_lockf_free" - -let lockf ch cmd size = - check_descriptor ch; - execute_job (lockf_job ch.fd cmd size) lockf_result lockf_free - -#endif - -(* +-----------------------------------------------------------------+ - | User id, group id | - +-----------------------------------------------------------------+ *) - -type passwd_entry = - Unix.passwd_entry = - { - pw_name : string; - pw_passwd : string; - pw_uid : int; - pw_gid : int; - pw_gecos : string; - pw_dir : string; - pw_shell : string - } - -type group_entry = - Unix.group_entry = - { - gr_name : string; - gr_passwd : string; - gr_gid : int; - gr_mem : string array - } - -#if windows - -let getlogin () = - return (Unix.getlogin ()) - -#else - -external getlogin_job : unit -> [ `unix_getlogin ] job = "lwt_unix_getlogin_job" -external getlogin_result : [ `unix_getlogin ] job -> string = "lwt_unix_getlogin_result" -external getlogin_free : [ `unix_getlogin ] job -> unit = "lwt_unix_getlogin_free" - -let getlogin () = - execute_job (getlogin_job ()) getlogin_result getlogin_free - -#endif - -#if windows - -let getpwnam name = - return (Unix.getpwnam name) - -#else - -external getpwnam_job : string -> [ `unix_getpwnam ] job = "lwt_unix_getpwnam_job" -external getpwnam_result : [ `unix_getpwnam ] job -> Unix.passwd_entry = "lwt_unix_getpwnam_result" -external getpwnam_free : [ `unix_getpwnam ] job -> unit = "lwt_unix_getpwnam_free" - -let getpwnam name = - execute_job (getpwnam_job name) getpwnam_result getpwnam_free - -#endif - -#if windows - -let getgrnam name = - return (Unix.getgrnam name) - -#else - -external getgrnam_job : string -> [ `unix_getgrnam ] job = "lwt_unix_getgrnam_job" -external getgrnam_result : [ `unix_getgrnam ] job -> Unix.group_entry = "lwt_unix_getgrnam_result" -external getgrnam_free : [ `unix_getgrnam ] job -> unit = "lwt_unix_getgrnam_free" - -let getgrnam name = - execute_job (getgrnam_job name) getgrnam_result getgrnam_free - -#endif - -#if windows - -let getpwuid uid = - return (Unix.getpwuid uid) - -#else - -external getpwuid_job : int -> [ `unix_getpwuid ] job = "lwt_unix_getpwuid_job" -external getpwuid_result : [ `unix_getpwuid ] job -> Unix.passwd_entry = "lwt_unix_getpwuid_result" -external getpwuid_free : [ `unix_getpwuid ] job -> unit = "lwt_unix_getpwuid_free" - -let getpwuid uid = - execute_job (getpwuid_job uid) getpwuid_result getpwuid_free - -#endif - -#if windows - -let getgrgid gid = - return (Unix.getgrgid gid) - -#else - -external getgrgid_job : int -> [ `unix_getgrgid ] job = "lwt_unix_getgrgid_job" -external getgrgid_result : [ `unix_getgrgid ] job -> Unix.group_entry = "lwt_unix_getgrgid_result" -external getgrgid_free : [ `unix_getgrgid ] job -> unit = "lwt_unix_getgrgid_free" - -let getgrgid gid = - execute_job (getgrgid_job gid) getgrgid_result getgrgid_free - -#endif - -(* +-----------------------------------------------------------------+ - | Sockets | - +-----------------------------------------------------------------+ *) - -type msg_flag = - Unix.msg_flag = - | MSG_OOB - | MSG_DONTROUTE - | MSG_PEEK - -#if windows -let stub_recv = Unix.recv -#else -external stub_recv : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_recv" -#endif - -let recv ch buf pos len flags = - if pos < 0 || len < 0 || pos > String.length buf - len then - invalid_arg "Lwt_unix.recv" - else - wrap_syscall Read ch (fun () -> stub_recv ch.fd buf pos len flags) - -#if windows -let stub_send = Unix.send -#else -external stub_send : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_send" -#endif - -let send ch buf pos len flags = - if pos < 0 || len < 0 || pos > String.length buf - len then - invalid_arg "Lwt_unix.send" - else - wrap_syscall Write ch (fun () -> stub_send ch.fd buf pos len flags) - -#if windows -let stub_recvfrom = Unix.recvfrom -#else -external stub_recvfrom : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr = "lwt_unix_recvfrom" -#endif - -let recvfrom ch buf pos len flags = - if pos < 0 || len < 0 || pos > String.length buf - len then - invalid_arg "Lwt_unix.recvfrom" - else - wrap_syscall Read ch (fun () -> stub_recvfrom ch.fd buf pos len flags) - -#if windows -let stub_sendto = Unix.sendto -#else -external stub_sendto : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int = "lwt_unix_sendto_byte" "lwt_unix_sendto" -#endif - -let sendto ch buf pos len flags addr = - if pos < 0 || len < 0 || pos > String.length buf - len then - invalid_arg "Lwt_unix.sendto" - else - wrap_syscall Write ch (fun () -> stub_sendto ch.fd buf pos len flags addr) - -type io_vector = { - iov_buffer : string; - iov_offset : int; - iov_length : int; -} - -let io_vector ~buffer ~offset ~length = { - iov_buffer = buffer; - iov_offset = offset; - iov_length = length; -} - -let check_io_vectors func_name iovs = - List.iter (fun iov -> - if iov.iov_offset < 0 - || iov.iov_length < 0 - || iov.iov_offset > String.length iov.iov_buffer - iov.iov_length then - invalid_arg func_name) iovs - -#if windows - -let recv_msg ~socket ~io_vectors = - raise (Lwt_sys.Not_available "recv_msg") - -#else - -external stub_recv_msg : Unix.file_descr -> int -> io_vector list -> int * Unix.file_descr list = "lwt_unix_recv_msg" - -let recv_msg ~socket ~io_vectors = - check_io_vectors "Lwt_unix.recv_msg" io_vectors; - let n_iovs = List.length io_vectors in - wrap_syscall Read socket - (fun () -> - stub_recv_msg socket.fd n_iovs io_vectors) - -#endif - -#if windows - -let send_msg ~socket ~io_vectors ~fds = - raise (Lwt_sys.Not_available "send_msg") - -#else - -external stub_send_msg : Unix.file_descr -> int -> io_vector list -> int -> Unix.file_descr list -> int = "lwt_unix_send_msg" - -let send_msg ~socket ~io_vectors ~fds = - check_io_vectors "Lwt_unix.send_msg" io_vectors; - let n_iovs = List.length io_vectors and n_fds = List.length fds in - wrap_syscall Write socket - (fun () -> - stub_send_msg socket.fd n_iovs io_vectors n_fds fds) - -#endif - -type inet_addr = Unix.inet_addr - -type socket_domain = - Unix.socket_domain = - | PF_UNIX - | PF_INET - | PF_INET6 - -type socket_type = - Unix.socket_type = - | SOCK_STREAM - | SOCK_DGRAM - | SOCK_RAW - | SOCK_SEQPACKET - -type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int - -let socket dom typ proto = - let s = Unix.socket dom typ proto in - mk_ch ~blocking:false s - -type shutdown_command = - Unix.shutdown_command = - | SHUTDOWN_RECEIVE - | SHUTDOWN_SEND - | SHUTDOWN_ALL - -let shutdown ch shutdown_command = - check_descriptor ch; - Unix.shutdown ch.fd shutdown_command - -let socketpair dom typ proto = - let (s1, s2) = Unix.socketpair dom typ proto in - (mk_ch ~blocking:false s1, mk_ch ~blocking:false s2) - -let accept ch = - wrap_syscall Read ch (fun _ -> let (fd, addr) = Unix.accept ch.fd in (mk_ch ~blocking:false fd, addr)) - -let accept_n ch n = - let l = ref [] in - lwt blocking = Lazy.force ch.blocking in - try_lwt - wrap_syscall Read ch begin fun () -> - begin - try - for i = 1 to n do - if blocking && not (stub_readable ch.fd) then raise Retry; - let fd, addr = Unix.accept ch.fd in - l := (mk_ch ~blocking:false fd, addr) :: !l - done - with - | (Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) | Retry) when !l <> [] -> - (* Ignore blocking errors if we have at least one file-descriptor: *) - () - end; - (List.rev !l, None) - end - with exn -> - return (List.rev !l, Some exn) - -#if windows - -let connect ch addr = - (* [in_progress] tell wether connection has started but not - terminated: *) - let in_progress = ref false in - wrap_syscall Write ch begin fun () -> - if !in_progress then - (* Nothing works without this test and i have no idea why... *) - if writable ch then - try - Unix.connect ch.fd addr - with - | Unix.Unix_error (Unix.EISCONN, _, _) -> - (* This is the windows way of telling that the connection - has completed. *) - () - else - raise Retry - else - try - Unix.connect ch.fd addr - with - | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> - in_progress := true; - raise Retry - end - -#else - -let connect ch addr = - (* [in_progress] tell wether connection has started but not - terminated: *) - let in_progress = ref false in - wrap_syscall Write ch begin fun () -> - if !in_progress then - (* If the connection is in progress, [getsockopt_error] tells - wether it succceed: *) - match Unix.getsockopt_error ch.fd with - | None -> - (* The socket is connected *) - () - | Some err -> - (* An error happened: *) - raise (Unix.Unix_error(err, "connect", "")) - else - try - (* We should pass only one time here, unless the system call - is interrupted by a signal: *) - Unix.connect ch.fd addr - with - | Unix.Unix_error (Unix.EINPROGRESS, _, _) -> - in_progress := true; - raise Retry - end - -#endif - -let setsockopt ch opt v = - check_descriptor ch; - Unix.setsockopt ch.fd opt v - -let bind ch addr = - check_descriptor ch; - Unix.bind ch.fd addr - -let listen ch cnt = - check_descriptor ch; - Unix.listen ch.fd cnt - -let getpeername ch = - check_descriptor ch; - Unix.getpeername ch.fd - -let getsockname ch = - check_descriptor ch; - Unix.getsockname ch.fd - -type credentials = { - cred_pid : int; - cred_uid : int; - cred_gid : int; -} - -#if HAVE_GET_CREDENTIALS - -external stub_get_credentials : Unix.file_descr -> credentials = "lwt_unix_get_credentials" - -let get_credentials ch = - check_descriptor ch; - stub_get_credentials ch.fd - -#else - -let get_credentials ch = - raise (Lwt_sys.Not_available "get_credentials") - -#endif - -(* +-----------------------------------------------------------------+ - | Socket options | - +-----------------------------------------------------------------+ *) - -type socket_bool_option = - Unix.socket_bool_option = - | SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - | TCP_NODELAY - | IPV6_ONLY - -type socket_int_option = - Unix.socket_int_option = - | SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = Unix.socket_optint_option = SO_LINGER - -type socket_float_option = - Unix.socket_float_option = - | SO_RCVTIMEO - | SO_SNDTIMEO - -let getsockopt ch opt = - check_descriptor ch; - Unix.getsockopt ch.fd opt - -let setsockopt ch opt x = - check_descriptor ch; - Unix.setsockopt ch.fd opt x - -let getsockopt_int ch opt = - check_descriptor ch; - Unix.getsockopt_int ch.fd opt - -let setsockopt_int ch opt x = - check_descriptor ch; - Unix.setsockopt_int ch.fd opt x - -let getsockopt_optint ch opt = - check_descriptor ch; - Unix.getsockopt_optint ch.fd opt - -let setsockopt_optint ch opt x = - check_descriptor ch; - Unix.setsockopt_optint ch.fd opt x - -let getsockopt_float ch opt = - check_descriptor ch; - Unix.getsockopt_float ch.fd opt - -let setsockopt_float ch opt x = - check_descriptor ch; - Unix.setsockopt_float ch.fd opt x - -let getsockopt_error ch = - check_descriptor ch; - Unix.getsockopt_error ch.fd - -(* +-----------------------------------------------------------------+ - | Host and protocol databases | - +-----------------------------------------------------------------+ *) - -type host_entry = - Unix.host_entry = - { - h_name : string; - h_aliases : string array; - h_addrtype : socket_domain; - h_addr_list : inet_addr array - } - -type protocol_entry = - Unix.protocol_entry = - { - p_name : string; - p_aliases : string array; - p_proto : int - } - -type service_entry = - Unix.service_entry = - { - s_name : string; - s_aliases : string array; - s_port : int; - s_proto : string - } - -#if windows - -let gethostname () = - return (Unix.gethostname ()) - -#else - -external gethostname_job : unit -> [ `unix_gethostname ] job = "lwt_unix_gethostname_job" -external gethostname_result : [ `unix_gethostname ] job -> string = "lwt_unix_gethostname_result" -external gethostname_free : [ `unix_gethostname ] job -> unit = "lwt_unix_gethostname_free" - -let gethostname () = - execute_job (gethostname_job ()) gethostname_result gethostname_free - -#endif - -#if windows - -let gethostbyname name = - return (Unix.gethostbyname name) - -#else - -external gethostbyname_job : string -> [ `unix_gethostbyname ] job = "lwt_unix_gethostbyname_job" -external gethostbyname_result : [ `unix_gethostbyname ] job -> Unix.host_entry = "lwt_unix_gethostbyname_result" -external gethostbyname_free : [ `unix_gethostbyname ] job -> unit = "lwt_unix_gethostbyname_free" - -let gethostbyname name = - execute_job (gethostbyname_job name) gethostbyname_result gethostbyname_free - -#endif - -#if windows - -let gethostbyaddr addr = - return (Unix.gethostbyaddr addr) - -#else - -external gethostbyaddr_job : Unix.inet_addr -> [ `unix_gethostbyaddr ] job = "lwt_unix_gethostbyaddr_job" -external gethostbyaddr_result : [ `unix_gethostbyaddr ] job -> Unix.host_entry = "lwt_unix_gethostbyaddr_result" -external gethostbyaddr_free : [ `unix_gethostbyaddr ] job -> unit = "lwt_unix_gethostbyaddr_free" - -let gethostbyaddr addr = - execute_job (gethostbyaddr_job addr) gethostbyaddr_result gethostbyaddr_free - -#endif - -#if windows - -let getprotobyname name = - return (Unix.getprotobyname name) - -#else - -external getprotobyname_job : string -> [ `unix_getprotobyname ] job = "lwt_unix_getprotobyname_job" -external getprotobyname_result : [ `unix_getprotobyname ] job -> Unix.protocol_entry = "lwt_unix_getprotobyname_result" -external getprotobyname_free : [ `unix_getprotobyname ] job -> unit = "lwt_unix_getprotobyname_free" - -let getprotobyname name = - execute_job (getprotobyname_job name) getprotobyname_result getprotobyname_free - -#endif - -#if windows - -let getprotobynumber number = - return (Unix.getprotobynumber number) - -#else - -external getprotobynumber_job : int -> [ `unix_getprotobynumber ] job = "lwt_unix_getprotobynumber_job" -external getprotobynumber_result : [ `unix_getprotobynumber ] job -> Unix.protocol_entry = "lwt_unix_getprotobynumber_result" -external getprotobynumber_free : [ `unix_getprotobynumber ] job -> unit = "lwt_unix_getprotobynumber_free" - -let getprotobynumber number = - execute_job (getprotobynumber_job number) getprotobynumber_result getprotobynumber_free - -#endif - -#if windows - -let getservbyname name x = - return (Unix.getservbyname name x) - -#else - -external getservbyname_job : string -> string -> [ `unix_getservbyname ] job = "lwt_unix_getservbyname_job" -external getservbyname_result : [ `unix_getservbyname ] job -> Unix.service_entry = "lwt_unix_getservbyname_result" -external getservbyname_free : [ `unix_getservbyname ] job -> unit = "lwt_unix_getservbyname_free" - -let getservbyname name x = - execute_job (getservbyname_job name x) getservbyname_result getservbyname_free - -#endif - -#if windows - -let getservbyport port x = - return (Unix.getservbyport port x) - -#else - -external getservbyport_job : int -> string -> [ `unix_getservbyport ] job = "lwt_unix_getservbyport_job" -external getservbyport_result : [ `unix_getservbyport ] job -> Unix.service_entry = "lwt_unix_getservbyport_result" -external getservbyport_free : [ `unix_getservbyport ] job -> unit = "lwt_unix_getservbyport_free" - -let getservbyport port x = - execute_job (getservbyport_job port x) getservbyport_result getservbyport_free - -#endif - -type addr_info = - Unix.addr_info = - { - ai_family : socket_domain; - ai_socktype : socket_type; - ai_protocol : int; - ai_addr : sockaddr; - ai_canonname : string; - } - -type getaddrinfo_option = - Unix.getaddrinfo_option = - | AI_FAMILY of socket_domain - | AI_SOCKTYPE of socket_type - | AI_PROTOCOL of int - | AI_NUMERICHOST - | AI_CANONNAME - | AI_PASSIVE - -#if windows - -let getaddrinfo host service opts = - return (Unix.getaddrinfo host service opts) - -#else - -external getaddrinfo_job : string -> string -> Unix.getaddrinfo_option list -> [ `unix_getaddrinfo ] job = "lwt_unix_getaddrinfo_job" -external getaddrinfo_result : [ `unix_getaddrinfo ] job -> Unix.addr_info list = "lwt_unix_getaddrinfo_result" -external getaddrinfo_free : [ `unix_getaddrinfo ] job -> unit = "lwt_unix_getaddrinfo_free" - -let getaddrinfo host service opts = - execute_job (getaddrinfo_job host service opts) getaddrinfo_result getaddrinfo_free - -#endif - -type name_info = - Unix.name_info = - { - ni_hostname : string; - ni_service : string; - } - -type getnameinfo_option = - Unix.getnameinfo_option = - | NI_NOFQDN - | NI_NUMERICHOST - | NI_NAMEREQD - | NI_NUMERICSERV - | NI_DGRAM - -#if windows - -let getnameinfo addr opts = - return (Unix.getnameinfo addr opts) - -#else - -external getnameinfo_job : Unix.sockaddr -> Unix.getnameinfo_option list -> [ `unix_getnameinfo ] job = "lwt_unix_getnameinfo_job" -external getnameinfo_result : [ `unix_getnameinfo ] job -> Unix.name_info = "lwt_unix_getnameinfo_result" -external getnameinfo_free : [ `unix_getnameinfo ] job -> unit = "lwt_unix_getnameinfo_free" - -let getnameinfo addr opts = - execute_job (getnameinfo_job addr opts) getnameinfo_result getnameinfo_free - -#endif - -(* +-----------------------------------------------------------------+ - | Terminal interface | - +-----------------------------------------------------------------+ *) - - -type terminal_io = - Unix.terminal_io = - { - mutable c_ignbrk : bool; - mutable c_brkint : bool; - mutable c_ignpar : bool; - mutable c_parmrk : bool; - mutable c_inpck : bool; - mutable c_istrip : bool; - mutable c_inlcr : bool; - mutable c_igncr : bool; - mutable c_icrnl : bool; - mutable c_ixon : bool; - mutable c_ixoff : bool; - mutable c_opost : bool; - mutable c_obaud : int; - mutable c_ibaud : int; - mutable c_csize : int; - mutable c_cstopb : int; - mutable c_cread : bool; - mutable c_parenb : bool; - mutable c_parodd : bool; - mutable c_hupcl : bool; - mutable c_clocal : bool; - mutable c_isig : bool; - mutable c_icanon : bool; - mutable c_noflsh : bool; - mutable c_echo : bool; - mutable c_echoe : bool; - mutable c_echok : bool; - mutable c_echonl : bool; - mutable c_vintr : char; - mutable c_vquit : char; - mutable c_verase : char; - mutable c_vkill : char; - mutable c_veof : char; - mutable c_veol : char; - mutable c_vmin : int; - mutable c_vtime : int; - mutable c_vstart : char; - mutable c_vstop : char; - } - -type setattr_when = - Unix.setattr_when = - | TCSANOW - | TCSADRAIN - | TCSAFLUSH - -type flush_queue = - Unix.flush_queue = - | TCIFLUSH - | TCOFLUSH - | TCIOFLUSH - -type flow_action = - Unix.flow_action = - | TCOOFF - | TCOON - | TCIOFF - | TCION - -#if windows - -let tcgetattr ch = - check_descriptor ch; - return (Unix.tcgetattr ch.fd) - -#else - -external tcgetattr_job : Unix.file_descr -> [ `unix_tcgetattr ] job = "lwt_unix_tcgetattr_job" -external tcgetattr_result : [ `unix_tcgetattr ] job -> Unix.terminal_io = "lwt_unix_tcgetattr_result" -external tcgetattr_free : [ `unix_tcgetattr ] job -> unit = "lwt_unix_tcgetattr_free" - -let tcgetattr ch = - check_descriptor ch; - execute_job (tcgetattr_job ch.fd) tcgetattr_result tcgetattr_free - -#endif - -#if windows - -let tcsetattr ch when_ attrs = - check_descriptor ch; - return (Unix.tcsetattr ch.fd when_ attrs) - -#else - -external tcsetattr_job : Unix.file_descr -> Unix.setattr_when -> Unix.terminal_io -> [ `unix_tcsetattr ] job = "lwt_unix_tcsetattr_job" -external tcsetattr_result : [ `unix_tcsetattr ] job -> unit = "lwt_unix_tcsetattr_result" -external tcsetattr_free : [ `unix_tcsetattr ] job -> unit = "lwt_unix_tcsetattr_free" - -let tcsetattr ch when_ attrs = - check_descriptor ch; - execute_job (tcsetattr_job ch.fd when_ attrs) tcsetattr_result tcsetattr_free - -#endif - -#if windows - -let tcsendbreak ch delay = - check_descriptor ch; - return (Unix.tcsendbreak ch.fd delay) - -#else - -external tcsendbreak_job : Unix.file_descr -> int -> [ `unix_tcsendbreak ] job = "lwt_unix_tcsendbreak_job" -external tcsendbreak_result : [ `unix_tcsendbreak ] job -> unit = "lwt_unix_tcsendbreak_result" -external tcsendbreak_free : [ `unix_tcsendbreak ] job -> unit = "lwt_unix_tcsendbreak_free" - -let tcsendbreak ch delay = - check_descriptor ch; - execute_job (tcsendbreak_job ch.fd delay) tcsendbreak_result tcsendbreak_free - -#endif - -#if windows - -let tcdrain ch = - check_descriptor ch; - return (Unix.tcdrain ch.fd) - -#else - -external tcdrain_job : Unix.file_descr -> [ `unix_tcdrain ] job = "lwt_unix_tcdrain_job" -external tcdrain_result : [ `unix_tcdrain ] job -> unit = "lwt_unix_tcdrain_result" -external tcdrain_free : [ `unix_tcdrain ] job -> unit = "lwt_unix_tcdrain_free" - -let tcdrain ch = - check_descriptor ch; - execute_job (tcdrain_job ch.fd) tcdrain_result tcdrain_free - -#endif - -#if windows - -let tcflush ch q = - check_descriptor ch; - return (Unix.tcflush ch.fd q) - -#else - -external tcflush_job : Unix.file_descr -> Unix.flush_queue -> [ `unix_tcflush ] job = "lwt_unix_tcflush_job" -external tcflush_result : [ `unix_tcflush ] job -> unit = "lwt_unix_tcflush_result" -external tcflush_free : [ `unix_tcflush ] job -> unit = "lwt_unix_tcflush_free" - -let tcflush ch q = - check_descriptor ch; - execute_job (tcflush_job ch.fd q) tcflush_result tcflush_free - -#endif - -#if windows - -let tcflow ch act = - check_descriptor ch; - return (Unix.tcflow ch.fd act) - -#else - -external tcflow_job : Unix.file_descr -> Unix.flow_action -> [ `unix_tcflow ] job = "lwt_unix_tcflow_job" -external tcflow_result : [ `unix_tcflow ] job -> unit = "lwt_unix_tcflow_result" -external tcflow_free : [ `unix_tcflow ] job -> unit = "lwt_unix_tcflow_free" - -let tcflow ch act = - check_descriptor ch; - execute_job (tcflow_job ch.fd act) tcflow_result tcflow_free - -#endif - -(* +-----------------------------------------------------------------+ - | Reading notifications | - +-----------------------------------------------------------------+ *) - -(* Buffer used to receive notifications: *) -let notification_buffer = String.create 4 - -external init_notification : unit -> Unix.file_descr = "lwt_unix_init_notification" -external send_notification : int -> unit = "lwt_unix_send_notification_stub" -external recv_notifications : unit -> int array = "lwt_unix_recv_notifications" - -let handle_notification id = - match try Some(Notifiers.find notifiers id) with Not_found -> None with - | Some notifier -> - if notifier.notify_once then - stop_notification id; - notifier.notify_handler () - | None -> - () - -let rec handle_notifications ev = - (* Process available notifications. *) - Array.iter handle_notification (recv_notifications ()) - -let event_notifications = ref (Lwt_engine.on_readable (init_notification ()) handle_notifications) - -(* +-----------------------------------------------------------------+ - | Signals | - +-----------------------------------------------------------------+ *) - -module Signal_map = Map.Make(struct type t = int let compare a b = a - b end) - -let signals = ref Signal_map.empty -let signal_count () = - Signal_map.fold - (fun signum (id, actions) len -> len + Lwt_sequence.length actions) - !signals - 0 - -type signal_handler_id = unit Lazy.t - -let on_signal signum handler = - let notification, actions = - try - Signal_map.find signum !signals - with Not_found -> - let actions = Lwt_sequence.create () in - let notification = make_notification (fun () -> Lwt_sequence.iter_l (fun f -> f signum) actions) in - (try - Sys.set_signal signum (Sys.Signal_handle (fun signum -> send_notification notification)) - with exn -> - stop_notification notification; - raise exn); - signals := Signal_map.add signum (notification, actions) !signals; - (notification, actions) - in - let node = Lwt_sequence.add_r handler actions in - lazy(Lwt_sequence.remove node; - if Lwt_sequence.is_empty actions then begin - signals := Signal_map.remove signum !signals; - stop_notification notification; - Sys.set_signal signum Sys.Signal_default - end) - -let disable_signal_handler = Lazy.force - -let reinstall_signal_handler signum = - match try Some (Signal_map.find signum !signals) with Not_found -> None with - | Some (notification, actions) -> - Sys.set_signal signum (Sys.Signal_handle (fun signum -> send_notification notification)) - | None -> - () - -(* +-----------------------------------------------------------------+ - | Processes | - +-----------------------------------------------------------------+ *) - -external reset_after_fork : unit -> unit = "lwt_unix_reset_after_fork" - -let fork () = - match Unix.fork () with - | 0 -> - (* Reset threading. *) - reset_after_fork (); - (* Stop the old event for notifications. *) - Lwt_engine.stop_event !event_notifications; - (* Reinitialise the notification system. *) - event_notifications := Lwt_engine.on_readable (init_notification ()) handle_notifications; - (* Collect all pending jobs. *) - let l = Lwt_sequence.fold_l (fun w l -> w :: l) jobs [] in - (* Remove them all. *) - Lwt_sequence.iter_node_l Lwt_sequence.remove jobs; - (* And cancel them all. We yield first so that if the program - do an exec just after, it won't be executed. *) - on_termination (Lwt_main.yield ()) (fun () -> List.iter cancel l); - 0 - | pid -> - pid - -type process_status = - Unix.process_status = - | WEXITED of int - | WSIGNALED of int - | WSTOPPED of int - -type wait_flag = - Unix.wait_flag = - | WNOHANG - | WUNTRACED - -let has_wait4 = not Lwt_sys.windows - -type resource_usage = { ru_utime : float; ru_stime : float } - -#if windows - -let stub_wait4 flags pid = - let pid, status = Unix.waitpid flags pid in - (pid, status, { ru_utime = 0.0; ru_stime = 0.0 }) - -#else - -external stub_wait4 : Unix.wait_flag list -> int -> int * Unix.process_status * resource_usage = "lwt_unix_wait4" - -#endif - -let wait_children = Lwt_sequence.create () -let wait_count () = Lwt_sequence.length wait_children - -#if not windows -let () = - ignore begin - on_signal Sys.sigchld - (fun _ -> - Lwt_sequence.iter_node_l begin fun node -> - let wakener, flags, pid = Lwt_sequence.get node in - try - let (pid', _, _) as v = stub_wait4 flags pid in - if pid' <> 0 then begin - Lwt_sequence.remove node; - Lwt.wakeup wakener v - end - with e -> - Lwt_sequence.remove node; - Lwt.wakeup_exn wakener e - end wait_children) - end -#endif - -let _waitpid flags pid = - try_lwt - return (Unix.waitpid flags pid) - -#if windows - -let waitpid = _waitpid - -#else - -let waitpid flags pid = - if List.mem Unix.WNOHANG flags then - _waitpid flags pid - else - let flags = Unix.WNOHANG :: flags in - lwt ((pid', _) as res) = _waitpid flags pid in - if pid' <> 0 then - return res - else begin - let (res, w) = Lwt.task () in - let node = Lwt_sequence.add_l (w, flags, pid) wait_children in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - lwt (pid, status, _) = res in - return (pid, status) - end - -#endif - -let _wait4 flags pid = - try_lwt - return (stub_wait4 flags pid) - -#if windows - -let wait4 = _wait4 - -#else - -let wait4 flags pid = - if List.mem Unix.WNOHANG flags then - _wait4 flags pid - else - let flags = Unix.WNOHANG :: flags in - lwt (pid', _, _) as res = _wait4 flags pid in - if pid' <> 0 then - return res - else begin - let (res, w) = Lwt.task () in - let node = Lwt_sequence.add_l (w, flags, pid) wait_children in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - res - end - -#endif - -let wait () = waitpid [] (-1) - -let system cmd = - match Unix.fork () with - | 0 -> - begin try - Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] - with _ -> - exit 127 - end - | id -> - waitpid [] id >|= snd - -(* +-----------------------------------------------------------------+ - | Misc | - +-----------------------------------------------------------------+ *) - -let run = Lwt_main.run - -let handle_unix_error f x = - try_lwt - f x - with exn -> - Unix.handle_unix_error (fun () -> raise exn) () - -(* +-----------------------------------------------------------------+ - | System thread pool | - +-----------------------------------------------------------------+ *) - -external pool_size : unit -> int = "lwt_unix_pool_size" "noalloc" -external set_pool_size : int -> unit = "lwt_unix_set_pool_size" "noalloc" -external thread_count : unit -> int = "lwt_unix_thread_count" "noalloc" -external thread_waiting_count : unit -> int = "lwt_unix_thread_waiting_count" "noalloc" - -(* +-----------------------------------------------------------------+ - | CPUs | - +-----------------------------------------------------------------+ *) - -#if HAVE_GETCPU -external get_cpu : unit -> int = "lwt_unix_get_cpu" -#else -let get_cpu () = raise (Lwt_sys.Not_available "get_cpu") -#endif - -#if HAVE_AFFINITY - -external stub_get_affinity : int -> int list = "lwt_unix_get_affinity" -external stub_set_affinity : int -> int list -> unit = "lwt_unix_set_affinity" - -let get_affinity ?(pid=0) () = stub_get_affinity pid -let set_affinity ?(pid=0) l = stub_set_affinity pid l - -#else - -let get_affinity ?pid () = raise (Lwt_sys.Not_available "get_affinity") -let set_affinity ?pid l = raise (Lwt_sys.Not_available "set_affinity") - -#endif - -(* +-----------------------------------------------------------------+ - | Error printing | - +-----------------------------------------------------------------+ *) - -let () = - Printexc.register_printer - (function - | Unix.Unix_error(error, func, arg) -> - let error = - match error with - | Unix.E2BIG -> "E2BIG" - | Unix.EACCES -> "EACCES" - | Unix.EAGAIN -> "EAGAIN" - | Unix.EBADF -> "EBADF" - | Unix.EBUSY -> "EBUSY" - | Unix.ECHILD -> "ECHILD" - | Unix.EDEADLK -> "EDEADLK" - | Unix.EDOM -> "EDOM" - | Unix.EEXIST -> "EEXIST" - | Unix.EFAULT -> "EFAULT" - | Unix.EFBIG -> "EFBIG" - | Unix.EINTR -> "EINTR" - | Unix.EINVAL -> "EINVAL" - | Unix.EIO -> "EIO" - | Unix.EISDIR -> "EISDIR" - | Unix.EMFILE -> "EMFILE" - | Unix.EMLINK -> "EMLINK" - | Unix.ENAMETOOLONG -> "ENAMETOOLONG" - | Unix.ENFILE -> "ENFILE" - | Unix.ENODEV -> "ENODEV" - | Unix.ENOENT -> "ENOENT" - | Unix.ENOEXEC -> "ENOEXEC" - | Unix.ENOLCK -> "ENOLCK" - | Unix.ENOMEM -> "ENOMEM" - | Unix.ENOSPC -> "ENOSPC" - | Unix.ENOSYS -> "ENOSYS" - | Unix.ENOTDIR -> "ENOTDIR" - | Unix.ENOTEMPTY -> "ENOTEMPTY" - | Unix.ENOTTY -> "ENOTTY" - | Unix.ENXIO -> "ENXIO" - | Unix.EPERM -> "EPERM" - | Unix.EPIPE -> "EPIPE" - | Unix.ERANGE -> "ERANGE" - | Unix.EROFS -> "EROFS" - | Unix.ESPIPE -> "ESPIPE" - | Unix.ESRCH -> "ESRCH" - | Unix.EXDEV -> "EXDEV" - | Unix.EWOULDBLOCK -> "EWOULDBLOCK" - | Unix.EINPROGRESS -> "EINPROGRESS" - | Unix.EALREADY -> "EALREADY" - | Unix.ENOTSOCK -> "ENOTSOCK" - | Unix.EDESTADDRREQ -> "EDESTADDRREQ" - | Unix.EMSGSIZE -> "EMSGSIZE" - | Unix.EPROTOTYPE -> "EPROTOTYPE" - | Unix.ENOPROTOOPT -> "ENOPROTOOPT" - | Unix.EPROTONOSUPPORT -> "EPROTONOSUPPORT" - | Unix.ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT" - | Unix.EOPNOTSUPP -> "EOPNOTSUPP" - | Unix.EPFNOSUPPORT -> "EPFNOSUPPORT" - | Unix.EAFNOSUPPORT -> "EAFNOSUPPORT" - | Unix.EADDRINUSE -> "EADDRINUSE" - | Unix.EADDRNOTAVAIL -> "EADDRNOTAVAIL" - | Unix.ENETDOWN -> "ENETDOWN" - | Unix.ENETUNREACH -> "ENETUNREACH" - | Unix.ENETRESET -> "ENETRESET" - | Unix.ECONNABORTED -> "ECONNABORTED" - | Unix.ECONNRESET -> "ECONNRESET" - | Unix.ENOBUFS -> "ENOBUFS" - | Unix.EISCONN -> "EISCONN" - | Unix.ENOTCONN -> "ENOTCONN" - | Unix.ESHUTDOWN -> "ESHUTDOWN" - | Unix.ETOOMANYREFS -> "ETOOMANYREFS" - | Unix.ETIMEDOUT -> "ETIMEDOUT" - | Unix.ECONNREFUSED -> "ECONNREFUSED" - | Unix.EHOSTDOWN -> "EHOSTDOWN" - | Unix.EHOSTUNREACH -> "EHOSTUNREACH" - | Unix.ELOOP -> "ELOOP" - | Unix.EOVERFLOW -> "EOVERFLOW" - | Unix.EUNKNOWNERR n -> Printf.sprintf "EUNKNOWNERR %d" n - in - Some(Printf.sprintf "Unix.Unix_error(Unix.%s, %S, %S)" error func arg) - | _ -> - None) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix.mli b/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix.mli deleted file mode 100644 index b657e18..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix.mli +++ /dev/null @@ -1,1131 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Lwt_unix - * Copyright (C) 2005-2008 Jrme Vouillon - * Laboratoire PPS - CNRS Universit Paris Diderot - * 2009 Jrmie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Cooperative system calls *) - -(** This modules redefine system calls, as in the [Unix] module of the - standard library, but mapped into cooperative ones, which will not - block the program, letting other threads run. - - The semantic of all operations is the following: if the action - (for example reading from a {b file descriptor}) can be performed - immediatly, it is done and returns immediatly, otherwise it - returns a sleeping threads which is waked up when the operation - completes. - - Moreover all sleeping threads returned by function of this modules - are {b cancelable}, this means that you can cancel them with - {!Lwt.cancel}. For example if you want to read something from a {b - file descriptor} with a timeout, you can cancel the action after - the timeout and the reading will not be performed if not already - done. - - More precisely, assuming that you have two {b file descriptor} - [fd1] and [fd2] and you want to read something from [fd1] or - exclusively from [fd2], and fail with an exception if a timeout of - 1 second expires, without reading anything from [fd1] and [fd2], - even if they become readable in the future. - - Then you can do: - - {[ - Lwt.pick [Lwt_unix.timeout 1.0; read fd1 buf1 ofs1 len1; read fd2 buf2 ofs2 len2] - ]} - - In this case it is guaranteed that exactly one of the three - operations will completes, and other will just be cancelled. -*) - -val handle_unix_error : ('a -> 'b Lwt.t) -> 'a -> 'b Lwt.t - (** Same as [Unix.handle_unix_error] but catches lwt-level - exceptions *) - -(** {6 Configuration} *) - -(** For system calls that cannot be made asynchronously, Lwt uses one - of the following method: *) -type async_method = - | Async_none - (** System calls are made synchronously, and may block the - entire program. *) - | Async_detach - (** System calls are made in another system thread, thus without - blocking other Lwt threads. The drawback is that it may - degrade performances in some cases. - - This is the default. *) - | Async_switch - (** System calls are made in the main thread, and if one blocks - the execution continue in another system thread. This method - is the most efficint, also you will get better performances - if you force all threads to run on the same cpu. On linux - this can be done by using the command [taskset]. - - Note that this method is still experimental. *) - -val default_async_method : unit -> async_method - (** Returns the default async method. - - This can be initialized using the environment variable - ["LWT_ASYNC_METHOD"] with possible values ["none"], - ["detach"] and ["switch"]. *) - -val set_default_async_method : async_method -> unit - (** Sets the default async method. *) - -val async_method : unit -> async_method - (** [async_method ()] returns the async method used in the current - thread. *) - -val async_method_key : async_method Lwt.key - (** The key for storing the local async method. *) - -val with_async_none : (unit -> 'a) -> 'a - (** [with_async_none f] is a shorthand for: - - {[ - Lwt.with_value async_method_key (Some Async_none) f - ]} - *) - -val with_async_detach : (unit -> 'a) -> 'a - (** [with_async_none f] is a shorthand for: - - {[ - Lwt.with_value async_method_key (Some Async_detach) f - ]} - *) - -val with_async_switch : (unit -> 'a) -> 'a - (** [with_async_none f] is a shorthand for: - - {[ - Lwt.with_value async_method_key (Some Async_switch) f - ]} - *) - -(** {6 Sleeping} *) - -val sleep : float -> unit Lwt.t - (** [sleep d] is a threads which remain suspended for [d] seconds - and then terminates. *) - -val yield : unit -> unit Lwt.t - (** [yield ()] is a threads which suspends itself and then resumes - as soon as possible and terminates. *) - -val auto_yield : float -> (unit -> unit Lwt.t) - (** [auto_yield timeout] returns a function [f] which will yield - every [timeout] seconds. *) - -exception Timeout - (** Exception raised by timeout operations *) - -val timeout : float -> 'a Lwt.t - (** [timeout d] is a threads which remain suspended for [d] seconds - then fail with {!Timeout} *) - -val with_timeout : float -> (unit -> 'a Lwt.t) -> 'a Lwt.t - (** [with_timeout d f] is a short-hand for: - - {[ - Lwt.pick [Lwt_unix.timeout d; f ()] - ]} - *) - -(** {6 Operation on file-descriptors} *) - -type file_descr - (** The abstract type for {b file descriptor}s. A Lwt {b file - descriptor} is a pair of a unix {b file descriptor} (of type - [Unix.file_descr]) and a {b state}. - - A {b file descriptor} may be: - - - {b opened}, in which case it is fully usable - - {b closed} or {b aborted}, in which case it is no longer - usable *) - -(** State of a {b file descriptor} *) -type state = - | Opened - (** The {b file descriptor} is opened *) - | Closed - (** The {b file descriptor} has been closed by {!close}. It must - not be used for any operation. *) - | Aborted of exn - (** The {b file descriptor} has been aborted, the only operation - possible is {!close}, all others will fail. *) - -val state : file_descr -> state - (** [state fd] returns the state of [fd] *) - -val unix_file_descr : file_descr -> Unix.file_descr - (** Returns the underlying unix {b file descriptor}. It always - succeed, even if the {b file descriptor}'s state is not - {!Open}. *) - -val of_unix_file_descr : ?blocking : bool -> ?set_flags : bool -> Unix.file_descr -> file_descr - (** Creates a lwt {b file descriptor} from a unix one. - - [blocking] is the blocking mode of the file-descriptor, it - describe how Lwt will use it. In non-blocking mode, read/write - on this file descriptor are made using non-blocking IO; in - blocking mode they are made using the current async method. If - [blocking] is not specified it is guessed according to the file - kind: socket and pipes are in non-blocking mode and others are - in blocking mode. - - If [set_flags] is [true] (the default) then the file flags are - modified according to the [blocking] argument, otherwise they - are left unchanged. - - Note that the blocking mode is less efficient than the - non-blocking one, so it should be used only for file descriptors - that does not support asynchronous operations, such as regular - files, or for shared descriptors such as {!stdout}, {!stderr} or - {!stdin}. *) - -val blocking : file_descr -> bool Lwt.t - (** [blocking fd] returns whether [fd] is used in blocking or - non-blocking mode. *) - -val set_blocking : ?set_flags : bool -> file_descr -> bool -> unit - (** [set_blocking fd b] puts [fd] in blocking or non-blocking - mode. If [set_flags] is [true] (the default) then the file flags - are modified, otherwise the modification is only done at the - application level. *) - -val abort : file_descr -> exn -> unit - (** [abort fd exn] makes all current and further uses of the file - descriptor fail with the given exception. This put the {b file - descriptor} into the {!Aborted} state. - - If the {b file descrptor} is closed, this does nothing, if it is - aborted, this replace the abort exception by [exn]. - - Note that this only works for reading and writing operations on - file descriptors supporting non-blocking mode. *) - -(** {6 Process handling} *) - -val fork : unit -> int - (** [fork ()] does the same as [Unix.fork]. You must use this - function instead of [Unix.fork] when you want to use Lwt in the - child process. - - Notes: - - in the child process all pending jobs are canceled, - - if you are going to use Lwt in the parent and the child, it is - a good idea to call {!Lwt_io.flush_all} before callling - {!fork} to avoid double-flush. *) - -type process_status = - Unix.process_status = - | WEXITED of int - | WSIGNALED of int - | WSTOPPED of int - -type wait_flag = - Unix.wait_flag = - | WNOHANG - | WUNTRACED - -val wait : unit -> (int * process_status) Lwt.t - (** Wrapper for [Unix.wait] *) - -val waitpid : wait_flag list -> int -> (int * process_status) Lwt.t - (** Wrapper for [Unix.waitpid] *) - -(** Resource usages *) -type resource_usage = { - ru_utime : float; - (** User time used *) - - ru_stime : float; - (** System time used *) -} - -val wait4 : wait_flag list -> int -> (int * process_status * resource_usage) Lwt.t - (** [wait4 flags pid] returns [(pid, status, rusage)] where [(pid, - status)] is the same result as [Unix.waitpid flags pid], and - [rusage] contains accounting information about the child. - - On windows it will always returns [{ utime = 0.0; stime = 0.0 }]. *) - -val wait_count : unit -> int - (** Returns the number of threads waiting for a child to - terminate. *) - -val system : string -> process_status Lwt.t - (** Wrapper for [Unix.system] *) - -(** {6 Basic file input/output} *) - -val stdin : file_descr - (** The standard {b file descriptor} for input. This one is usually - a terminal is the program is started from a terminal. *) - -val stdout : file_descr - (** The standard {b file descriptor} for output *) - -val stderr : file_descr - (** The standard {b file descriptor} for printing error messages *) - -type file_perm = Unix.file_perm - -type open_flag = - Unix.open_flag = - | O_RDONLY - | O_WRONLY - | O_RDWR - | O_NONBLOCK - | O_APPEND - | O_CREAT - | O_TRUNC - | O_EXCL - | O_NOCTTY - | O_DSYNC - | O_SYNC - | O_RSYNC - -val openfile : string -> open_flag list -> file_perm -> file_descr Lwt.t - (** Wrapper for [Unix.openfile]. *) - -val close : file_descr -> unit Lwt.t - (** Close a {b file descriptor}. This close the underlying unix {b - file descriptor} and set its state to {!Closed} *) - -val read : file_descr -> string -> int -> int -> int Lwt.t - (** [read fd buf ofs len] has the same semantic as [Unix.read], but - is cooperative *) - -val write : file_descr -> string -> int -> int -> int Lwt.t - (** [read fd buf ofs len] has the same semantic as [Unix.write], but - is cooperative *) - -val readable : file_descr -> bool - (** Returns whether the given file descriptor is currently - readable. *) - -val writable : file_descr -> bool - (** Returns whether the given file descriptor is currently - writable. *) - -val wait_read : file_descr -> unit Lwt.t - (** waits (without blocking other threads) until there is something - to read on the file descriptor *) - -val wait_write : file_descr -> unit Lwt.t - (** waits (without blocking other threads) until it is possible to - write on the file descriptor *) - -(** {6 Seeking and truncating} *) - -type seek_command = - Unix.seek_command = - | SEEK_SET - | SEEK_CUR - | SEEK_END - -val lseek : file_descr -> int -> seek_command -> int Lwt.t - (** Wrapper for [Unix.lseek] *) - -val truncate : string -> int -> unit Lwt.t - (** Wrapper for [Unix.truncate] *) - -val ftruncate : file_descr -> int -> unit Lwt.t - (** Wrapper for [Unix.ftruncate] *) - -(** {6 Syncing} *) - -val fsync : file_descr -> unit Lwt.t - (** Synchronise all data and metadata of the file descriptor with - the disk. On Windows it uses [FlushFileBuffers]. *) - -val fdatasync : file_descr -> unit Lwt.t - (** Synchronise all data (but not metadata) of the file descriptor - with the disk. - - Note that [fdatasync] is not available on all platforms. *) - -(** {6 File status} *) - -type file_kind = - Unix.file_kind = - | S_REG - | S_DIR - | S_CHR - | S_BLK - | S_LNK - | S_FIFO - | S_SOCK - -type stats = - Unix.stats = - { - st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int; - st_atime : float; - st_mtime : float; - st_ctime : float; - } - -val stat : string -> stats Lwt.t - (** Wrapper for [Unix.stat] *) - -val lstat : string -> stats Lwt.t - (** Wrapper for [Unix.lstat] *) - -val fstat : file_descr -> stats Lwt.t - (** Wrapper for [Unix.fstat] *) - -val isatty : file_descr -> bool Lwt.t - (** Wrapper for [Unix.isatty] *) - -(** {6 File operations on large files} *) - -module LargeFile : sig - val lseek : file_descr -> int64 -> seek_command -> int64 Lwt.t - (** Wrapper for [Unix.LargeFile.lseek] *) - - val truncate : string -> int64 -> unit Lwt.t - (** Wrapper for [Unix.LargeFile.truncate] *) - - val ftruncate : file_descr -> int64 -> unit Lwt.t - (** Wrapper for [Unix.LargeFile.ftruncate] *) - - type stats = - Unix.LargeFile.stats = - { - st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int64; - st_atime : float; - st_mtime : float; - st_ctime : float; - } - - val stat : string -> stats Lwt.t - (** Wrapper for [Unix.LargeFile.stat] *) - - val lstat : string -> stats Lwt.t - (** Wrapper for [Unix.LargeFile.lstat] *) - - val fstat : file_descr -> stats Lwt.t - (** Wrapper for [Unix.LargeFile.fstat] *) -end - -(** {6 Operations on file names} *) - -val unlink : string -> unit Lwt.t - (** Wrapper for [Unix.unlink] *) - -val rename : string -> string -> unit Lwt.t - (** Wrapper for [Unix.rename] *) - -val link : string -> string -> unit Lwt.t - (** Wrapper for [Unix.link] *) - -(** {6 File permissions and ownership} *) - -val chmod : string -> file_perm -> unit Lwt.t - (** Wrapper for [Unix.chmod] *) - -val fchmod : file_descr -> file_perm -> unit Lwt.t - (** Wrapper for [Unix.fchmod] *) - -val chown : string -> int -> int -> unit Lwt.t - (** Wrapper for [Unix.chown] *) - -val fchown : file_descr -> int -> int -> unit Lwt.t - (** Wrapper for [Unix.fchown] *) - -type access_permission = - Unix.access_permission = - | R_OK - | W_OK - | X_OK - | F_OK - -val access : string -> access_permission list -> unit Lwt.t - (** Wrapper for [Unix.access] *) - -(** {6 Operations on file descriptors} *) - -val dup : file_descr -> file_descr - (** Wrapper for [Unix.dup] *) - -val dup2 : file_descr -> file_descr -> unit - (** Wrapper for [Unix.dup2] *) - -val set_close_on_exec : file_descr -> unit - (** Wrapper for [Unix.set_close_on_exec] *) - -val clear_close_on_exec : file_descr -> unit - (** Wrapper for [Unix.clear_close_on_exec] *) - -(** {6 Directories} *) - -val mkdir : string -> file_perm -> unit Lwt.t - (** Wrapper for [Unix.mkdir] *) - -val rmdir : string -> unit Lwt.t - (** Wrapper for [Unix.rmdir] *) - -val chdir : string -> unit Lwt.t - (** Wrapper for [Unix.chdir] *) - -val chroot : string -> unit Lwt.t - (** Wrapper for [Unix.chroot] *) - -type dir_handle = Unix.dir_handle - -val opendir : string -> dir_handle Lwt.t - (** Wrapper for [Unix.opendir] *) - -val readdir : dir_handle -> string Lwt.t - (** Wrapper for [Unix.dir] *) - -val readdir_n : dir_handle -> int -> string array Lwt.t - (** [readdir_n handle count] reads at most [count] entry from the - given directory. It is more efficient that callling [count] - times [readdir]. If the length of the returned array is smaller - than [count], this means that the end of the directory has been - reached. *) - -val rewinddir : dir_handle -> unit Lwt.t - (** Wrapper for [Unix.rewinddir] *) - -val closedir : dir_handle -> unit Lwt.t - (** Wrapper for [Unix.closedir] *) - -val files_of_directory : string -> string Lwt_stream.t - (** [files_of_directory dir] returns the stream of all files of - [dir]. *) - -(** {6 Pipes and redirections} *) - -val pipe : unit -> file_descr * file_descr - (** [pipe ()] creates pipe using [Unix.pipe] and returns two lwt {b - file descriptor}s created from unix {b file_descriptor} *) - -val pipe_in : unit -> file_descr * Unix.file_descr - (** [pipe_in ()] is the same as {!pipe} but maps only the unix {b - file descriptor} for reading into a lwt one. The second is not - put into non-blocking mode. You usually want to use this before - forking to receive data from the child process. *) - -val pipe_out : unit -> Unix.file_descr * file_descr - (** [pipe_out ()] is the inverse of {!pipe_in}. You usually want to - use this before forking to send data to the child process *) - -val mkfifo : string -> file_perm -> unit Lwt.t - (** Wrapper for [Unix.mkfifo] *) - -(** {6 Symbolic links} *) - -val symlink : string -> string -> unit Lwt.t - (** Wrapper for [Unix.symlink] *) - -val readlink : string -> string Lwt.t - (** Wrapper for [Unix.readlink] *) - -(** {6 Locking} *) - -type lock_command = - Unix.lock_command = - | F_ULOCK - | F_LOCK - | F_TLOCK - | F_TEST - | F_RLOCK - | F_TRLOCK - -val lockf : file_descr -> lock_command -> int -> unit Lwt.t - (** Wrapper for [Unix.lockf] *) - -(** {6 User id, group id} *) - -type passwd_entry = - Unix.passwd_entry = - { - pw_name : string; - pw_passwd : string; - pw_uid : int; - pw_gid : int; - pw_gecos : string; - pw_dir : string; - pw_shell : string - } - -type group_entry = - Unix.group_entry = - { - gr_name : string; - gr_passwd : string; - gr_gid : int; - gr_mem : string array - } - -val getlogin : unit -> string Lwt.t - (** Wrapper for [Unix.getlogin] *) - -val getpwnam : string -> passwd_entry Lwt.t - (** Wrapper for [Unix.getpwnam] *) - -val getgrnam : string -> group_entry Lwt.t - (** Wrapper for [Unix.getgrnam] *) - -val getpwuid : int -> passwd_entry Lwt.t - (** Wrapper for [Unix.getpwuid] *) - -val getgrgid : int -> group_entry Lwt.t - (** Wrapper for [Unix.getgrgid] *) - -(** {6 Signals} *) - -type signal_handler_id - (** Id of a signal handler, used to cancel it *) - -val on_signal : int -> (int -> unit) -> signal_handler_id - (** [on_signal signum f] calls [f] each time the signal with numnber - [signum] is received by the process. It returns a signal handler - identifier which can be used to stop monitoring [signum]. *) - -val disable_signal_handler : signal_handler_id -> unit - (** Stops receiving this signal *) - -val signal_count : unit -> int - (** Returns the number of registered signal handler. *) - -val reinstall_signal_handler : int -> unit - (** [reinstall_signal_handler signum] if any signal handler is - registered for this signal with {!on_signal}, it reinstall the - signal handler (with [Sys.set_signal]). This is usefull in case - another part of the program install another signal handler. *) - -(** {6 Sockets} *) - -type inet_addr = Unix.inet_addr - -type socket_domain = - Unix.socket_domain = - | PF_UNIX - | PF_INET - | PF_INET6 - -type socket_type = - Unix.socket_type = - | SOCK_STREAM - | SOCK_DGRAM - | SOCK_RAW - | SOCK_SEQPACKET - -type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int - -val socket : socket_domain -> socket_type -> int -> file_descr - (** [socket domain type proto] is the same as [Unix.socket] but maps - the result into a lwt {b file descriptor} *) - -val socketpair : socket_domain -> socket_type -> int -> file_descr * file_descr - (** Wrapper for [Unix.socketpair] *) - -val bind : file_descr -> sockaddr -> unit - (** Wrapper for [Unix.bind] *) - -val listen : file_descr -> int -> unit - (** Wrapper for [Unix.listen] *) - -val accept : file_descr -> (file_descr * sockaddr) Lwt.t - (** Wrapper for [Unix.accept] *) - -val accept_n : file_descr -> int -> ((file_descr * sockaddr) list * exn option) Lwt.t - (** [accept_n fd count] accepts up to [count] connection in one time. - - - if no connection is available right now, it returns a sleeping - thread - - - if more that 1 and less than [count] are available, it returns - all of them - - - if more that [count] are available, it returns the next - [count] of them - - - if an error happen, it returns the connections that have been - successfully accepted so far and the error - - [accept_n] has the advantage of improving performances. If you - want a more detailed description, you can have a look at: - - {{:http://portal.acm.org/citation.cfm?id=1247435}Acceptable strategies for improving web server performance} *) - -val connect : file_descr -> sockaddr -> unit Lwt.t - (** Wrapper for [Unix.connect] *) - -type shutdown_command = - Unix.shutdown_command = - | SHUTDOWN_RECEIVE - | SHUTDOWN_SEND - | SHUTDOWN_ALL - -val shutdown : file_descr -> shutdown_command -> unit - (** Wrapper for [Unix.shutdown] *) - -val getsockname : file_descr -> sockaddr - (** Wrapper for [Unix.getsockname] *) - -val getpeername : file_descr -> sockaddr - (** Wrapper for [Unix.getpeername] *) - -type msg_flag = - Unix.msg_flag = - | MSG_OOB - | MSG_DONTROUTE - | MSG_PEEK - -val recv : file_descr -> string -> int -> int -> msg_flag list -> int Lwt.t - (** Wrapper for [Unix.recv] *) - -val recvfrom : file_descr -> string -> int -> int -> msg_flag list -> (int * sockaddr) Lwt.t - (** Wrapper for [Unix.recvfrom] *) - -val send : file_descr -> string -> int -> int -> msg_flag list -> int Lwt.t - (** Wrapper for [Unix.send] *) - -val sendto : file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int Lwt.t - (** Wrapper for [Unix.sendto] *) - -(** An io-vector. Used by {!recv_msg} and {!send_msg}. *) -type io_vector = { - iov_buffer : string; - iov_offset : int; - iov_length : int; -} - -val io_vector : buffer : string -> offset : int -> length : int -> io_vector - (** Creates an io-vector *) - -val recv_msg : socket : file_descr -> io_vectors : io_vector list -> (int * Unix.file_descr list) Lwt.t - (** [recv_msg ~socket ~io_vectors] receives data into a list of - io-vectors, plus any file-descriptors that may accompany the - message. - - This call is not available on windows. *) - -val send_msg : socket : file_descr -> io_vectors : io_vector list -> fds : Unix.file_descr list -> int Lwt.t - (** [send_msg ~socket ~io_vectors ~fds] sends data from a list of - io-vectors, accompanied with a list of file-descriptor. If - fd-passing is not possible on the current system and [fds] is - not empty, it raises [Lwt_sys.Not_available "fd_passing"]. - - This call is not available on windows. *) - -type credentials = { - cred_pid : int; - cred_uid : int; - cred_gid : int; -} - -val get_credentials : file_descr -> credentials - (** [get_credentials fd] returns credential informations from the - given socket. *) - -(** {8 Socket options} *) - -type socket_bool_option = - Unix.socket_bool_option = - | SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - | TCP_NODELAY - | IPV6_ONLY - -type socket_int_option = - Unix.socket_int_option = - | SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = Unix.socket_optint_option = SO_LINGER - -type socket_float_option = - Unix.socket_float_option = - | SO_RCVTIMEO - | SO_SNDTIMEO - -val getsockopt : file_descr -> socket_bool_option -> bool - (** Wrapper for [Unix.getsockopt] *) - -val setsockopt : file_descr -> socket_bool_option -> bool -> unit - (** Wrapper for [Unix.setsockopt] *) - -val getsockopt_int : file_descr -> socket_int_option -> int - (** Wrapper for [Unix.getsockopt_int] *) - -val setsockopt_int : file_descr -> socket_int_option -> int -> unit - (** Wrapper for [Unix.setsockopt_int] *) - -val getsockopt_optint : file_descr -> socket_optint_option -> int option - (** Wrapper for [Unix.getsockopt_optint] *) - -val setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit - (** Wrapper for [Unix.setsockopt_optint] *) - -val getsockopt_float : file_descr -> socket_float_option -> float - (** Wrapper for [Unix.getsockopt_float] *) - -val setsockopt_float : file_descr -> socket_float_option -> float -> unit - (** Wrapper for [Unix.setsockopt_float] *) - -val getsockopt_error : file_descr -> Unix.error option - (** Wrapper for [Unix.getsockopt_error] *) - -(** {6 Host and protocol databases} *) - -type host_entry = - Unix.host_entry = - { - h_name : string; - h_aliases : string array; - h_addrtype : socket_domain; - h_addr_list : inet_addr array - } - -type protocol_entry = - Unix.protocol_entry = - { - p_name : string; - p_aliases : string array; - p_proto : int - } - -type service_entry = - Unix.service_entry = - { - s_name : string; - s_aliases : string array; - s_port : int; - s_proto : string - } - -val gethostname : unit -> string Lwt.t - (** Wrapper for [Unix.gethostname] *) - -val gethostbyname : string -> host_entry Lwt.t - (** Wrapper for [Unix.gethostbyname] *) - -val gethostbyaddr : inet_addr -> host_entry Lwt.t - (** Wrapper for [Unix.gethostbyaddr] *) - -val getprotobyname : string -> protocol_entry Lwt.t - (** Wrapper for [Unix.getprotobyname] *) - -val getprotobynumber : int -> protocol_entry Lwt.t - (** Wrapper for [Unix.getprotobynumber] *) - -val getservbyname : string -> string -> service_entry Lwt.t - (** Wrapper for [Unix.getservbyname] *) - -val getservbyport : int -> string -> service_entry Lwt.t - (** Wrapper for [Unix.getservbyport] *) - -type addr_info = - Unix.addr_info = - { - ai_family : socket_domain; - ai_socktype : socket_type; - ai_protocol : int; - ai_addr : sockaddr; - ai_canonname : string; - } - -type getaddrinfo_option = - Unix.getaddrinfo_option = - | AI_FAMILY of socket_domain - | AI_SOCKTYPE of socket_type - | AI_PROTOCOL of int - | AI_NUMERICHOST - | AI_CANONNAME - | AI_PASSIVE - -val getaddrinfo : string -> string -> getaddrinfo_option list -> addr_info list Lwt.t - (** Wrapper for [Unix.getaddrinfo] *) - -type name_info = - Unix.name_info = - { - ni_hostname : string; - ni_service : string; - } - -type getnameinfo_option = - Unix.getnameinfo_option = - | NI_NOFQDN - | NI_NUMERICHOST - | NI_NAMEREQD - | NI_NUMERICSERV - | NI_DGRAM - -val getnameinfo : sockaddr -> getnameinfo_option list -> name_info Lwt.t - (** Wrapper for [Unix.getnameinfo] *) - -(** {6 Terminal interface} *) - -type terminal_io = - Unix.terminal_io = - { - mutable c_ignbrk : bool; - mutable c_brkint : bool; - mutable c_ignpar : bool; - mutable c_parmrk : bool; - mutable c_inpck : bool; - mutable c_istrip : bool; - mutable c_inlcr : bool; - mutable c_igncr : bool; - mutable c_icrnl : bool; - mutable c_ixon : bool; - mutable c_ixoff : bool; - mutable c_opost : bool; - mutable c_obaud : int; - mutable c_ibaud : int; - mutable c_csize : int; - mutable c_cstopb : int; - mutable c_cread : bool; - mutable c_parenb : bool; - mutable c_parodd : bool; - mutable c_hupcl : bool; - mutable c_clocal : bool; - mutable c_isig : bool; - mutable c_icanon : bool; - mutable c_noflsh : bool; - mutable c_echo : bool; - mutable c_echoe : bool; - mutable c_echok : bool; - mutable c_echonl : bool; - mutable c_vintr : char; - mutable c_vquit : char; - mutable c_verase : char; - mutable c_vkill : char; - mutable c_veof : char; - mutable c_veol : char; - mutable c_vmin : int; - mutable c_vtime : int; - mutable c_vstart : char; - mutable c_vstop : char; - } - -val tcgetattr : file_descr -> terminal_io Lwt.t - (** Wrapper for [Unix.tcgetattr] *) - -type setattr_when = - Unix.setattr_when = - | TCSANOW - | TCSADRAIN - | TCSAFLUSH - -val tcsetattr : file_descr -> setattr_when -> terminal_io -> unit Lwt.t - (** Wrapper for [Unix.tcsetattr] *) - -val tcsendbreak : file_descr -> int -> unit Lwt.t - (** Wrapper for [Unix.tcsendbreak] *) - -val tcdrain : file_descr -> unit Lwt.t - (** Wrapper for [Unix.tcdrain] *) - -type flush_queue = - Unix.flush_queue = - | TCIFLUSH - | TCOFLUSH - | TCIOFLUSH - -val tcflush : file_descr -> flush_queue -> unit Lwt.t - (** Wrapper for [Unix.tcflush] *) - -type flow_action = - Unix.flow_action = - | TCOOFF - | TCOON - | TCIOFF - | TCION - -val tcflow : file_descr -> flow_action -> unit Lwt.t - (** Wrapper for [Unix.tcflow] *) - -(** {6 Low-level interaction} *) - -exception Retry - (** If an action raises {!Retry}, it will be requeued until the {b - file descriptor} becomes readable/writable again. *) - -exception Retry_read - (** If an action raises {!Retry_read}, it will be requeued until the - {b file descriptor} becomes readable. *) - -exception Retry_write - (** If an action raises {!Retry_read}, it will be requeued until the - {b file descriptor} becomes writables. *) - -type io_event = Read | Write - -val wrap_syscall : io_event -> file_descr -> (unit -> 'a) -> 'a Lwt.t - (** [wrap_syscall set fd action] wrap an action on a {b file - descriptor}. It tries to execture action, and if it can not be - performed immediately without blocking, it is registered for - latter. - - In the latter case, if the thread is canceled, [action] is - removed from [set]. *) - -val check_descriptor : file_descr -> unit - (** [check_descriptor fd] raise an exception if [fd] is not in the - state {!Open} *) - -val register_action : io_event -> file_descr -> (unit -> 'a) -> 'a Lwt.t - (** [register_action set fd action] registers [action] on [fd]. When - [fd] becomes [readable]/[writable] [action] is called. - - Note: - - - you must call [check_descriptor fd] before calling - [register_action] - - - you should prefer using {!wrap_syscall} - *) - -type 'a job - (** Type of jobs that run: - - - on another thread if the current async method is [Async_thread] - - on the main thread if the current async method is [Async_none]. *) - -val execute_job : - ?async_method : async_method -> - job : 'a job -> - result : ('a job -> 'b) -> - free : ('a job -> unit) -> 'b Lwt.t - (** [execute_job ?async_method ~job ~get ~free] starts - [job] and wait for its termination. - - [async_method] is how the job will be executed. It defaults to - the async method of the current thread. [result] is used to get - the result of the job, and [free] to free its associated - resources. *) - -val cancel_jobs : unit -> unit - (** [cancel_jobs ()] make all pending jobs to fail with - {!Lwt.Canceled}. *) - -val wait_for_jobs : unit -> unit Lwt.t - (** Wait for all pending jobs to terminate. *) - -(** {6 Notifications} *) - -(** Lwt internally use a pipe to send notification to the main - thread. The following functions allow to use this pipe. *) - -val make_notification : ?once : bool -> (unit -> unit) -> int - (** [new_notifier ?once f] registers a new notifier. It returns the - id of the notifier. Each time a notification with this id is - received, [f] is called. - - if [once] is specified, then the notification is stopped after - the first time it is received. It defaults to [false]. *) - -val send_notification : int -> unit - (** [send_notification id] sends a notification. - - This function is thread-safe. *) - -val stop_notification : int -> unit - (** Stop the given notification. Note that you should not reuse the - id after the notification has been stopped, the result is - unspecified if you do so. *) - -val set_notification : int -> (unit -> unit) -> unit - (** [set_notification id f] replace the function associated to the - notification by [f]. It raises [Not_found] if the given - notification is not found. *) - -(** {6 System threads pool} *) - -(** If the program is using the async method {!Async_detach} or - {!Async_switch}, Lwt will launch system threads to execute - blocking system calls asynchronously. *) - -val pool_size : unit -> int - (** Maximum number of system threads that can be started. If this - limit is reached, jobs will be executed synchronously. *) - -val set_pool_size : int -> unit - (** Change the size of the pool. *) - -val thread_count : unit -> int - (** The number of system threads running (excluding this one). *) - -val thread_waiting_count : unit -> int - (** The number threads waiting for a job. *) - -(** {6 CPUs} *) - -val get_cpu : unit -> int - (** [get_cpu ()] returns the number of the CPU the current thread is - running on. *) - -val get_affinity : ?pid : int -> unit -> int list - (** [get_affinity ?pid ()] returns the list of CPUs the process with - pid [pid] is allowed to run on. If [pid] is not specified then - the affinity of the current process is returned. *) - -val set_affinity : ?pid : int -> int list -> unit - (** [set_affinity ?pid cpus] sets the list of CPUs the given process - is allowed to run on. *) - -(**/**) - -val run : 'a Lwt.t -> 'a - (* Same as {!Lwt_main.run} *) - -val has_wait4 : bool - (* Deprecated, use [Lwt_sys.have `wait4]. *) diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix_stubs.c b/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix_stubs.c deleted file mode 100644 index 7571649..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix_stubs.c +++ /dev/null @@ -1,1377 +0,0 @@ -/* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_unix_stubs - * Copyright (C) 2009-2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - */ - -#if defined(_WIN32) || defined(_WIN64) -# include -# include -#endif - -#define _GNU_SOURCE -#define _POSIX_PTHREAD_SEMANTICS - -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include -#include -#include - -#include "lwt_config.h" -#include "lwt_unix.h" - -#if !defined(LWT_ON_WINDOWS) -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -#endif - -#if defined(HAVE_EVENTFD) -# include -#endif - -//#define DEBUG_MODE - -#if defined(DEBUG_MODE) -# include -# define DEBUG(fmt, ...) { fprintf(stderr, "lwt-debug[%d]: %s: " fmt "\n", (pid_t)syscall(SYS_gettid), __FUNCTION__, ##__VA_ARGS__); fflush(stderr); } -#else -# define DEBUG(fmt, ...) -#endif - -/* +-----------------------------------------------------------------+ - | OS-dependent functions | - +-----------------------------------------------------------------+ */ - -#if defined(LWT_ON_WINDOWS) -# include "lwt_unix_windows.c" -#else -# include "lwt_unix_unix.c" -#endif - -/* +-----------------------------------------------------------------+ - | Utils | - +-----------------------------------------------------------------+ */ - -void *lwt_unix_malloc(size_t size) -{ - void *ptr = malloc(size); - if (ptr == NULL) { - perror("cannot allocate memory"); - abort(); - } - return ptr; -} - -char *lwt_unix_strdup(char *str) -{ - char *new_str = strdup(str); - if (new_str == NULL) { - perror("cannot allocate memory"); - abort(); - } - return new_str; -} - -void lwt_unix_not_available(char const *feature) -{ - caml_raise_with_arg(*caml_named_value("lwt:not-available"), caml_copy_string(feature)); -} - -/* +-----------------------------------------------------------------+ - | Operation on bigarrays | - +-----------------------------------------------------------------+ */ - -CAMLprim value lwt_unix_blit_bytes_bytes(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) -{ - memmove((char*)Caml_ba_data_val(val_buf2) + Long_val(val_ofs2), - (char*)Caml_ba_data_val(val_buf1) + Long_val(val_ofs1), - Long_val(val_len)); - return Val_unit; -} - -CAMLprim value lwt_unix_blit_string_bytes(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) -{ - memcpy((char*)Caml_ba_data_val(val_buf2) + Long_val(val_ofs2), - String_val(val_buf1) + Long_val(val_ofs1), - Long_val(val_len)); - return Val_unit; -} - -CAMLprim value lwt_unix_blit_bytes_string(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) -{ - memcpy(String_val(val_buf2) + Long_val(val_ofs2), - (char*)Caml_ba_data_val(val_buf1) + Long_val(val_ofs1), - Long_val(val_len)); - return Val_unit; -} - -CAMLprim value lwt_unix_fill_bytes(value val_buf, value val_ofs, value val_len, value val_char) -{ - memset((char*)Caml_ba_data_val(val_buf) + Long_val(val_ofs), Int_val(val_char), Long_val(val_len)); - return Val_unit; -} - -CAMLprim value lwt_unix_mapped(value v_bstr) -{ - return Val_bool(Caml_ba_array_val(v_bstr)->flags & CAML_BA_MAPPED_FILE); -} - -/* +-----------------------------------------------------------------+ - | Byte order | - +-----------------------------------------------------------------+ */ - -value lwt_unix_system_byte_order() -{ -#ifdef ARCH_BIG_ENDIAN - return Val_int(1); -#else - return Val_int(0); -#endif -} - -/* +-----------------------------------------------------------------+ - | Threading | - +-----------------------------------------------------------------+ */ - -#if defined(LWT_ON_WINDOWS) - -void lwt_unix_launch_thread(void* (*start)(void*), void* data) -{ - HANDLE handle = CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start, data, 0, NULL); - if (handle) CloseHandle(handle); -} - -lwt_unix_thread lwt_unix_thread_self() -{ - return GetCurrentThreadId(); -} - -int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2) -{ - return thread1 == thread2; -} - -void lwt_unix_mutex_init(lwt_unix_mutex *mutex) -{ - InitializeCriticalSection(mutex); -} - -void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex) -{ - DeleteCriticalSection(mutex); -} - -void lwt_unix_mutex_lock(lwt_unix_mutex *mutex) -{ - EnterCriticalSection(mutex); -} - -void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex) -{ - LeaveCriticalSection(mutex); -} - -struct wait_list { - HANDLE event; - struct wait_list *next; -}; - -struct lwt_unix_condition { - CRITICAL_SECTION mutex; - struct wait_list *waiters; -}; - -void lwt_unix_condition_init(lwt_unix_condition *condition) -{ - InitializeCriticalSection(&condition->mutex); - condition->waiters = NULL; -} - -void lwt_unix_condition_destroy(lwt_unix_condition *condition) -{ - DeleteCriticalSection(&condition->mutex); -} - -void lwt_unix_condition_signal(lwt_unix_condition *condition) -{ - struct wait_list *node; - EnterCriticalSection(&condition->mutex); - - node = condition->waiters; - if (node) { - condition->waiters = node->next; - SetEvent(node->event); - } - LeaveCriticalSection(&condition->mutex); -} - -void lwt_unix_condition_broadcast(lwt_unix_condition *condition) -{ - struct wait_list *node; - EnterCriticalSection(&condition->mutex); - for (node = condition->waiters; node; node = node->next) - SetEvent(node->event); - condition->waiters = NULL; - LeaveCriticalSection(&condition->mutex); -} - -void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex) -{ - HANDLE event; - struct wait_list node; - - /* Create the event for the notification. */ - node.event = CreateEvent(NULL, FALSE, FALSE, NULL); - - /* Add the node to the condition. */ - EnterCriticalSection(&condition->mutex); - node.next = condition->waiters; - condition->waiters = &node; - LeaveCriticalSection(&condition->mutex); - - /* Release the mutex. */ - LeaveCriticalSection(mutex); - - /* Wait for a signal. */ - WaitForSingleObject(node.event, INFINITE); - - /* Re-acquire the mutex. */ - EnterCriticalSection(mutex); -} - -#else - -void lwt_unix_launch_thread(void* (*start)(void*), void* data) -{ - pthread_t thread; - pthread_attr_t attr; - int result; - - pthread_attr_init(&attr); - - /* The thread is created in detached state so we do not have to join - it when it terminates: */ - pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); - - result = pthread_create(&thread, &attr, start, data); - - if (result) unix_error(result, "launch_thread", Nothing); - - pthread_attr_destroy (&attr); -} - -lwt_unix_thread lwt_unix_thread_self() -{ - return pthread_self(); -} - -int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2) -{ - return pthread_equal(thread1, thread2); -} - -void lwt_unix_mutex_init(lwt_unix_mutex *mutex) -{ - pthread_mutex_init(mutex, NULL); -} - -void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex) -{ - pthread_mutex_destroy(mutex); -} - -void lwt_unix_mutex_lock(lwt_unix_mutex *mutex) -{ - pthread_mutex_lock(mutex); -} - -void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex) -{ - pthread_mutex_unlock(mutex); -} - -void lwt_unix_condition_init(lwt_unix_condition *condition) -{ - pthread_cond_init(condition, NULL); -} - -void lwt_unix_condition_destroy(lwt_unix_condition *condition) -{ - pthread_cond_destroy(condition); -} - -void lwt_unix_condition_signal(lwt_unix_condition *condition) -{ - pthread_cond_signal(condition); -} - -void lwt_unix_condition_broadcast(lwt_unix_condition *condition) -{ - pthread_cond_broadcast(condition); -} - -void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex) -{ - pthread_cond_wait(condition, mutex); -} - -#endif - -/* +-----------------------------------------------------------------+ - | Notifications | - +-----------------------------------------------------------------+ */ - -/* The mutex used to send and receive notifications. */ -static lwt_unix_mutex notification_mutex; - -/* All pending notifications. */ -static long *notifications = NULL; - -/* The size of the notification buffer. */ -static long notification_count = 0; - -/* The index to the next available cell in the notification buffer. */ -static long notification_index = 0; - -/* The mode currently used for notifications. */ -enum notification_mode { - /* Not yet initialized. */ - NOTIFICATION_MODE_NOT_INITIALIZED, - - /* Initialized but no mode defined. */ - NOTIFICATION_MODE_NONE, - - /* Using an eventfd. */ - NOTIFICATION_MODE_EVENTFD, - - /* Using a pipe. */ - NOTIFICATION_MODE_PIPE, - - /* Using a pair of sockets (only on windows). */ - NOTIFICATION_MODE_WINDOWS -}; - -/* The current notification mode. */ -static enum notification_mode notification_mode = NOTIFICATION_MODE_NOT_INITIALIZED; - -/* Send one notification. */ -static int (*notification_send)(); - -/* Read one notification. */ -static int (*notification_recv)(); - -static void init_notifications() -{ - lwt_unix_mutex_init(¬ification_mutex); - notification_count = 4096; - notifications = (long*)lwt_unix_malloc(notification_count * sizeof(long)); -} - -static void resize_notifications() -{ - long new_notification_count = notification_count * 2; - long *new_notifications = (long*)lwt_unix_malloc(new_notification_count * sizeof(long)); - memcpy((void*)new_notifications, (void*)notifications, notification_count * sizeof(long)); - free(notifications); - notifications = new_notifications; - notification_count = new_notification_count; -} - -void lwt_unix_send_notification(int id) -{ - int ret; - lwt_unix_mutex_lock(¬ification_mutex); - if (notification_index > 0) { - /* There is already a pending notification in the buffer, no - need to signal the main thread. */ - if (notification_index == notification_count) resize_notifications(); - notifications[notification_index++] = id; - } else { - /* There is none, notify the main thread. */ - notifications[notification_index++] = id; -#if defined(LWT_ON_WINDOWS) - ret = notification_send(); - if (ret == SOCKET_ERROR) { - lwt_unix_mutex_unlock(¬ification_mutex); - win32_maperr(WSAGetLastError()); - uerror("send_notification", Nothing); - } -#else - for (;;) { - ret = notification_send(); - if (ret < 0) { - if (errno != EINTR) { - lwt_unix_mutex_unlock(¬ification_mutex); - uerror("send_notification", Nothing); - } - } else - break; - } -#endif - } - lwt_unix_mutex_unlock(¬ification_mutex); -} - -value lwt_unix_send_notification_stub(value id) -{ - lwt_unix_send_notification(Long_val(id)); - return Val_unit; -} - -value lwt_unix_recv_notifications() -{ - int ret, i; - value result; - lwt_unix_mutex_lock(¬ification_mutex); - /* Receive the signal. */ -#if defined(LWT_ON_WINDOWS) - ret = notification_recv(); - if (ret == SOCKET_ERROR) { - lwt_unix_mutex_unlock(¬ification_mutex); - win32_maperr(WSAGetLastError()); - uerror("recv_notifications", Nothing); - } -#else - for (;;) { - ret = notification_recv(); - if (ret < 0) { - if (errno != EINTR) { - lwt_unix_mutex_unlock(¬ification_mutex); - uerror("recv_notifications", Nothing); - } - } else - break; - } -#endif - /* Read all pending notifications. */ - result = caml_alloc_tuple(notification_index); - for (i = 0; i < notification_index; i++) - Field(result, i) = Val_long(notifications[i]); - /* Reset the index. */ - notification_index = 0; - lwt_unix_mutex_unlock(¬ification_mutex); - return result; -} - -#if defined(LWT_ON_WINDOWS) - -static SOCKET set_close_on_exec(SOCKET socket) -{ - SOCKET new_socket; - if (!DuplicateHandle(GetCurrentProcess(), (HANDLE)socket, - GetCurrentProcess(), (HANDLE*)&new_socket, - 0L, FALSE, DUPLICATE_SAME_ACCESS)) { - win32_maperr(GetLastError()); - uerror("set_close_on_exec", Nothing); - } - closesocket(socket); - return new_socket; -} - -static SOCKET socket_r, socket_w; - -static int windows_notification_send() -{ - char buf; - return send(socket_w, &buf, 1, 0); -} - -static int windows_notification_recv() -{ - char buf; - return recv(socket_r, &buf, 1, 0); -} - -value lwt_unix_init_notification() -{ - union { - struct sockaddr_in inaddr; - struct sockaddr addr; - } a; - SOCKET listener; - int e; - int addrlen = sizeof(a.inaddr); - int reuse = 1; - DWORD err; - - switch (notification_mode) { - case NOTIFICATION_MODE_NOT_INITIALIZED: - notification_mode = NOTIFICATION_MODE_NONE; - init_notifications(); - break; - case NOTIFICATION_MODE_WINDOWS: - notification_mode = NOTIFICATION_MODE_NONE; - closesocket(socket_r); - closesocket(socket_w); - break; - case NOTIFICATION_MODE_NONE: - break; - default: - caml_failwith("notification system in unknown state"); - } - - /* Since pipes do not works with select, we need to use a pair of - sockets. The following code simulate the socketpair call of - unix. */ - - socket_r = INVALID_SOCKET; - socket_w = INVALID_SOCKET; - - listener = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); - if (listener == INVALID_SOCKET) - goto failure; - - memset(&a, 0, sizeof(a)); - a.inaddr.sin_family = AF_INET; - a.inaddr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); - a.inaddr.sin_port = 0; - - if (setsockopt(listener, SOL_SOCKET, SO_REUSEADDR, (char*) &reuse, sizeof(reuse)) == -1) - goto failure; - - if (bind(listener, &a.addr, sizeof(a.inaddr)) == SOCKET_ERROR) - goto failure; - - memset(&a, 0, sizeof(a)); - if (getsockname(listener, &a.addr, &addrlen) == SOCKET_ERROR) - goto failure; - - a.inaddr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); - a.inaddr.sin_family = AF_INET; - - if (listen(listener, 1) == SOCKET_ERROR) - goto failure; - - socket_r = WSASocket(AF_INET, SOCK_STREAM, 0, NULL, 0, WSA_FLAG_OVERLAPPED); - if (socket_r == INVALID_SOCKET) - goto failure; - - if (connect(socket_r, &a.addr, sizeof(a.inaddr)) == SOCKET_ERROR) - goto failure; - - socket_w = accept(listener, NULL, NULL); - if (socket_w == INVALID_SOCKET) - goto failure; - - closesocket(listener); - - socket_r = set_close_on_exec(socket_r); - socket_w = set_close_on_exec(socket_w); - notification_mode = NOTIFICATION_MODE_WINDOWS; - notification_send = windows_notification_send; - notification_recv = windows_notification_recv; - return win_alloc_socket(socket_r); - - failure: - err = WSAGetLastError(); - closesocket(listener); - closesocket(socket_r); - closesocket(socket_w); - win32_maperr(err); - uerror("init_notification", Nothing); - /* Just to make the compiler happy. */ - return Val_unit; -} - -#else /* defined(LWT_ON_WINDOWS) */ - -static void set_close_on_exec(int fd) -{ - int flags = fcntl(fd, F_GETFD, 0); - if (flags == -1 || fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1) - uerror("set_close_on_exec", Nothing); -} - -#if defined(HAVE_EVENTFD) - -static int notification_fd; - -static int eventfd_notification_send() -{ - uint64_t buf = 1; - return write(notification_fd, (char*)&buf, 8); -} - -static int eventfd_notification_recv() -{ - uint64_t buf; - return read(notification_fd, (char*)&buf, 8); -} - -#endif /* defined(HAVE_EVENTFD) */ - -static int notification_fds[2]; - -static int pipe_notification_send() -{ - char buf; - return write(notification_fds[1], &buf, 1); -} - -static int pipe_notification_recv() -{ - char buf; - return read(notification_fds[0], &buf, 1); -} - -value lwt_unix_init_notification() -{ - switch (notification_mode) { -#if defined(HAVE_EVENTFD) - case NOTIFICATION_MODE_EVENTFD: - notification_mode = NOTIFICATION_MODE_NONE; - if (close(notification_fd) == -1) uerror("close", Nothing); - break; -#endif - case NOTIFICATION_MODE_PIPE: - notification_mode = NOTIFICATION_MODE_NONE; - if (close(notification_fds[0]) == -1) uerror("close", Nothing); - if (close(notification_fds[1]) == -1) uerror("close", Nothing); - break; - case NOTIFICATION_MODE_NOT_INITIALIZED: - notification_mode = NOTIFICATION_MODE_NONE; - init_notifications(); - break; - case NOTIFICATION_MODE_NONE: - break; - default: - caml_failwith("notification system in unknown state"); - } - -#if defined(HAVE_EVENTFD) - notification_fd = eventfd(0, 0); - if (notification_fd != -1) { - notification_mode = NOTIFICATION_MODE_EVENTFD; - notification_send = eventfd_notification_send; - notification_recv = eventfd_notification_recv; - set_close_on_exec(notification_fd); - return Val_int(notification_fd); - } -#endif - - if (pipe(notification_fds) == -1) uerror("pipe", Nothing); - set_close_on_exec(notification_fds[0]); - set_close_on_exec(notification_fds[1]); - notification_mode = NOTIFICATION_MODE_PIPE; - notification_send = pipe_notification_send; - notification_recv = pipe_notification_recv; - return Val_int(notification_fds[0]); -} - -#endif /* defined(LWT_ON_WINDOWS) */ - -/* +-----------------------------------------------------------------+ - | Job execution | - +-----------------------------------------------------------------+ */ - -/* Execute the given job. */ -static void execute_job(lwt_unix_job job) -{ - DEBUG("executing the job"); - - lwt_unix_mutex_lock(&job->mutex); - - /* If the job has been canceled, do nothing. */ - if (job->state == LWT_UNIX_JOB_STATE_CANCELED) { - lwt_unix_mutex_unlock(&job->mutex); - return; - } - - /* Mark the job as running. */ - job->state = LWT_UNIX_JOB_STATE_RUNNING; - - /* Set the thread of the job. */ - job->thread = lwt_unix_thread_self(); - - lwt_unix_mutex_unlock(&job->mutex); - - /* Execute the job. */ - job->worker(job); - - DEBUG("job done"); - - lwt_unix_mutex_lock(&job->mutex); - - DEBUG("marking the job has done"); - - /* Job is done. If the main thread stopped until now, asynchronous - notification is not necessary. */ - job->state = LWT_UNIX_JOB_STATE_DONE; - - /* Send a notification if the main thread continued its execution - before the job terminated. */ - if (job->fast == 0) { - lwt_unix_mutex_unlock(&job->mutex); - DEBUG("notifying the main thread"); - lwt_unix_send_notification(job->notification_id); - } else { - lwt_unix_mutex_unlock(&job->mutex); - DEBUG("not notifying the main thread"); - } -} - -/* +-----------------------------------------------------------------+ - | Config | - +-----------------------------------------------------------------+ */ - -/* The signal used to allocate new stack. */ -static int signal_alloc_stack = -1; - -/* The signal used to kill a thread. */ -static int signal_kill_thread = -1; - -/* +-----------------------------------------------------------------+ - | Thread pool | - +-----------------------------------------------------------------+ */ - -/* Number of thread waiting for a job in the pool. */ -static int thread_waiting_count = 0; - -/* Number of started threads. */ -static int thread_count = 0; - -/* Maximum number of system threads that can be started. */ -static int pool_size = 1000; - -/* Condition on which pool threads are waiting. */ -static lwt_unix_condition pool_condition; - -/* Queue of pending jobs. It points to the last enqueued job. */ -static lwt_unix_job pool_queue = NULL; - -/* The mutex which protect access to [pool_queue], [pool_condition] - and [thread_waiting_count]. */ -static lwt_unix_mutex pool_mutex; - -/* +-----------------------------------------------------------------+ - | Thread switching | - +-----------------------------------------------------------------+ */ - -/* Possible states of the main thread (i.e. the one executing the - ocaml code). */ -enum main_state { - /* The main thread is running. */ - STATE_RUNNING, - - /* The main thread is doing a blocking call that has not yet - terminated. */ - STATE_BLOCKED, -}; - -/* State of the main thread. */ -static enum main_state main_state = STATE_RUNNING; - -/* The main thread. */ -static lwt_unix_thread main_thread; - -/* A node in a list of stack frames. */ -struct stack_frame { - /* The stack frame itself. */ - jmp_buf checkpoint; - - /* The next available one. */ - struct stack_frame *next; -}; - -/* Stack frames available to do a blocking call. */ -static struct stack_frame *blocking_call_enter = NULL; - -/* Mutex to protect access to [blocking_call_enter]. */ -static lwt_unix_mutex blocking_call_enter_mutex; - -/* Where to go when the blocking call is done, or when it get - scheduled. */ -static jmp_buf blocking_call_leave; - -/* Where to go to become a worjer */ -static struct stack_frame *become_worker = NULL; - -/* Value returned to the main thread when a blocking call terminates - without being scheduled. */ -#define CALL_SUCCEEDED 1 - -/* Value returned to the old main thread whan a blocking call - terminates but has been scheduled. */ -#define CALL_SCHEDULED 2 - -/* The job to be executed on the first available alternative stack. */ -static lwt_unix_job blocking_call = NULL; - -/* The stack frame used for the current blocking call. */ -static struct stack_frame *blocking_call_frame = NULL; - -/* Flag which become [1] once the stack has been allocated. */ -static int stack_allocated; - -/* Function executed on an alternative stack. */ -static void altstack_worker() -{ - struct stack_frame *node; - jmp_buf buf; - - if (stack_allocated == 1) return; - stack_allocated = 1; - - /* The first passage is to register a new stack frame. */ - node = lwt_unix_new(struct stack_frame); - - if (setjmp(node->checkpoint) == 0) { - - /* Add it to the list of available stack frames. */ - lwt_unix_mutex_lock(&blocking_call_enter_mutex); - node->next = blocking_call_enter; - blocking_call_enter = node; - lwt_unix_mutex_unlock(&blocking_call_enter_mutex); - - } else { - - /* Save the job to execute and the current stack frame before - another thread can become the main thread. */ - lwt_unix_job job = blocking_call; - struct stack_frame *frame = blocking_call_frame; - - /* Mark the main thread as blocked. */ - main_state = STATE_BLOCKED; - - DEBUG("signaling the pool condition variable"); - - /* Maybe wakeup a worker so it can become the main thread. */ - lwt_unix_mutex_lock(&pool_mutex); - lwt_unix_condition_signal(&pool_condition); - lwt_unix_mutex_unlock(&pool_mutex); - - DEBUG("executing the blocking call"); - - /* Execute the blocking call. */ - execute_job(job); - - DEBUG("blocking call done"); - - lwt_unix_mutex_lock(&pool_mutex); - - if (lwt_unix_thread_equal(main_thread, lwt_unix_thread_self())) { - /* We stayed the main thread, continue the execution - normally. */ - main_state = STATE_RUNNING; - - lwt_unix_mutex_unlock(&pool_mutex); - - DEBUG("blocing call terminated without blocking, resuming"); - - /* Leave the blocking call. */ - longjmp(blocking_call_leave, CALL_SUCCEEDED); - } else { - /* We did not stayed the main thread, we now become a worker. */ - - assert(become_worker != NULL); - - /* Take and remove the first worker checkpoint. */ - node = become_worker; - become_worker = node->next; - - lwt_unix_mutex_unlock(&pool_mutex); - - DEBUG("blocking call terminated after blocking, becoming a worker"); - - /* Add the stack frame used for this call to the list of - available ones. */ - lwt_unix_mutex_lock(&blocking_call_enter_mutex); - frame->next = blocking_call_enter; - blocking_call_enter = frame; - /* Release the mutex only after the jump. */ - - memcpy(&buf, &(node->checkpoint), sizeof(jmp_buf)); - free(node); - longjmp(buf, 1); - } - } -} - -#define STACK_SIZE (256 * 1024) - -/* Allocate a new stack for doing blocking calls. */ -void alloc_new_stack() -{ -#if !defined(LWT_ON_WINDOWS) - DEBUG("allocate a new stack"); - - stack_t old_stack, new_stack; - struct sigaction old_sa, new_sa; - - /* Create the new stack. */ - new_stack.ss_flags = 0; - new_stack.ss_size = STACK_SIZE; - new_stack.ss_sp = lwt_unix_malloc(STACK_SIZE); - - /* Change the stack used for signals. */ - sigaltstack(&new_stack, &old_stack); - - stack_allocated = 0; - - /* Set up the custom signal handler. */ - new_sa.sa_handler = altstack_worker; - new_sa.sa_flags = SA_ONSTACK; - sigemptyset(&new_sa.sa_mask); - sigaction(signal_alloc_stack, &new_sa, &old_sa); - - /* Save the stack frame. */ - raise(signal_alloc_stack); - - /* Restore the old signal handler. */ - sigaction(signal_alloc_stack, &old_sa, NULL); - - /* Restore the old alternative stack. */ - sigaltstack(&old_stack, NULL); -#endif -} - -/* +-----------------------------------------------------------------+ - | Threading stuff initialization | - +-----------------------------------------------------------------+ */ - -/* Whether threading has been initialized. */ -static int threading_initialized = 0; - -static void nop() {} - -#if !defined(SIGRTMIN) || !defined(SIGRTMAX) -# define SIGRTMIN 0 -# define SIGRTMAX 0 -#endif - -/* Initialize the pool of thread. */ -void initialize_threading() -{ - if (threading_initialized == 0) { - lwt_unix_mutex_init(&pool_mutex); - lwt_unix_condition_init(&pool_condition); - lwt_unix_mutex_init(&blocking_call_enter_mutex); - - main_thread = lwt_unix_thread_self(); - -#if !defined(LWT_ON_WINDOWS) - if (SIGRTMIN < SIGRTMAX) { - signal_alloc_stack = SIGRTMIN; - if (SIGRTMIN + 1 < SIGRTMAX) - signal_kill_thread = SIGRTMIN + 1; - else - signal_kill_thread = SIGUSR1; - } else { - signal_alloc_stack = SIGUSR1; - signal_kill_thread = SIGUSR2; - } - - /* Define a handler for the signal used for killing threads to be - sure system calls get interrupted. */ - struct sigaction sa; - sa.sa_handler = nop; - sa.sa_flags = 0; - sigemptyset(&sa.sa_mask); - sigaction(signal_kill_thread, &sa, NULL); -#endif - - threading_initialized = 1; - } -} - -/* +-----------------------------------------------------------------+ - | Worker loop | - +-----------------------------------------------------------------+ */ - -/* Function executed by threads of the pool. */ -static void* worker_loop(void *data) -{ - lwt_unix_job job = (lwt_unix_job)data; - struct stack_frame *node; - - /* Execute the initial job if any. */ - if (job != NULL) execute_job(job); - - while (1) { - DEBUG("entering waiting section"); - - lwt_unix_mutex_lock(&pool_mutex); - - /* One more thread is waiting for work. */ - thread_waiting_count++; - - DEBUG("waiting for something to do"); - - /* Wait for something to do. */ - while (pool_queue == NULL && main_state == STATE_RUNNING) - lwt_unix_condition_wait(&pool_condition, &pool_mutex); - - DEBUG("received something to do"); - - /* This thread is busy. */ - thread_waiting_count--; - - if (main_state == STATE_BLOCKED) { - DEBUG("main thread is blocked"); - DEBUG("\e[1;31mswitching\e[0m"); - - /* If the main thread is blocked, we become the main thread. */ - main_thread = lwt_unix_thread_self(); - - /* The new main thread is running again. */ - main_state = STATE_RUNNING; - - node = lwt_unix_new(struct stack_frame); - - /* Save the stack frame so the old main thread can become a - worker when the blocking call terminates. */ - if (setjmp(node->checkpoint) == 0) { - DEBUG("checkpoint for future worker done"); - - /* Save the stack frame in the list of worker checkpoints. */ - node->next = become_worker; - become_worker = node; - - DEBUG("going back to the ocaml code"); - - /* Go to before the blocking call. */ - longjmp(blocking_call_leave, CALL_SCHEDULED); - } - - DEBUG("transformation to worker done"); - - /* This thread is not running caml code anymore. */ - //caml_c_thread_unregister(); - - /* Release this mutex. It was locked before the jump. */ - lwt_unix_mutex_unlock(&blocking_call_enter_mutex); - - } else { - DEBUG("taking a job to execute"); - - /* Take the first queued job. */ - job = pool_queue->next; - - /* Remove it from the queue. */ - if (job->next == job) - pool_queue = NULL; - else - pool_queue->next = job->next; - - lwt_unix_mutex_unlock(&pool_mutex); - - /* Execute the job. */ - execute_job(job); - } - } - - return NULL; -} - -/* +-----------------------------------------------------------------+ - | Jobs | - +-----------------------------------------------------------------+ */ - -/* Description of jobs. */ -struct custom_operations job_ops = { - "lwt.unix.job", - custom_finalize_default, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -/* Get the job structure contained in a custom value. */ -#define Job_val(v) *(lwt_unix_job*)Data_custom_val(v) - -value lwt_unix_alloc_job(lwt_unix_job job) -{ - value val_job = caml_alloc_custom(&job_ops, sizeof(lwt_unix_job), 0, 1); - Job_val(val_job) = job; - return val_job; -} - -void lwt_unix_free_job(lwt_unix_job job) -{ - if (job->async_method != LWT_UNIX_ASYNC_METHOD_NONE) - lwt_unix_mutex_destroy(&job->mutex); - free(job); -} - -CAMLprim value lwt_unix_start_job(value val_job, value val_async_method) -{ - lwt_unix_job job = Job_val(val_job); - struct stack_frame *node; - lwt_unix_async_method async_method = Int_val(val_async_method); - - /* Fallback to synchronous call if there is no worker available and - we can not launch more threads. */ - if (async_method != LWT_UNIX_ASYNC_METHOD_NONE && thread_waiting_count == 0 && thread_count >= pool_size) - async_method = LWT_UNIX_ASYNC_METHOD_NONE; - - /* Initialises job parameters. */ - job->state = LWT_UNIX_JOB_STATE_PENDING; - job->fast = 1; - job->async_method = async_method; - - switch (async_method) { - - case LWT_UNIX_ASYNC_METHOD_NONE: - /* Execute the job synchronously. */ - caml_enter_blocking_section(); - job->worker(job); - caml_leave_blocking_section(); - return Val_true; - - case LWT_UNIX_ASYNC_METHOD_DETACH: - if (threading_initialized == 0) initialize_threading(); - - lwt_unix_mutex_init(&job->mutex); - - lwt_unix_mutex_lock(&pool_mutex); - if (thread_waiting_count == 0) { - /* Launch a new worker. */ - thread_count++; - lwt_unix_mutex_unlock(&pool_mutex); - lwt_unix_launch_thread(worker_loop, (void*)job); - } else { - /* Add the job at the end of the queue. */ - if (pool_queue == NULL) { - pool_queue = job; - job->next = job; - } else { - job->next = pool_queue->next; - pool_queue->next = job; - pool_queue = job; - } - /* Wakeup one worker. */ - lwt_unix_condition_signal(&pool_condition); - lwt_unix_mutex_unlock(&pool_mutex); - } - return Val_bool(job->state == LWT_UNIX_JOB_STATE_DONE); - - case LWT_UNIX_ASYNC_METHOD_SWITCH: -#if defined(LWT_ON_WINDOWS) - caml_invalid_argument("the switch method is not implemented on windows"); -#endif - - if (threading_initialized == 0) initialize_threading(); - - lwt_unix_mutex_init(&job->mutex); - job->thread = main_thread; - - /* Ensures there is at least one thread that can become the main - thread. */ - if (thread_waiting_count == 0) { - thread_count++; - lwt_unix_launch_thread(worker_loop, NULL); - } - - if (blocking_call_enter == NULL) alloc_new_stack(); - - DEBUG("taking a stack frame for doing a blocking call"); - - /* Take and remove the first available stack frame for system - calls. */ - lwt_unix_mutex_lock(&blocking_call_enter_mutex); - assert(blocking_call_enter != NULL); - node = blocking_call_enter; - blocking_call_enter = node->next; - lwt_unix_mutex_unlock(&blocking_call_enter_mutex); - - /* Save the stack frame to leave the blocking call. */ - switch (setjmp(blocking_call_leave)) { - case 0: - /* Save the job to do. */ - blocking_call = job; - - /* Save the stack frame that will be used for this call in case - it get scheduled. */ - blocking_call_frame = node; - - DEBUG("jumping to do a blocking call"); - - /* Jump to an alternative stack and do the call. */ - longjmp(node->checkpoint, 1); - - case CALL_SUCCEEDED: - DEBUG("resuming without being scheduled"); - - /* Re-add the stack frame used for the call to the list of - available ones. */ - lwt_unix_mutex_lock(&blocking_call_enter_mutex); - node->next = blocking_call_enter; - blocking_call_enter = node; - lwt_unix_mutex_unlock(&blocking_call_enter_mutex); - return Val_true; - - case CALL_SCHEDULED: - DEBUG("resuming after being scheduled"); - - /* This mutex was locked before we did the jump. */ - lwt_unix_mutex_unlock(&pool_mutex); - - /* This thread is now running caml code. */ - //caml_c_thread_register(); - return Val_bool(job->state == LWT_UNIX_JOB_STATE_DONE); - } - } - - return Val_false; -} - -CAMLprim value lwt_unix_check_job(value val_job, value val_notification_id) -{ - lwt_unix_job job = Job_val(val_job); - value result; - - DEBUG("checking job"); - - switch (job->async_method) { - - case LWT_UNIX_ASYNC_METHOD_NONE: - return Val_int(1); - - case LWT_UNIX_ASYNC_METHOD_DETACH: - case LWT_UNIX_ASYNC_METHOD_SWITCH: - lwt_unix_mutex_lock(&job->mutex); - /* We are not waiting anymore. */ - job->fast = 0; - /* Set the notification id for asynchronous wakeup. */ - job->notification_id = Int_val(val_notification_id); - result = Val_bool(job->state == LWT_UNIX_JOB_STATE_DONE); - lwt_unix_mutex_unlock(&job->mutex); - - DEBUG("job done: %d", Int_val(result)); - - return result; - } - - return Val_int(0); -} - -CAMLprim value lwt_unix_cancel_job(value val_job) -{ - struct lwt_unix_job *job = Job_val(val_job); - - DEBUG("cancelling job"); - - switch (job->async_method) { - - case LWT_UNIX_ASYNC_METHOD_NONE: - break; - - case LWT_UNIX_ASYNC_METHOD_DETACH: - case LWT_UNIX_ASYNC_METHOD_SWITCH: - lwt_unix_mutex_lock(&job->mutex); - switch (job->state) { - case LWT_UNIX_JOB_STATE_PENDING: - /* The job has not yet started, mark it as canceled. */ - job->state = LWT_UNIX_JOB_STATE_CANCELED; - break; - - case LWT_UNIX_JOB_STATE_RUNNING: -#if !defined(LWT_ON_WINDOWS) - /* The job is running, kill it. */ - if (signal_kill_thread >= 0) - pthread_kill(job->thread, signal_kill_thread); -#endif - break; - - case LWT_UNIX_JOB_STATE_DONE: - /* The job is done, do nothing. */ - break; - - case LWT_UNIX_JOB_STATE_CANCELED: - /* Not possible. */ - break; - } - lwt_unix_mutex_unlock(&job->mutex); - break; - } - - return Val_unit; -} - -CAMLprim value lwt_unix_reset_after_fork() -{ - if (threading_initialized) { - /* Reset the main thread. */ - main_thread = lwt_unix_thread_self (); - - /* There is no more waiting threads. */ - thread_waiting_count = 0; - - /* There is no more threads. */ - thread_count = 0; - - /* Empty the queue. */ - pool_queue = NULL; - } - - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | Statistics and control | - +-----------------------------------------------------------------+ */ - -CAMLprim value lwt_unix_pool_size() -{ - return Val_int(pool_size); -} - -CAMLprim value lwt_unix_set_pool_size(value val_size) -{ - pool_size = Int_val(val_size); - return Val_unit; -} - -CAMLprim value lwt_unix_thread_count() -{ - return Val_int(thread_count); -} - -CAMLprim value lwt_unix_thread_waiting_count() -{ - return Val_int(thread_waiting_count); -} diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix_unix.c b/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix_unix.c deleted file mode 100644 index 4dccc6a..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix_unix.c +++ /dev/null @@ -1,3864 +0,0 @@ -/* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_unix_unix - * Copyright (C) 2009-2010 Jérémie Dimino - * 2009 Mauricio Fernandez - * 2010 Pierre Chambart - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - */ - -/* Unix (non windows) version of stubs. */ - -/* +-----------------------------------------------------------------+ - | Test for readability/writability | - +-----------------------------------------------------------------+ */ - -#include - -CAMLprim value lwt_unix_readable(value fd) -{ - struct pollfd pollfd; - pollfd.fd = Int_val(fd); - pollfd.events = POLLIN; - pollfd.revents = 0; - if (poll(&pollfd, 1, 0) < 0) - uerror("readable", Nothing); - return (Val_bool(pollfd.revents & POLLIN)); -} - -CAMLprim value lwt_unix_writable(value fd) -{ - struct pollfd pollfd; - pollfd.fd = Int_val(fd); - pollfd.events = POLLOUT; - pollfd.revents = 0; - if (poll(&pollfd, 1, 0) < 0) - uerror("readable", Nothing); - return (Val_bool(pollfd.revents & POLLOUT)); -} - -/* +-----------------------------------------------------------------+ - | Memory mapped files | - +-----------------------------------------------------------------+ */ - -static int advise_table[] = { - MADV_NORMAL, - MADV_RANDOM, - MADV_SEQUENTIAL, - MADV_WILLNEED, - MADV_DONTNEED, -}; - -CAMLprim value lwt_unix_madvise (value val_buffer, value val_offset, value val_length, value val_advice) -{ - int ret = madvise((char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset), - Long_val(val_length), - advise_table[Int_val(val_advice)]); - if (ret == -1) uerror("madvise", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_get_page_size() -{ - long page_size = sysconf(_SC_PAGESIZE); - if (page_size < 0) page_size = 4096; - return Val_long(page_size); -} - -CAMLprim value lwt_unix_mincore(value val_buffer, value val_offset, value val_length, value val_states) -{ - long len = Wosize_val(val_states); - unsigned char vec[len]; - mincore((char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset), Long_val(val_length), vec); - long i; - for (i = 0; i < len; i++) - Field(val_states, i) = Val_bool(vec[i] & 1); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | read/write | - +-----------------------------------------------------------------+ */ - -CAMLprim value lwt_unix_read(value val_fd, value val_buf, value val_ofs, value val_len) -{ - int ret; - ret = read(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len)); - if (ret == -1) uerror("read", Nothing); - return Val_int(ret); -} - -CAMLprim value lwt_unix_bytes_read(value val_fd, value val_buf, value val_ofs, value val_len) -{ - int ret; - ret = read(Int_val(val_fd), (char*)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs), Long_val(val_len)); - if (ret == -1) uerror("read", Nothing); - return Val_int(ret); -} - -CAMLprim value lwt_unix_write(value val_fd, value val_buf, value val_ofs, value val_len) -{ - int ret; - ret = write(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len)); - if (ret == -1) uerror("write", Nothing); - return Val_int(ret); -} - -CAMLprim value lwt_unix_bytes_write(value val_fd, value val_buf, value val_ofs, value val_len) -{ - int ret; - ret = write(Int_val(val_fd), (char*)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs), Long_val(val_len)); - if (ret == -1) uerror("write", Nothing); - return Val_int(ret); -} - -/* +-----------------------------------------------------------------+ - | recv/send | - +-----------------------------------------------------------------+ */ - -static int msg_flag_table[] = { - MSG_OOB, MSG_DONTROUTE, MSG_PEEK -}; - -value lwt_unix_recv(value fd, value buf, value ofs, value len, value flags) -{ - int ret; - ret = recv(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), - convert_flag_list(flags, msg_flag_table)); - if (ret == -1) uerror("recv", Nothing); - return Val_int(ret); -} - -value lwt_unix_bytes_recv(value fd, value buf, value ofs, value len, value flags) -{ - int ret; - ret = recv(Int_val(fd), (char*)Caml_ba_array_val(buf)->data + Long_val(ofs), Long_val(len), - convert_flag_list(flags, msg_flag_table)); - if (ret == -1) uerror("recv", Nothing); - return Val_int(ret); -} - -value lwt_unix_send(value fd, value buf, value ofs, value len, value flags) -{ - int ret; - ret = send(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), - convert_flag_list(flags, msg_flag_table)); - if (ret == -1) uerror("send", Nothing); - return Val_int(ret); -} - -value lwt_unix_bytes_send(value fd, value buf, value ofs, value len, value flags) -{ - int ret; - ret = send(Int_val(fd), (char*)Caml_ba_array_val(buf)->data + Long_val(ofs), Long_val(len), - convert_flag_list(flags, msg_flag_table)); - if (ret == -1) uerror("send", Nothing); - return Val_int(ret); -} - -/* +-----------------------------------------------------------------+ - | recvfrom/sendto | - +-----------------------------------------------------------------+ */ - -extern int socket_domain_table[]; -extern int socket_type_table[]; - -union sock_addr_union { - struct sockaddr s_gen; - struct sockaddr_un s_unix; - struct sockaddr_in s_inet; - struct sockaddr_in6 s_inet6; -}; - -CAMLexport value alloc_sockaddr (union sock_addr_union * addr /*in*/, - socklen_t addr_len, int close_on_error); - -value lwt_unix_recvfrom(value fd, value buf, value ofs, value len, value flags) -{ - CAMLparam5(fd, buf, ofs, len, flags); - CAMLlocal2(result, address); - int ret; - union sock_addr_union addr; - socklen_t addr_len; - addr_len = sizeof(addr); - ret = recvfrom(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), - convert_flag_list(flags, msg_flag_table), - &addr.s_gen, &addr_len); - if (ret == -1) uerror("recvfrom", Nothing); - address = alloc_sockaddr(&addr, addr_len, -1); - result = caml_alloc_tuple(2); - Field(result, 0) = Val_int(ret); - Field(result, 1) = address; - CAMLreturn(result); -} - -value lwt_unix_bytes_recvfrom(value fd, value buf, value ofs, value len, value flags) -{ - CAMLparam5(fd, buf, ofs, len, flags); - CAMLlocal2(result, address); - int ret; - union sock_addr_union addr; - socklen_t addr_len; - addr_len = sizeof(addr); - ret = recvfrom(Int_val(fd), (char*)Caml_ba_data_val(buf) + Long_val(ofs), Long_val(len), - convert_flag_list(flags, msg_flag_table), - &addr.s_gen, &addr_len); - if (ret == -1) uerror("recvfrom", Nothing); - address = alloc_sockaddr(&addr, addr_len, -1); - result = caml_alloc_tuple(2); - Field(result, 0) = Val_int(ret); - Field(result, 1) = address; - CAMLreturn(result); -} - -extern void get_sockaddr (value mladdr, - union sock_addr_union * addr /*out*/, - socklen_t * addr_len /*out*/); - -value lwt_unix_sendto(value fd, value buf, value ofs, value len, value flags, value dest) -{ - union sock_addr_union addr; - socklen_t addr_len; - int ret; - get_sockaddr(dest, &addr, &addr_len); - ret = sendto(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), - convert_flag_list(flags, msg_flag_table), - &addr.s_gen, addr_len); - if (ret == -1) uerror("send", Nothing); - return Val_int(ret); -} - -CAMLprim value lwt_unix_sendto_byte(value *argv, int argc) -{ - return lwt_unix_sendto(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value lwt_unix_bytes_sendto(value fd, value buf, value ofs, value len, value flags, value dest) -{ - union sock_addr_union addr; - socklen_t addr_len; - int ret; - get_sockaddr(dest, &addr, &addr_len); - ret = sendto(Int_val(fd), (char*)Caml_ba_data_val(buf) + Long_val(ofs), Long_val(len), - convert_flag_list(flags, msg_flag_table), - &addr.s_gen, addr_len); - if (ret == -1) uerror("send", Nothing); - return Val_int(ret); -} - -CAMLprim value lwt_unix_bytes_sendto_byte(value *argv, int argc) -{ - return lwt_unix_bytes_sendto(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -/* +-----------------------------------------------------------------+ - | {recv/send}_msg | - +-----------------------------------------------------------------+ */ - -/* Convert a caml list of io-vectors into a C array io io-vector - structures */ -static void store_iovs(struct iovec *iovs, value iovs_val) -{ - CAMLparam0(); - CAMLlocal2(list, x); - for(list = iovs_val; Is_block(list); list = Field(list, 1), iovs++) { - x = Field(list, 0); - iovs->iov_base = &Byte(String_val(Field(x, 0)), Long_val(Field(x, 1))); - iovs->iov_len = Long_val(Field(x, 2)); - } - CAMLreturn0; -} - -static void bytes_store_iovs(struct iovec *iovs, value iovs_val) -{ - CAMLparam0(); - CAMLlocal2(list, x); - for(list = iovs_val; Is_block(list); list = Field(list, 1), iovs++) { - x = Field(list, 0); - iovs->iov_base = (char*)Caml_ba_data_val(Field(x, 0)) + Long_val(Field(x, 1)); - iovs->iov_len = Long_val(Field(x, 2)); - } - CAMLreturn0; -} - -static value wrapper_recv_msg(int fd, int n_iovs, struct iovec *iovs) -{ - CAMLparam0(); - CAMLlocal3(list, result, x); - - struct msghdr msg; - memset(&msg, 0, sizeof(msg)); - msg.msg_iov = iovs; - msg.msg_iovlen = n_iovs; -#if defined(HAVE_FD_PASSING) - msg.msg_controllen = CMSG_SPACE(256 * sizeof(int)); - msg.msg_control = alloca(msg.msg_controllen); - memset(msg.msg_control, 0, msg.msg_controllen); -#endif - - int ret = recvmsg(fd, &msg, 0); - if (ret == -1) uerror("recv_msg", Nothing); - - list = Val_int(0); -#if defined(HAVE_FD_PASSING) - struct cmsghdr *cm; - for (cm = CMSG_FIRSTHDR(&msg); cm; cm = CMSG_NXTHDR(&msg, cm)) - if (cm->cmsg_level == SOL_SOCKET && cm->cmsg_type == SCM_RIGHTS) { - int *fds = (int*)CMSG_DATA(cm); - int nfds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int); - int i; - for(i = nfds - 1; i >= 0; i--) { - x = caml_alloc_tuple(2); - Store_field(x, 0, Val_int(fds[i])); - Store_field(x, 1, list); - list = x; - }; - break; - }; -#endif - - result = caml_alloc_tuple(2); - Store_field(result, 0, Val_int(ret)); - Store_field(result, 1, list); - CAMLreturn(result); -} - -CAMLprim value lwt_unix_recv_msg(value val_fd, value val_n_iovs, value val_iovs) -{ - int n_iovs = Int_val(val_n_iovs); - struct iovec iovs[n_iovs]; - store_iovs(iovs, val_iovs); - return wrapper_recv_msg(Int_val(val_fd), n_iovs, iovs); -} - -CAMLprim value lwt_unix_bytes_recv_msg(value val_fd, value val_n_iovs, value val_iovs) -{ - int n_iovs = Int_val(val_n_iovs); - struct iovec iovs[n_iovs]; - bytes_store_iovs(iovs, val_iovs); - return wrapper_recv_msg(Int_val(val_fd), n_iovs, iovs); -} - -static value wrapper_send_msg(int fd, int n_iovs, struct iovec *iovs, value val_n_fds, value val_fds) -{ - CAMLparam2(val_n_fds, val_fds); - - struct msghdr msg; - memset(&msg, 0, sizeof(msg)); - msg.msg_iov = iovs; - msg.msg_iovlen = n_iovs; - - int n_fds = Int_val(val_n_fds); -#if defined(HAVE_FD_PASSING) - if (n_fds > 0) { - msg.msg_controllen = CMSG_SPACE(n_fds * sizeof(int)); - msg.msg_control = alloca(msg.msg_controllen); - memset(msg.msg_control, 0, msg.msg_controllen); - - struct cmsghdr *cm; - cm = CMSG_FIRSTHDR(&msg); - cm->cmsg_level = SOL_SOCKET; - cm->cmsg_type = SCM_RIGHTS; - cm->cmsg_len = CMSG_LEN(n_fds * sizeof(int)); - - int *fds = (int*)CMSG_DATA(cm); - for(; Is_block(val_fds); val_fds = Field(val_fds, 1), fds++) - *fds = Int_val(Field(val_fds, 0)); - }; -#else - if (n_fds > 0) lwt_unix_not_available("fd_passing"); -#endif - - int ret = sendmsg(fd, &msg, 0); - if (ret == -1) uerror("send_msg", Nothing); - CAMLreturn(Val_int(ret)); -} - -CAMLprim value lwt_unix_send_msg(value val_fd, value val_n_iovs, value val_iovs, value val_n_fds, value val_fds) -{ - int n_iovs = Int_val(val_n_iovs); - struct iovec iovs[n_iovs]; - store_iovs(iovs, val_iovs); - return wrapper_send_msg(Int_val(val_fd), n_iovs, iovs, val_n_fds, val_fds); -} - -CAMLprim value lwt_unix_bytes_send_msg(value val_fd, value val_n_iovs, value val_iovs, value val_n_fds, value val_fds) -{ - int n_iovs = Int_val(val_n_iovs); - struct iovec iovs[n_iovs]; - bytes_store_iovs(iovs, val_iovs); - return wrapper_send_msg(Int_val(val_fd), n_iovs, iovs, val_n_fds, val_fds); -} - -/* +-----------------------------------------------------------------+ - | Credentials | - +-----------------------------------------------------------------+ */ - -#if defined(HAVE_GET_CREDENTIALS) - -#include - -CAMLprim value lwt_unix_get_credentials(value fd) -{ - CAMLparam1(fd); - CAMLlocal1(res); - struct ucred cred; - socklen_t cred_len = sizeof(cred); - - if (getsockopt(Int_val(fd), SOL_SOCKET, SO_PEERCRED, &cred, &cred_len) == -1) - uerror("get_credentials", Nothing); - - res = caml_alloc_tuple(3); - Store_field(res, 0, Val_int(cred.pid)); - Store_field(res, 1, Val_int(cred.uid)); - Store_field(res, 2, Val_int(cred.gid)); - CAMLreturn(res); -} - -#endif - -/* +-----------------------------------------------------------------+ - | wait4 | - +-----------------------------------------------------------------+ */ - -/* Some code duplicated from OCaml's otherlibs/unix/wait.c */ - -#include -#include -#include - -CAMLextern int caml_convert_signal_number (int); -CAMLextern int caml_rev_convert_signal_number (int); - -#if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \ - defined(WSTOPSIG) && defined(WTERMSIG)) -/* Assume old-style V7 status word */ -#define WIFEXITED(status) (((status) & 0xFF) == 0) -#define WEXITSTATUS(status) (((status) >> 8) & 0xFF) -#define WIFSTOPPED(status) (((status) & 0xFF) == 0xFF) -#define WSTOPSIG(status) (((status) >> 8) & 0xFF) -#define WTERMSIG(status) ((status) & 0x3F) -#endif - -#define TAG_WEXITED 0 -#define TAG_WSIGNALED 1 -#define TAG_WSTOPPED 2 - -static value alloc_process_status(int status) -{ - value st; - - if (WIFEXITED(status)) { - st = alloc_small(1, TAG_WEXITED); - Field(st, 0) = Val_int(WEXITSTATUS(status)); - } - else if (WIFSTOPPED(status)) { - st = alloc_small(1, TAG_WSTOPPED); - Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status))); - } - else { - st = alloc_small(1, TAG_WSIGNALED); - Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status))); - } - return st; -} - -static int wait_flag_table[] = { - WNOHANG, WUNTRACED -}; - -value lwt_unix_wait4(value flags, value pid_req) -{ - CAMLparam1(flags); - CAMLlocal2(times, res); - - int pid, status, cv_flags; - cv_flags = caml_convert_flag_list(flags, wait_flag_table); - - struct rusage ru; - - caml_enter_blocking_section(); - pid = wait4(Int_val(pid_req), &status, cv_flags, &ru); - caml_leave_blocking_section(); - if (pid == -1) uerror("wait4", Nothing); - - times = alloc_small(2 * Double_wosize, Double_array_tag); - Store_double_field(times, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6); - Store_double_field(times, 1, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6); - - res = caml_alloc_tuple(3); - Store_field(res, 0, Val_int(pid)); - Store_field(res, 1, alloc_process_status(status)); - Store_field(res, 2, times); - CAMLreturn(res); -} - -value lwt_unix_has_wait4(value unit) -{ - return Val_int(1); -} - -/* +-----------------------------------------------------------------+ - | CPUs | - +-----------------------------------------------------------------+ */ - -#if defined(HAVE_GETCPU) - -CAMLprim value lwt_unix_get_cpu() -{ - int cpu = sched_getcpu(); - if (cpu < 0) uerror("sched_getcpu", Nothing); - return Val_int(cpu); -} - -#endif - -#if defined(HAVE_AFFINITY) - -CAMLprim value lwt_unix_get_affinity(value val_pid) -{ - CAMLparam1(val_pid); - CAMLlocal2(list, node); - cpu_set_t cpus; - if (sched_getaffinity(Int_val(val_pid), sizeof(cpu_set_t), &cpus) < 0) - uerror("sched_getaffinity", Nothing); - int i; - list = Val_int(0); - for (i = sizeof(cpu_set_t) * 8 - 1; i >= 0; i--) { - if (CPU_ISSET(i, &cpus)) { - node = caml_alloc_tuple(2); - Field(node, 0) = Val_int(i); - Field(node, 1) = list; - list = node; - } - } - CAMLreturn(list); -} - -CAMLprim value lwt_unix_set_affinity(value val_pid, value val_cpus) -{ - cpu_set_t cpus; - CPU_ZERO(&cpus); - for (; Is_block(val_cpus); val_cpus = Field(val_cpus, 1)) - CPU_SET(Int_val(Field(val_cpus, 0)), &cpus); - if (sched_setaffinity(Int_val(val_pid), sizeof(cpu_set_t), &cpus) < 0) - uerror("sched_setaffinity", Nothing); - return Val_unit; -} - -#endif - -/* +-----------------------------------------------------------------+ - | JOB: guess_blocking | - +-----------------------------------------------------------------+ */ - -struct job_guess_blocking { - struct lwt_unix_job job; - int fd; - int result; -}; - -#define Job_guess_blocking_val(v) *(struct job_guess_blocking**)Data_custom_val(v) - -static void worker_guess_blocking(struct job_guess_blocking *job) -{ - struct stat stat; - if (fstat(job->fd, &stat) == 0) - job->result = !(S_ISFIFO(stat.st_mode) || S_ISSOCK(stat.st_mode)); - else - job->result = 1; -} - -CAMLprim value lwt_unix_guess_blocking_job(value val_fd) -{ - struct job_guess_blocking *job = lwt_unix_new(struct job_guess_blocking); - job->job.worker = (lwt_unix_job_worker)worker_guess_blocking; - job->fd = Int_val(val_fd); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_guess_blocking_result(value val_job) -{ - struct job_guess_blocking *job = Job_guess_blocking_val(val_job); - return Bool_val(job->result); -} - -CAMLprim value lwt_unix_guess_blocking_free(value val_job) -{ - struct job_guess_blocking *job = Job_guess_blocking_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: wait_mincore | - +-----------------------------------------------------------------+ */ - -struct job_wait_mincore { - struct lwt_unix_job job; - char *ptr; -}; - -#define Job_wait_mincore_val(v) *(struct job_wait_mincore**)Data_custom_val(v) - -static void worker_wait_mincore(struct job_wait_mincore *job) -{ - /* Read the byte to force the kernel to fetch the page: */ - char dummy; - memcpy(&dummy, job->ptr, 1); -} - -CAMLprim value lwt_unix_wait_mincore_job(value val_buffer, value val_offset) -{ - struct job_wait_mincore *job = lwt_unix_new(struct job_wait_mincore); - job->job.worker = (lwt_unix_job_worker)worker_wait_mincore; - job->ptr = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_wait_mincore_free(value val_job) -{ - struct job_wait_mincore *job = Job_wait_mincore_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: open | - +-----------------------------------------------------------------+ */ - -#ifndef O_NONBLOCK -#define O_NONBLOCK O_NDELAY -#endif -#ifndef O_DSYNC -#define O_DSYNC 0 -#endif -#ifndef O_SYNC -#define O_SYNC 0 -#endif -#ifndef O_RSYNC -#define O_RSYNC 0 -#endif - -static int open_flag_table[] = { - O_RDONLY, - O_WRONLY, - O_RDWR, - O_NONBLOCK, - O_APPEND, - O_CREAT, - O_TRUNC, - O_EXCL, - O_NOCTTY, - O_DSYNC, - O_SYNC, - O_RSYNC -}; - -struct job_open { - struct lwt_unix_job job; - char *path; - int flags; - int perms; - int fd; - int blocking; - int error_code; -}; - -#define Job_open_val(v) *(struct job_open**)Data_custom_val(v) - -static void worker_open(struct job_open *job) -{ - int fd; - fd = open(job->path, job->flags, job->perms); - job->fd = fd; - job->error_code = errno; - if (fd >= 0) { - struct stat stat; - if (fstat(fd, &stat) < 0) - job->blocking = 1; - else - job->blocking = !(S_ISFIFO(stat.st_mode) || S_ISSOCK(stat.st_mode)); - } -} - -CAMLprim value lwt_unix_open_job(value val_path, value val_flags, value val_perms) -{ - struct job_open *job = lwt_unix_new(struct job_open); - job->job.worker = (lwt_unix_job_worker)worker_open; - job->path = lwt_unix_strdup(String_val(val_path)); - job->flags = convert_flag_list(val_flags, open_flag_table); - job->perms = Int_val(val_perms); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_open_result(value val_job) -{ - struct job_open *job = Job_open_val(val_job); - int fd = job->fd; - if (fd < 0) unix_error(job->error_code, "open", Nothing); - value result = caml_alloc_tuple(2); - Field(result, 0) = Val_int(fd); - Field(result, 1) = Val_bool(job->blocking); - return result; -} - -CAMLprim value lwt_unix_open_free(value val_job) -{ - struct job_open *job = Job_open_val(val_job); - free(job->path); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: close | - +-----------------------------------------------------------------+ */ - -struct job_close { - struct lwt_unix_job job; - int fd; - int result; - int error_code; -}; - -#define Job_close_val(v) *(struct job_close**)Data_custom_val(v) - -static void worker_close(struct job_close *job) -{ - job->result = close(job->fd); - job->error_code = errno; -} - -CAMLprim value lwt_unix_close_job(value val_fd) -{ - struct job_close *job = lwt_unix_new(struct job_close); - job->job.worker = (lwt_unix_job_worker)worker_close; - job->fd = Int_val(val_fd); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_close_result(value val_job) -{ - struct job_close *job = Job_close_val(val_job); - if (job->result < 0) unix_error(job->error_code, "close", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_close_free(value val_job) -{ - lwt_unix_free_job(&(Job_close_val(val_job))->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: read | - +-----------------------------------------------------------------+ */ - -struct job_read { - struct lwt_unix_job job; - int fd; - char *buffer; - int length; - int result; - int error_code; -}; - -#define Job_read_val(v) *(struct job_read**)Data_custom_val(v) - -static void worker_read(struct job_read *job) -{ - job->result = read(job->fd, job->buffer, job->length); - job->error_code = errno; -} - -CAMLprim value lwt_unix_read_job(value val_fd, value val_length) -{ - struct job_read *job = lwt_unix_new(struct job_read); - long length = Long_val(val_length); - job->job.worker = (lwt_unix_job_worker)worker_read; - job->fd = Int_val(val_fd); - job->buffer = (char*)lwt_unix_malloc(length); - job->length = length; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_read_result(value val_job, value val_string, value val_offset) -{ - struct job_read *job = Job_read_val(val_job); - int result = job->result; - if (result < 0) unix_error(job->error_code, "read", Nothing); - memcpy(String_val(val_string) + Long_val(val_offset), job->buffer, result); - return Val_long(result); -} - -CAMLprim value lwt_unix_read_free(value val_job) -{ - struct job_read *job = Job_read_val(val_job); - free(job->buffer); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: bytes_read | - +-----------------------------------------------------------------+ */ - -struct job_bytes_read { - struct lwt_unix_job job; - int fd; - char *buffer; - int length; - int result; - int error_code; -}; - -#define Job_bytes_read_val(v) *(struct job_bytes_read**)Data_custom_val(v) - -static void worker_bytes_read(struct job_bytes_read *job) -{ - job->result = read(job->fd, job->buffer, job->length); - job->error_code = errno; -} - -CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buf, value val_ofs, value val_len) -{ - struct job_bytes_read *job = lwt_unix_new(struct job_bytes_read); - job->job.worker = (lwt_unix_job_worker)worker_bytes_read; - job->fd = Int_val(val_fd); - job->buffer = (char*)Caml_ba_data_val(val_buf) + Long_val(val_ofs); - job->length = Long_val(val_len); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_bytes_read_result(value val_job) -{ - struct job_bytes_read *job = Job_bytes_read_val(val_job); - int result = job->result; - if (result < 0) unix_error(job->error_code, "read", Nothing); - return Val_long(result); -} - -CAMLprim value lwt_unix_bytes_read_free(value val_job) -{ - struct job_bytes_read *job = Job_bytes_read_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: write | - +-----------------------------------------------------------------+ */ - -struct job_write { - struct lwt_unix_job job; - int fd; - char *buffer; - int length; - int result; - int error_code; -}; - -#define Job_write_val(v) *(struct job_write**)Data_custom_val(v) - -static void worker_write(struct job_write *job) -{ - job->result = write(job->fd, job->buffer, job->length); - job->error_code = errno; -} - -CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length) -{ - struct job_write *job = lwt_unix_new(struct job_write); - long length = Long_val(val_length); - job->job.worker = (lwt_unix_job_worker)worker_write; - job->fd = Int_val(val_fd); - job->buffer = (char*)lwt_unix_malloc(length); - memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length); - job->length = length; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_write_result(value val_job) -{ - struct job_write *job = Job_write_val(val_job); - int result = job->result; - if (result < 0) unix_error(job->error_code, "write", Nothing); - return Val_long(result); -} - -CAMLprim value lwt_unix_write_free(value val_job) -{ - struct job_write *job = Job_write_val(val_job); - free(job->buffer); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: bytes_write | - +-----------------------------------------------------------------+ */ - -struct job_bytes_write { - struct lwt_unix_job job; - int fd; - char *buffer; - int length; - int result; - int error_code; -}; - -#define Job_bytes_write_val(v) *(struct job_bytes_write**)Data_custom_val(v) - -static void worker_bytes_write(struct job_bytes_write *job) -{ - job->result = write(job->fd, job->buffer, job->length); - job->error_code = errno; -} - -CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length) -{ - struct job_bytes_write *job = lwt_unix_new(struct job_bytes_write); - job->job.worker = (lwt_unix_job_worker)worker_bytes_write; - job->fd = Int_val(val_fd); - job->buffer = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); - job->length = Long_val(val_length); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_bytes_write_result(value val_job) -{ - struct job_bytes_write *job = Job_bytes_write_val(val_job); - int result = job->result; - if (result < 0) unix_error(job->error_code, "write", Nothing); - return Val_long(result); -} - -CAMLprim value lwt_unix_bytes_write_free(value val_job) -{ - struct job_bytes_write *job = Job_bytes_write_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: lseek | - +-----------------------------------------------------------------+ */ - -struct job_lseek { - struct lwt_unix_job job; - int fd; - off_t offset; - int command; - off_t result; - int error_code; -}; - -#define Job_lseek_val(v) *(struct job_lseek**)Data_custom_val(v) - -static int seek_command_table[] = { - SEEK_SET, SEEK_CUR, SEEK_END -}; - -static void worker_lseek(struct job_lseek *job) -{ - job->result = lseek(job->fd, job->offset, job->command); - job->error_code = errno; -} - -CAMLprim value lwt_unix_lseek_job(value val_fd, value val_offset, value val_command) -{ - struct job_lseek *job = lwt_unix_new(struct job_lseek); - job->job.worker = (lwt_unix_job_worker)worker_lseek; - job->fd = Int_val(val_fd); - job->offset = Long_val(val_offset); - job->command = seek_command_table[Int_val(val_command)]; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_lseek_result(value val_job) -{ - struct job_lseek *job = Job_lseek_val(val_job); - off_t result = job->result; - if (result < 0) unix_error(job->error_code, "lseek", Nothing); - return Val_long(result); -} - -CAMLprim value lwt_unix_lseek_free(value val_job) -{ - struct job_lseek *job = Job_lseek_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -CAMLprim value lwt_unix_lseek_64_job(value val_fd, value val_offset, value val_command) -{ - struct job_lseek *job = lwt_unix_new(struct job_lseek); - job->job.worker = (lwt_unix_job_worker)worker_lseek; - job->fd = Int_val(val_fd); - job->offset = Int64_val(val_offset); - job->command = seek_command_table[Int_val(val_command)]; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_lseek_64_result(value val_job) -{ - struct job_lseek *job = Job_lseek_val(val_job); - off_t result = job->result; - if (result < 0) unix_error(job->error_code, "lseek", Nothing); - return caml_copy_int64(result); -} - -CAMLprim value lwt_unix_lseek_64_free(value val_job) -{ - struct job_lseek *job = Job_lseek_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: truncate | - +-----------------------------------------------------------------+ */ - -struct job_truncate { - struct lwt_unix_job job; - char *name; - off_t offset; - int result; - int error_code; -}; - -#define Job_truncate_val(v) *(struct job_truncate**)Data_custom_val(v) - -static void worker_truncate(struct job_truncate *job) -{ - job->result = truncate(job->name, job->offset); - job->error_code = errno; -} - -CAMLprim value lwt_unix_truncate_job(value val_name, value val_offset) -{ - struct job_truncate *job = lwt_unix_new(struct job_truncate); - job->job.worker = (lwt_unix_job_worker)worker_truncate; - job->name = lwt_unix_strdup(String_val(val_name)); - job->offset = Long_val(val_offset); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_truncate_result(value val_job) -{ - struct job_truncate *job = Job_truncate_val(val_job); - if (job->result < 0) unix_error(job->error_code, "truncate", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_truncate_free(value val_job) -{ - struct job_truncate *job = Job_truncate_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -CAMLprim value lwt_unix_truncate_64_job(value val_name, value val_offset) -{ - struct job_truncate *job = lwt_unix_new(struct job_truncate); - job->job.worker = (lwt_unix_job_worker)worker_truncate; - job->name = lwt_unix_strdup(String_val(val_name)); - job->offset = Int64_val(val_offset); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_truncate_64_result(value val_job) -{ - struct job_truncate *job = Job_truncate_val(val_job); - if (job->result < 0) unix_error(job->error_code, "truncate", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_truncate_64_free(value val_job) -{ - struct job_truncate *job = Job_truncate_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: ftruncate | - +-----------------------------------------------------------------+ */ - -struct job_ftruncate { - struct lwt_unix_job job; - int fd; - off_t offset; - int result; - int error_code; -}; - -#define Job_ftruncate_val(v) *(struct job_ftruncate**)Data_custom_val(v) - -static void worker_ftruncate(struct job_ftruncate *job) -{ - job->result = ftruncate(job->fd, job->offset); - job->error_code = errno; -} - -CAMLprim value lwt_unix_ftruncate_job(value val_fd, value val_offset) -{ - struct job_ftruncate *job = lwt_unix_new(struct job_ftruncate); - job->job.worker = (lwt_unix_job_worker)worker_ftruncate; - job->fd = Int_val(val_fd); - job->offset = Long_val(val_offset); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_ftruncate_result(value val_job) -{ - struct job_ftruncate *job = Job_ftruncate_val(val_job); - if (job->result < 0) unix_error(job->error_code, "ftruncate", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_ftruncate_free(value val_job) -{ - struct job_ftruncate *job = Job_ftruncate_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -CAMLprim value lwt_unix_ftruncate_64_job(value val_fd, value val_offset) -{ - struct job_ftruncate *job = lwt_unix_new(struct job_ftruncate); - job->job.worker = (lwt_unix_job_worker)worker_ftruncate; - job->fd = Int_val(val_fd); - job->offset = Int64_val(val_offset); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_ftruncate_64_result(value val_job) -{ - struct job_ftruncate *job = Job_ftruncate_val(val_job); - if (job->result < 0) unix_error(job->error_code, "ftruncate", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_ftruncate_64_free(value val_job) -{ - struct job_ftruncate *job = Job_ftruncate_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: fsync | - +-----------------------------------------------------------------+ */ - -struct job_fsync { - struct lwt_unix_job job; - int fd; - int result; - int error_code; -}; - -#define Job_fsync_val(v) *(struct job_fsync**)Data_custom_val(v) - -static void worker_fsync(struct job_fsync *job) -{ - job->result = fsync(job->fd); - job->error_code = errno; -} - -CAMLprim value lwt_unix_fsync_job(value val_fd) -{ - struct job_fsync *job = lwt_unix_new(struct job_fsync); - job->job.worker = (lwt_unix_job_worker)worker_fsync; - job->fd = Int_val(val_fd); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_fsync_result(value val_job) -{ - struct job_fsync *job = Job_fsync_val(val_job); - if (job->result < 0) unix_error(job->error_code, "fsync", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_fsync_free(value val_job) -{ - struct job_fsync *job = Job_fsync_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -#if defined(HAVE_FDATASYNC) - -/* +-----------------------------------------------------------------+ - | JOB: fdatasync | - +-----------------------------------------------------------------+ */ - -struct job_fdatasync { - struct lwt_unix_job job; - int fd; - int result; - int error_code; -}; - -#define Job_fdatasync_val(v) *(struct job_fdatasync**)Data_custom_val(v) - -static void worker_fdatasync(struct job_fdatasync *job) -{ - job->result = fdatasync(job->fd); - job->error_code = errno; -} - -CAMLprim value lwt_unix_fdatasync_job(value val_fd) -{ - struct job_fdatasync *job = lwt_unix_new(struct job_fdatasync); - job->job.worker = (lwt_unix_job_worker)worker_fdatasync; - job->fd = Int_val(val_fd); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_fdatasync_result(value val_job) -{ - struct job_fdatasync *job = Job_fdatasync_val(val_job); - if (job->result < 0) unix_error(job->error_code, "fdatasync", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_fdatasync_free(value val_job) -{ - struct job_fdatasync *job = Job_fdatasync_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -#endif - -/* +-----------------------------------------------------------------+ - | JOB: stat | - +-----------------------------------------------------------------+ */ - -struct job_stat { - struct lwt_unix_job job; - char *name; - struct stat stat; - int result; - int error_code; -}; - -#define Job_stat_val(v) *(struct job_stat**)Data_custom_val(v) - -static value copy_stat(int use_64, struct stat *buf) -{ - CAMLparam0(); - CAMLlocal5(atime, mtime, ctime, offset, v); - - atime = copy_double((double) buf->st_atime); - mtime = copy_double((double) buf->st_mtime); - ctime = copy_double((double) buf->st_ctime); - offset = use_64 ? caml_copy_int64(buf->st_size) : Val_int(buf->st_size); - v = alloc_small(12, 0); - Field(v, 0) = Val_int (buf->st_dev); - Field(v, 1) = Val_int (buf->st_ino); - switch (buf->st_mode & S_IFMT) { - case S_IFREG: - Field(v, 2) = Val_int(0); - break; - case S_IFDIR: - Field(v, 2) = Val_int(1); - break; - case S_IFCHR: - Field(v, 2) = Val_int(2); - break; - case S_IFBLK: - Field(v, 2) = Val_int(3); - break; - case S_IFLNK: - Field(v, 2) = Val_int(4); - break; - case S_IFIFO: - Field(v, 2) = Val_int(5); - break; - case S_IFSOCK: - Field(v, 2) = Val_int(6); - break; - default: - Field(v, 2) = Val_int(0); - break; - } - Field(v, 3) = Val_int(buf->st_mode & 07777); - Field(v, 4) = Val_int(buf->st_nlink); - Field(v, 5) = Val_int(buf->st_uid); - Field(v, 6) = Val_int(buf->st_gid); - Field(v, 7) = Val_int(buf->st_rdev); - Field(v, 8) = offset; - Field(v, 9) = atime; - Field(v, 10) = mtime; - Field(v, 11) = ctime; - CAMLreturn(v); -} - -static void worker_stat(struct job_stat *job) -{ - job->result = stat(job->name, &(job->stat)); - job->error_code = errno; -} - -CAMLprim value lwt_unix_stat_job(value val_name) -{ - struct job_stat *job = lwt_unix_new(struct job_stat); - job->job.worker = (lwt_unix_job_worker)worker_stat; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_stat_result(value val_job) -{ - struct job_stat *job = Job_stat_val(val_job); - if (job->result < 0) unix_error(job->error_code, "stat", Nothing); - return copy_stat(0, &(job->stat)); -} - -CAMLprim value lwt_unix_stat_free(value val_job) -{ - struct job_stat *job = Job_stat_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -CAMLprim value lwt_unix_stat_64_job(value val_name) -{ - struct job_stat *job = lwt_unix_new(struct job_stat); - job->job.worker = (lwt_unix_job_worker)worker_stat; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_stat_64_result(value val_job) -{ - struct job_stat *job = Job_stat_val(val_job); - if (job->result < 0) unix_error(job->error_code, "stat", Nothing); - return copy_stat(1, &(job->stat)); -} - -CAMLprim value lwt_unix_stat_64_free(value val_job) -{ - struct job_stat *job = Job_stat_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: lstat | - +-----------------------------------------------------------------+ */ - -struct job_lstat { - struct lwt_unix_job job; - char *name; - struct stat lstat; - int result; - int error_code; -}; - -#define Job_lstat_val(v) *(struct job_lstat**)Data_custom_val(v) - -static void worker_lstat(struct job_lstat *job) -{ - job->result = lstat(job->name, &(job->lstat)); - job->error_code = errno; -} - -CAMLprim value lwt_unix_lstat_job(value val_name) -{ - struct job_lstat *job = lwt_unix_new(struct job_lstat); - job->job.worker = (lwt_unix_job_worker)worker_lstat; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_lstat_result(value val_job) -{ - struct job_lstat *job = Job_lstat_val(val_job); - if (job->result < 0) unix_error(job->error_code, "lstat", Nothing); - return copy_stat(0, &(job->lstat)); -} - -CAMLprim value lwt_unix_lstat_free(value val_job) -{ - struct job_lstat *job = Job_lstat_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -CAMLprim value lwt_unix_lstat_64_job(value val_name) -{ - struct job_lstat *job = lwt_unix_new(struct job_lstat); - job->job.worker = (lwt_unix_job_worker)worker_lstat; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_lstat_64_result(value val_job) -{ - struct job_lstat *job = Job_lstat_val(val_job); - if (job->result < 0) unix_error(job->error_code, "lstat", Nothing); - return copy_stat(1, &(job->lstat)); -} - -CAMLprim value lwt_unix_lstat_64_free(value val_job) -{ - struct job_lstat *job = Job_lstat_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: fstat | - +-----------------------------------------------------------------+ */ - -struct job_fstat { - struct lwt_unix_job job; - int fd; - struct stat fstat; - int result; - int error_code; -}; - -#define Job_fstat_val(v) *(struct job_fstat**)Data_custom_val(v) - -static void worker_fstat(struct job_fstat *job) -{ - job->result = fstat(job->fd, &(job->fstat)); - job->error_code = errno; -} - -CAMLprim value lwt_unix_fstat_job(value val_fd) -{ - struct job_fstat *job = lwt_unix_new(struct job_fstat); - job->job.worker = (lwt_unix_job_worker)worker_fstat; - job->fd = Int_val(val_fd); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_fstat_result(value val_job) -{ - struct job_fstat *job = Job_fstat_val(val_job); - if (job->result < 0) unix_error(job->error_code, "fstat", Nothing); - return copy_stat(0, &(job->fstat)); -} - -CAMLprim value lwt_unix_fstat_free(value val_job) -{ - struct job_fstat *job = Job_fstat_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -CAMLprim value lwt_unix_fstat_64_job(value val_fd) -{ - struct job_fstat *job = lwt_unix_new(struct job_fstat); - job->job.worker = (lwt_unix_job_worker)worker_fstat; - job->fd = Int_val(val_fd); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_fstat_64_result(value val_job) -{ - struct job_fstat *job = Job_fstat_val(val_job); - if (job->result < 0) unix_error(job->error_code, "fstat", Nothing); - return copy_stat(1, &(job->fstat)); -} - -CAMLprim value lwt_unix_fstat_64_free(value val_job) -{ - struct job_fstat *job = Job_fstat_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: isatty | - +-----------------------------------------------------------------+ */ - -struct job_isatty { - struct lwt_unix_job job; - int fd; - int result; -}; - -#define Job_isatty_val(v) *(struct job_isatty**)Data_custom_val(v) - -static void worker_isatty(struct job_isatty *job) -{ - job->result = isatty(job->fd); -} - -CAMLprim value lwt_unix_isatty_job(value val_fd) -{ - struct job_isatty *job = lwt_unix_new(struct job_isatty); - job->job.worker = (lwt_unix_job_worker)worker_isatty; - job->fd = Int_val(val_fd); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_isatty_result(value val_job) -{ - struct job_isatty *job = Job_isatty_val(val_job); - return Val_bool(job->result); -} - -CAMLprim value lwt_unix_isatty_free(value val_job) -{ - struct job_isatty *job = Job_isatty_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: unlink | - +-----------------------------------------------------------------+ */ - -struct job_unlink { - struct lwt_unix_job job; - char *name; - int result; - int error_code; -}; - -#define Job_unlink_val(v) *(struct job_unlink**)Data_custom_val(v) - -static void worker_unlink(struct job_unlink *job) -{ - job->result = unlink(job->name); - job->error_code = errno; -} - -CAMLprim value lwt_unix_unlink_job(value val_name) -{ - struct job_unlink *job = lwt_unix_new(struct job_unlink); - job->job.worker = (lwt_unix_job_worker)worker_unlink; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_unlink_result(value val_job) -{ - struct job_unlink *job = Job_unlink_val(val_job); - if (job->result < 0) unix_error(job->error_code, "unlink", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_unlink_free(value val_job) -{ - struct job_unlink *job = Job_unlink_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: rename | - +-----------------------------------------------------------------+ */ - -struct job_rename { - struct lwt_unix_job job; - char *name1; - char *name2; - int result; - int error_code; -}; - -#define Job_rename_val(v) *(struct job_rename**)Data_custom_val(v) - -static void worker_rename(struct job_rename *job) -{ - job->result = rename(job->name1, job->name2); - job->error_code = errno; -} - -CAMLprim value lwt_unix_rename_job(value val_name1, value val_name2) -{ - struct job_rename *job = lwt_unix_new(struct job_rename); - job->job.worker = (lwt_unix_job_worker)worker_rename; - job->name1 = lwt_unix_strdup(String_val(val_name1)); - job->name2 = lwt_unix_strdup(String_val(val_name2)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_rename_result(value val_job) -{ - struct job_rename *job = Job_rename_val(val_job); - if (job->result < 0) unix_error(job->error_code, "rename", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_rename_free(value val_job) -{ - struct job_rename *job = Job_rename_val(val_job); - free(job->name1); - free(job->name2); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: link | - +-----------------------------------------------------------------+ */ - -struct job_link { - struct lwt_unix_job job; - char *name1; - char *name2; - int result; - int error_code; -}; - -#define Job_link_val(v) *(struct job_link**)Data_custom_val(v) - -static void worker_link(struct job_link *job) -{ - job->result = link(job->name1, job->name2); - job->error_code = errno; -} - -CAMLprim value lwt_unix_link_job(value val_name1, value val_name2) -{ - struct job_link *job = lwt_unix_new(struct job_link); - job->job.worker = (lwt_unix_job_worker)worker_link; - job->name1 = lwt_unix_strdup(String_val(val_name1)); - job->name2 = lwt_unix_strdup(String_val(val_name2)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_link_result(value val_job) -{ - struct job_link *job = Job_link_val(val_job); - if (job->result < 0) unix_error(job->error_code, "link", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_link_free(value val_job) -{ - struct job_link *job = Job_link_val(val_job); - free(job->name1); - free(job->name2); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: chmod | - +-----------------------------------------------------------------+ */ - -struct job_chmod { - struct lwt_unix_job job; - char *name; - int perms; - int result; - int error_code; -}; - -#define Job_chmod_val(v) *(struct job_chmod**)Data_custom_val(v) - -static void worker_chmod(struct job_chmod *job) -{ - job->result = chmod(job->name, job->perms); - job->error_code = errno; -} - -CAMLprim value lwt_unix_chmod_job(value val_name, value val_perms) -{ - struct job_chmod *job = lwt_unix_new(struct job_chmod); - job->job.worker = (lwt_unix_job_worker)worker_chmod; - job->name = lwt_unix_strdup(String_val(val_name)); - job->perms = Int_val(val_perms); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_chmod_result(value val_job) -{ - struct job_chmod *job = Job_chmod_val(val_job); - if (job->result < 0) unix_error(job->error_code, "chmod", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_chmod_free(value val_job) -{ - struct job_chmod *job = Job_chmod_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: fchmod | - +-----------------------------------------------------------------+ */ - -struct job_fchmod { - struct lwt_unix_job job; - int fd; - int perms; - int result; - int error_code; -}; - -#define Job_fchmod_val(v) *(struct job_fchmod**)Data_custom_val(v) - -static void worker_fchmod(struct job_fchmod *job) -{ - job->result = fchmod(job->fd, job->perms); - job->error_code = errno; -} - -CAMLprim value lwt_unix_fchmod_job(value val_fd, value val_perms) -{ - struct job_fchmod *job = lwt_unix_new(struct job_fchmod); - job->job.worker = (lwt_unix_job_worker)worker_fchmod; - job->fd = Int_val(val_fd); - job->perms = Int_val(val_perms); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_fchmod_result(value val_job) -{ - struct job_fchmod *job = Job_fchmod_val(val_job); - if (job->result < 0) unix_error(job->error_code, "fchmod", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_fchmod_free(value val_job) -{ - struct job_fchmod *job = Job_fchmod_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: chown | - +-----------------------------------------------------------------+ */ - -struct job_chown { - struct lwt_unix_job job; - char *name; - int uid; - int gid; - int result; - int error_code; -}; - -#define Job_chown_val(v) *(struct job_chown**)Data_custom_val(v) - -static void worker_chown(struct job_chown *job) -{ - job->result = chown(job->name, job->uid, job->gid); - job->error_code = errno; -} - -CAMLprim value lwt_unix_chown_job(value val_name, value val_uid, value val_gid) -{ - struct job_chown *job = lwt_unix_new(struct job_chown); - job->job.worker = (lwt_unix_job_worker)worker_chown; - job->name = lwt_unix_strdup(String_val(val_name)); - job->uid = Int_val(val_uid); - job->gid = Int_val(val_gid); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_chown_result(value val_job) -{ - struct job_chown *job = Job_chown_val(val_job); - if (job->result < 0) unix_error(job->error_code, "chown", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_chown_free(value val_job) -{ - struct job_chown *job = Job_chown_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: fchown | - +-----------------------------------------------------------------+ */ - -struct job_fchown { - struct lwt_unix_job job; - int fd; - int uid; - int gid; - int result; - int error_code; -}; - -#define Job_fchown_val(v) *(struct job_fchown**)Data_custom_val(v) - -static void worker_fchown(struct job_fchown *job) -{ - job->result = fchown(job->fd, job->uid, job->gid); - job->error_code = errno; -} - -CAMLprim value lwt_unix_fchown_job(value val_fd, value val_uid, value val_gid) -{ - struct job_fchown *job = lwt_unix_new(struct job_fchown); - job->job.worker = (lwt_unix_job_worker)worker_fchown; - job->fd = Int_val(val_fd); - job->uid = Int_val(val_uid); - job->gid = Int_val(val_gid); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_fchown_result(value val_job) -{ - struct job_fchown *job = Job_fchown_val(val_job); - if (job->result < 0) unix_error(job->error_code, "fchown", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_fchown_free(value val_job) -{ - struct job_fchown *job = Job_fchown_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: access | - +-----------------------------------------------------------------+ */ - -struct job_access { - struct lwt_unix_job job; - char *name; - int mode; - int result; - int error_code; -}; - -#define Job_access_val(v) *(struct job_access**)Data_custom_val(v) - -static int access_permission_table[] = { - R_OK, W_OK, X_OK, F_OK -}; - -static void worker_access(struct job_access *job) -{ - job->result = access(job->name, job->mode); - job->error_code = errno; -} - -CAMLprim value lwt_unix_access_job(value val_name, value val_perms) -{ - struct job_access *job = lwt_unix_new(struct job_access); - job->job.worker = (lwt_unix_job_worker)worker_access; - job->name = lwt_unix_strdup(String_val(val_name)); - job->mode = convert_flag_list(val_perms, access_permission_table); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_access_result(value val_job) -{ - struct job_access *job = Job_access_val(val_job); - if (job->result < 0) unix_error(job->error_code, "access", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_access_free(value val_job) -{ - struct job_access *job = Job_access_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: mkdir | - +-----------------------------------------------------------------+ */ - -struct job_mkdir { - struct lwt_unix_job job; - char *name; - int perms; - int result; - int error_code; -}; - -#define Job_mkdir_val(v) *(struct job_mkdir**)Data_custom_val(v) - -static void worker_mkdir(struct job_mkdir *job) -{ - job->result = mkdir(job->name, job->perms); - job->error_code = errno; -} - -CAMLprim value lwt_unix_mkdir_job(value val_name, value val_perms) -{ - struct job_mkdir *job = lwt_unix_new(struct job_mkdir); - job->job.worker = (lwt_unix_job_worker)worker_mkdir; - job->name = lwt_unix_strdup(String_val(val_name)); - job->perms = Int_val(val_perms); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_mkdir_result(value val_job) -{ - struct job_mkdir *job = Job_mkdir_val(val_job); - if (job->result < 0) unix_error(job->error_code, "mkdir", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_mkdir_free(value val_job) -{ - struct job_mkdir *job = Job_mkdir_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: rmdir | - +-----------------------------------------------------------------+ */ - -struct job_rmdir { - struct lwt_unix_job job; - char *name; - int result; - int error_code; -}; - -#define Job_rmdir_val(v) *(struct job_rmdir**)Data_custom_val(v) - -static void worker_rmdir(struct job_rmdir *job) -{ - job->result = rmdir(job->name); - job->error_code = errno; -} - -CAMLprim value lwt_unix_rmdir_job(value val_name) -{ - struct job_rmdir *job = lwt_unix_new(struct job_rmdir); - job->job.worker = (lwt_unix_job_worker)worker_rmdir; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_rmdir_result(value val_job) -{ - struct job_rmdir *job = Job_rmdir_val(val_job); - if (job->result < 0) unix_error(job->error_code, "rmdir", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_rmdir_free(value val_job) -{ - struct job_rmdir *job = Job_rmdir_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: chdir | - +-----------------------------------------------------------------+ */ - -struct job_chdir { - struct lwt_unix_job job; - char *name; - int result; - int error_code; -}; - -#define Job_chdir_val(v) *(struct job_chdir**)Data_custom_val(v) - -static void worker_chdir(struct job_chdir *job) -{ - job->result = chdir(job->name); - job->error_code = errno; -} - -CAMLprim value lwt_unix_chdir_job(value val_name) -{ - struct job_chdir *job = lwt_unix_new(struct job_chdir); - job->job.worker = (lwt_unix_job_worker)worker_chdir; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_chdir_result(value val_job) -{ - struct job_chdir *job = Job_chdir_val(val_job); - if (job->result < 0) unix_error(job->error_code, "chdir", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_chdir_free(value val_job) -{ - struct job_chdir *job = Job_chdir_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: chroot | - +-----------------------------------------------------------------+ */ - -struct job_chroot { - struct lwt_unix_job job; - char *name; - int result; - int error_code; -}; - -#define Job_chroot_val(v) *(struct job_chroot**)Data_custom_val(v) - -static void worker_chroot(struct job_chroot *job) -{ - job->result = chroot(job->name); - job->error_code = errno; -} - -CAMLprim value lwt_unix_chroot_job(value val_name) -{ - struct job_chroot *job = lwt_unix_new(struct job_chroot); - job->job.worker = (lwt_unix_job_worker)worker_chroot; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_chroot_result(value val_job) -{ - struct job_chroot *job = Job_chroot_val(val_job); - if (job->result < 0) unix_error(job->error_code, "chroot", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_chroot_free(value val_job) -{ - struct job_chroot *job = Job_chroot_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: opendir | - +-----------------------------------------------------------------+ */ - -struct job_opendir { - struct lwt_unix_job job; - char *name; - DIR *result; - int error_code; -}; - -#define Job_opendir_val(v) *(struct job_opendir**)Data_custom_val(v) - -static void worker_opendir(struct job_opendir *job) -{ - job->result = opendir(job->name); - job->error_code = errno; -} - -CAMLprim value lwt_unix_opendir_job(value val_name) -{ - struct job_opendir *job = lwt_unix_new(struct job_opendir); - job->job.worker = (lwt_unix_job_worker)worker_opendir; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_opendir_result(value val_job) -{ - struct job_opendir *job = Job_opendir_val(val_job); - if (job->result == NULL) unix_error(job->error_code, "opendir", Nothing); - value result = alloc_small(1, Abstract_tag); - DIR_Val(result) = job->result; - return result; -} - -CAMLprim value lwt_unix_opendir_free(value val_job) -{ - struct job_opendir *job = Job_opendir_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: readdir | - +-----------------------------------------------------------------+ */ - -struct job_readdir { - struct lwt_unix_job job; - DIR *dir; - struct dirent *entry; - struct dirent *ptr; - int result; -}; - -#define Job_readdir_val(v) *(struct job_readdir**)Data_custom_val(v) - -static void worker_readdir(struct job_readdir *job) -{ - job->entry = lwt_unix_malloc(offsetof(struct dirent, d_name) + fpathconf(dirfd(job->dir), _PC_NAME_MAX) + 1); - job->result = readdir_r(job->dir, job->entry, &(job->ptr)); -} - -CAMLprim value lwt_unix_readdir_job(value val_dir) -{ - struct job_readdir *job = lwt_unix_new(struct job_readdir); - job->job.worker = (lwt_unix_job_worker)worker_readdir; - job->dir = DIR_Val(val_dir); - job->entry = NULL; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_readdir_result(value val_job) -{ - struct job_readdir *job = Job_readdir_val(val_job); - if (job->result != 0) unix_error(job->result, "readdir", Nothing); - if (job->ptr == NULL) caml_raise_end_of_file(); - return caml_copy_string(job->entry->d_name); -} - -CAMLprim value lwt_unix_readdir_free(value val_job) -{ - struct job_readdir *job = Job_readdir_val(val_job); - if (job->entry != NULL) free(job->entry); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: readdir_n | - +-----------------------------------------------------------------+ */ - -struct job_readdir_n { - struct lwt_unix_job job; - DIR *dir; - int count; - int error_code; - struct dirent *entries[]; -}; - -#define Job_readdir_n_val(v) *(struct job_readdir_n**)Data_custom_val(v) - -static void worker_readdir_n(struct job_readdir_n *job) -{ - size_t size = offsetof(struct dirent, d_name) + fpathconf(dirfd(job->dir), _PC_NAME_MAX) + 1; - int i; - for(i = 0; i < job->count; i++) { - struct dirent *ptr; - struct dirent *entry = (struct dirent *)lwt_unix_malloc(size); - - int result = readdir_r(job->dir, entry, &ptr); - - /* An error happened. */ - if (result != 0) { - /* Free already read entries. */ - free(entry); - int j; - for(j = 0; j < i; j++) free(job->entries[j]); - /* Return an error. */ - job->error_code = result; - return; - } - - /* End of directory reached */ - if (ptr == NULL) { - free(entry); - break; - } - - job->entries[i] = entry; - } - - job->count = i; - job->error_code = 0; -} - -CAMLprim value lwt_unix_readdir_n_job(value val_dir, value val_count) -{ - int count = Int_val(val_count); - struct job_readdir_n *job = (struct job_readdir_n *)lwt_unix_malloc(sizeof(struct job_readdir_n) + sizeof(struct dirent*) * count); - job->job.worker = (lwt_unix_job_worker)worker_readdir_n; - job->dir = DIR_Val(val_dir); - job->count = count; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_readdir_n_result(value val_job) -{ - CAMLparam1(val_job); - CAMLlocal1(result); - struct job_readdir_n *job = Job_readdir_n_val(val_job); - if (job->error_code != 0) unix_error(job->error_code, "readdir_n", Nothing); - - result = caml_alloc(job->count, 0); - int i; - for(i = 0; i < job->count; i++) { - Store_field(result, i, caml_copy_string(job->entries[i]->d_name)); - free(job->entries[i]); - job->entries[i] = NULL; - } - job->count = 0; - CAMLreturn(result); -} - -CAMLprim value lwt_unix_readdir_n_free(value val_job) -{ - struct job_readdir_n *job = Job_readdir_n_val(val_job); - if (job->error_code == 0) { - int i; - for(i = 0; i < job->count; i++) - if (job->entries[i] != NULL) free(job->entries[i]); - } - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: rewinddir | - +-----------------------------------------------------------------+ */ - -struct job_rewinddir { - struct lwt_unix_job job; - DIR *dir; -}; - -#define Job_rewinddir_val(v) *(struct job_rewinddir**)Data_custom_val(v) - -static void worker_rewinddir(struct job_rewinddir *job) -{ - rewinddir(job->dir); -} - -CAMLprim value lwt_unix_rewinddir_job(value val_dir) -{ - struct job_rewinddir *job = lwt_unix_new(struct job_rewinddir); - job->job.worker = (lwt_unix_job_worker)worker_rewinddir; - job->dir = DIR_Val(val_dir); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_rewinddir_result(value val_job) -{ - return Val_unit; -} - -CAMLprim value lwt_unix_rewinddir_free(value val_job) -{ - struct job_rewinddir *job = Job_rewinddir_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: closedir | - +-----------------------------------------------------------------+ */ - -struct job_closedir { - struct lwt_unix_job job; - DIR *dir; - int result; - int error_code; -}; - -#define Job_closedir_val(v) *(struct job_closedir**)Data_custom_val(v) - -static void worker_closedir(struct job_closedir *job) -{ - job->result = closedir(job->dir); - job->error_code = errno; -} - -CAMLprim value lwt_unix_closedir_job(value val_dir) -{ - struct job_closedir *job = lwt_unix_new(struct job_closedir); - job->job.worker = (lwt_unix_job_worker)worker_closedir; - job->dir = DIR_Val(val_dir); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_closedir_result(value val_job) -{ - struct job_closedir *job = Job_closedir_val(val_job); - if (job->result < 0) unix_error(job->error_code, "closedir", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_closedir_free(value val_job) -{ - struct job_closedir *job = Job_closedir_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: mkfifo | - +-----------------------------------------------------------------+ */ - -struct job_mkfifo { - struct lwt_unix_job job; - char *name; - int perms; - int result; - int error_code; -}; - -#define Job_mkfifo_val(v) *(struct job_mkfifo**)Data_custom_val(v) - -static void worker_mkfifo(struct job_mkfifo *job) -{ - job->result = mkfifo(job->name, job->perms); - job->error_code = errno; -} - -CAMLprim value lwt_unix_mkfifo_job(value val_name, value val_perms) -{ - struct job_mkfifo *job = lwt_unix_new(struct job_mkfifo); - job->job.worker = (lwt_unix_job_worker)worker_mkfifo; - job->name = lwt_unix_strdup(String_val(val_name)); - job->perms = Int_val(val_perms); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_mkfifo_result(value val_job) -{ - struct job_mkfifo *job = Job_mkfifo_val(val_job); - if (job->result < 0) unix_error(job->error_code, "mkfifo", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_mkfifo_free(value val_job) -{ - struct job_mkfifo *job = Job_mkfifo_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: symlink | - +-----------------------------------------------------------------+ */ - -struct job_symlink { - struct lwt_unix_job job; - char *name1; - char *name2; - int result; - int error_code; -}; - -#define Job_symlink_val(v) *(struct job_symlink**)Data_custom_val(v) - -static void worker_symlink(struct job_symlink *job) -{ - job->result = symlink(job->name1, job->name2); - job->error_code = errno; -} - -CAMLprim value lwt_unix_symlink_job(value val_name1, value val_name2) -{ - struct job_symlink *job = lwt_unix_new(struct job_symlink); - job->job.worker = (lwt_unix_job_worker)worker_symlink; - job->name1 = lwt_unix_strdup(String_val(val_name1)); - job->name2 = lwt_unix_strdup(String_val(val_name2)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_symlink_result(value val_job) -{ - struct job_symlink *job = Job_symlink_val(val_job); - if (job->result < 0) unix_error(job->error_code, "symlink", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_symlink_free(value val_job) -{ - struct job_symlink *job = Job_symlink_val(val_job); - free(job->name1); - free(job->name2); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: readlink | - +-----------------------------------------------------------------+ */ - -struct job_readlink { - struct lwt_unix_job job; - char *name; - char *buffer; - ssize_t result; - int error_code; -}; - -#define Job_readlink_val(v) *(struct job_readlink**)Data_custom_val(v) - -static void worker_readlink(struct job_readlink *job) -{ - - ssize_t buffer_size = 1024; - ssize_t link_length; - - for (;;) { - - job->buffer = lwt_unix_malloc(buffer_size); - - link_length = readlink(job->name, job->buffer, buffer_size); - - if (link_length < buffer_size) { - if (link_length >= 0) { - job->buffer = realloc(job->buffer, link_length + 1); - job->buffer[link_length] = '\0'; - } else { - free (job->buffer); - job->buffer = NULL; - } - job->result = link_length; - job->error_code = errno; - break; - } else { - free(job->buffer); - buffer_size *= 2; - } - } -} - -CAMLprim value lwt_unix_readlink_job(value val_name) -{ - struct job_readlink *job = lwt_unix_new(struct job_readlink); - job->job.worker = (lwt_unix_job_worker)worker_readlink; - job->name = lwt_unix_strdup(String_val(val_name)); - job->buffer = NULL; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_readlink_result(value val_job) -{ - struct job_readlink *job = Job_readlink_val(val_job); - if (job->result < 0) unix_error(job->error_code, "readlink", Nothing); - return caml_copy_string(job->buffer); -} - -CAMLprim value lwt_unix_readlink_free(value val_job) -{ - struct job_readlink *job = Job_readlink_val(val_job); - free(job->name); - free(job->buffer); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: lockf | - +-----------------------------------------------------------------+ */ - -struct job_lockf { - struct lwt_unix_job job; - int fd; - int command; - off_t length; - int result; - int error_code; -}; - -#define Job_lockf_val(v) *(struct job_lockf**)Data_custom_val(v) - -static int lock_command_table[] = { - F_ULOCK, F_LOCK, F_TLOCK, F_TEST, F_LOCK, F_TLOCK -}; - -static void worker_lockf(struct job_lockf *job) -{ - job->result = lockf(job->fd, job->command, job->length); - job->error_code = errno; -} - -CAMLprim value lwt_unix_lockf_job(value val_fd, value val_command, value val_length) -{ - struct job_lockf *job = lwt_unix_new(struct job_lockf); - job->job.worker = (lwt_unix_job_worker)worker_lockf; - job->fd = Int_val(val_fd); - job->command = lock_command_table[Int_val(val_command)]; - job->length = Long_val(val_length); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_lockf_result(value val_job) -{ - struct job_lockf *job = Job_lockf_val(val_job); - if (job->result < 0) unix_error(job->error_code, "lockf", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_lockf_free(value val_job) -{ - struct job_lockf *job = Job_lockf_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getlogin | - +-----------------------------------------------------------------+ */ - -struct job_getlogin { - struct lwt_unix_job job; - char buffer[1024]; - int result; -}; - -#define Job_getlogin_val(v) *(struct job_getlogin**)Data_custom_val(v) - -static void worker_getlogin(struct job_getlogin *job) -{ - job->result = getlogin_r(job->buffer, 1024); -} - -CAMLprim value lwt_unix_getlogin_job() -{ - struct job_getlogin *job = lwt_unix_new(struct job_getlogin); - job->job.worker = (lwt_unix_job_worker)worker_getlogin; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getlogin_result(value val_job) -{ - struct job_getlogin *job = Job_getlogin_val(val_job); - if (job->result != 0) unix_error(job->result, "getlogin", Nothing); - return caml_copy_string(job->buffer); -} - -CAMLprim value lwt_unix_getlogin_free(value val_job) -{ - struct job_getlogin *job = Job_getlogin_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getpwnam | - +-----------------------------------------------------------------+ */ - -struct job_getpwnam { - struct lwt_unix_job job; - char *name; - struct passwd pwd; - struct passwd *ptr; - char *buffer; - int result; -}; - -#define Job_getpwnam_val(v) *(struct job_getpwnam**)Data_custom_val(v) - -static value alloc_passwd_entry(struct passwd *entry) -{ - value res; - value name = Val_unit, passwd = Val_unit, gecos = Val_unit; - value dir = Val_unit, shell = Val_unit; - - Begin_roots5 (name, passwd, gecos, dir, shell); - name = copy_string(entry->pw_name); - passwd = copy_string(entry->pw_passwd); -#ifndef __BEOS__ - gecos = copy_string(entry->pw_gecos); -#else - gecos = copy_string(""); -#endif - dir = copy_string(entry->pw_dir); - shell = copy_string(entry->pw_shell); - res = alloc_small(7, 0); - Field(res, 0) = name; - Field(res, 1) = passwd; - Field(res, 2) = Val_int(entry->pw_uid); - Field(res, 3) = Val_int(entry->pw_gid); - Field(res, 4) = gecos; - Field(res, 5) = dir; - Field(res, 6) = shell; - End_roots(); - return res; -} - -static void worker_getpwnam(struct job_getpwnam *job) -{ - size_t buffer_size = sysconf(_SC_GETPW_R_SIZE_MAX); - if (buffer_size == (size_t) -1) buffer_size = 16384; - job->buffer = (char*)lwt_unix_malloc(buffer_size); - job->result = getpwnam_r(job->name, &(job->pwd), job->buffer, buffer_size, &(job->ptr)); -} - -CAMLprim value lwt_unix_getpwnam_job(value val_name) -{ - struct job_getpwnam *job = lwt_unix_new(struct job_getpwnam); - job->job.worker = (lwt_unix_job_worker)worker_getpwnam; - job->name = lwt_unix_strdup(String_val(val_name)); - job->buffer = NULL; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getpwnam_result(value val_job) -{ - struct job_getpwnam *job = Job_getpwnam_val(val_job); - if (job->result != 0) unix_error(job->result, "getpwnam", Nothing); - if (job->ptr == NULL) caml_raise_not_found(); - return alloc_passwd_entry(&(job->pwd)); -} - -CAMLprim value lwt_unix_getpwnam_free(value val_job) -{ - struct job_getpwnam *job = Job_getpwnam_val(val_job); - free(job->name); - if (job->buffer != NULL) free(job->buffer); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getgrnam | - +-----------------------------------------------------------------+ */ - -struct job_getgrnam { - struct lwt_unix_job job; - char *name; - struct group grp; - struct group *ptr; - char *buffer; - int result; -}; - -#define Job_getgrnam_val(v) *(struct job_getgrnam**)Data_custom_val(v) - -static value alloc_group_entry(struct group *entry) -{ - value res; - value name = Val_unit, pass = Val_unit, mem = Val_unit; - - Begin_roots3 (name, pass, mem); - name = copy_string(entry->gr_name); - pass = copy_string(entry->gr_passwd); - mem = copy_string_array((const char**)entry->gr_mem); - res = alloc_small(4, 0); - Field(res, 0) = name; - Field(res, 1) = pass; - Field(res, 2) = Val_int(entry->gr_gid); - Field(res, 3) = mem; - End_roots(); - return res; -} - -static void worker_getgrnam(struct job_getgrnam *job) -{ - size_t buffer_size = sysconf(_SC_GETGR_R_SIZE_MAX); - if (buffer_size == (size_t) -1) buffer_size = 16384; - job->buffer = (char*)lwt_unix_malloc(buffer_size); - job->result = getgrnam_r(job->name, &(job->grp), job->buffer, buffer_size, &(job->ptr)); -} - -CAMLprim value lwt_unix_getgrnam_job(value val_name) -{ - struct job_getgrnam *job = lwt_unix_new(struct job_getgrnam); - job->job.worker = (lwt_unix_job_worker)worker_getgrnam; - job->name = lwt_unix_strdup(String_val(val_name)); - job->buffer = NULL; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getgrnam_result(value val_job) -{ - struct job_getgrnam *job = Job_getgrnam_val(val_job); - if (job->result != 0) unix_error(job->result, "getgrnam", Nothing); - if (job->ptr == NULL) caml_raise_not_found(); - return alloc_group_entry(&(job->grp)); -} - -CAMLprim value lwt_unix_getgrnam_free(value val_job) -{ - struct job_getgrnam *job = Job_getgrnam_val(val_job); - free(job->name); - if (job->buffer != NULL) free(job->buffer); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getpwuid | - +-----------------------------------------------------------------+ */ - -struct job_getpwuid { - struct lwt_unix_job job; - int uid; - struct passwd pwd; - struct passwd *ptr; - char *buffer; - int result; -}; - -#define Job_getpwuid_val(v) *(struct job_getpwuid**)Data_custom_val(v) - -static void worker_getpwuid(struct job_getpwuid *job) -{ - size_t buffer_size = sysconf(_SC_GETPW_R_SIZE_MAX); - if (buffer_size == (size_t) -1) buffer_size = 16384; - job->buffer = (char*)lwt_unix_malloc(buffer_size); - job->result = getpwuid_r(job->uid, &(job->pwd), job->buffer, buffer_size, &(job->ptr)); -} - -CAMLprim value lwt_unix_getpwuid_job(value val_uid) -{ - struct job_getpwuid *job = lwt_unix_new(struct job_getpwuid); - job->job.worker = (lwt_unix_job_worker)worker_getpwuid; - job->uid = Int_val(val_uid); - job->buffer = NULL; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getpwuid_result(value val_job) -{ - struct job_getpwuid *job = Job_getpwuid_val(val_job); - if (job->result != 0) unix_error(job->result, "getpwuid", Nothing); - if (job->ptr == NULL) caml_raise_not_found(); - return alloc_passwd_entry(&(job->pwd)); -} - -CAMLprim value lwt_unix_getpwuid_free(value val_job) -{ - struct job_getpwuid *job = Job_getpwuid_val(val_job); - if (job->buffer != NULL) free(job->buffer); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getgrgid | - +-----------------------------------------------------------------+ */ - -struct job_getgrgid { - struct lwt_unix_job job; - int gid; - struct group grp; - struct group *ptr; - char *buffer; - int result; -}; - -#define Job_getgrgid_val(v) *(struct job_getgrgid**)Data_custom_val(v) - -static void worker_getgrgid(struct job_getgrgid *job) -{ - size_t buffer_size = sysconf(_SC_GETGR_R_SIZE_MAX); - if (buffer_size == (size_t) -1) buffer_size = 16384; - job->buffer = (char*)lwt_unix_malloc(buffer_size); - job->result = getgrgid_r(job->gid, &(job->grp), job->buffer, buffer_size, &(job->ptr)); -} - -CAMLprim value lwt_unix_getgrgid_job(value val_gid) -{ - struct job_getgrgid *job = lwt_unix_new(struct job_getgrgid); - job->job.worker = (lwt_unix_job_worker)worker_getgrgid; - job->gid = Int_val(val_gid); - job->buffer = NULL; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getgrgid_result(value val_job) -{ - struct job_getgrgid *job = Job_getgrgid_val(val_job); - if (job->result != 0) unix_error(job->result, "getgrgid", Nothing); - if (job->ptr == NULL) caml_raise_not_found(); - return alloc_group_entry(&(job->grp)); -} - -CAMLprim value lwt_unix_getgrgid_free(value val_job) -{ - struct job_getgrgid *job = Job_getgrgid_val(val_job); - if (job->buffer != NULL) free(job->buffer); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: gethostname | - +-----------------------------------------------------------------+ */ - -struct job_gethostname { - struct lwt_unix_job job; - char *buffer; - int result; - int error_code; -}; - -#define Job_gethostname_val(v) *(struct job_gethostname**)Data_custom_val(v) - -static void worker_gethostname(struct job_gethostname *job) -{ - int buffer_size = 64; - int err; - - for (;;) { - - job->buffer = lwt_unix_malloc(buffer_size + 1); - - err = gethostname(job->buffer, buffer_size); - - if (err == -1 && errno == ENAMETOOLONG) { - free(job->buffer); - buffer_size *= 2; - } else { - job->buffer[buffer_size] = '\0'; - job->result = err; - job->error_code = errno; - break; - } - } -} - -CAMLprim value lwt_unix_gethostname_job() -{ - struct job_gethostname *job = lwt_unix_new(struct job_gethostname); - job->job.worker = (lwt_unix_job_worker)worker_gethostname; - job->buffer = NULL; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_gethostname_result(value val_job) -{ - struct job_gethostname *job = Job_gethostname_val(val_job); - if (job->result < 0) unix_error(job->error_code, "gethostname", Nothing); - return caml_copy_string(job->buffer); -} - -CAMLprim value lwt_unix_gethostname_free(value val_job) -{ - struct job_gethostname *job = Job_gethostname_val(val_job); - free(job->buffer); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: gethostbyname | - +-----------------------------------------------------------------+ */ - -#define NETDB_BUFFER_SIZE 10000 - -struct job_gethostbyname { - struct lwt_unix_job job; - char *name; - struct hostent entry; - struct hostent *ptr; - char buffer[NETDB_BUFFER_SIZE]; -}; - -#define Job_gethostbyname_val(v) *(struct job_gethostbyname**)Data_custom_val(v) - -CAMLexport value alloc_inet_addr (struct in_addr * inaddr); -#define GET_INET_ADDR(v) (*((struct in_addr *) (v))) - -CAMLexport value alloc_inet6_addr (struct in6_addr * inaddr); -#define GET_INET6_ADDR(v) (*((struct in6_addr *) (v))) - -static value alloc_one_addr(char const *a) -{ - struct in_addr addr; - memmove (&addr, a, 4); - return alloc_inet_addr(&addr); -} - -static value alloc_one_addr6(char const *a) -{ - struct in6_addr addr; - memmove(&addr, a, 16); - return alloc_inet6_addr(&addr); -} - -static value alloc_host_entry(struct hostent *entry) -{ - value res; - value name = Val_unit, aliases = Val_unit; - value addr_list = Val_unit, adr = Val_unit; - - Begin_roots4 (name, aliases, addr_list, adr); - name = copy_string((char *)(entry->h_name)); - /* PR#4043: protect against buggy implementations of gethostbynamee() - that return a NULL pointer in h_aliases */ - if (entry->h_aliases) - aliases = copy_string_array((const char**)entry->h_aliases); - else - aliases = Atom(0); - if (entry->h_length == 16) - addr_list = alloc_array(alloc_one_addr6, (const char**)entry->h_addr_list); - else - addr_list = alloc_array(alloc_one_addr, (const char**)entry->h_addr_list); - res = alloc_small(4, 0); - Field(res, 0) = name; - Field(res, 1) = aliases; - switch (entry->h_addrtype) { - case PF_UNIX: Field(res, 2) = Val_int(0); break; - case PF_INET: Field(res, 2) = Val_int(1); break; - default: /*PF_INET6 */ Field(res, 2) = Val_int(2); break; - } - Field(res, 3) = addr_list; - End_roots(); - return res; -} - -static void worker_gethostbyname(struct job_gethostbyname *job) -{ - int h_errno; -#if HAS_GETHOSTBYNAME_R == 5 - job->ptr = gethostbyname_r(job->name, &(job->entry), job->buffer, NETDB_BUFFER_SIZE, &h_errno); -#elif HAS_GETHOSTBYNAME_R == 6 - if (gethostbyname_r(job->name, &(job->entry), job->buffer, NETDB_BUFFER_SIZE, &(job->ptr), &h_errno) != 0) - job->ptr = NULL; -#else - job->ptr = NULL; -#endif -} - -CAMLprim value lwt_unix_gethostbyname_job(value val_name) -{ - struct job_gethostbyname *job = lwt_unix_new(struct job_gethostbyname); - job->job.worker = (lwt_unix_job_worker)worker_gethostbyname; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_gethostbyname_result(value val_job) -{ - struct job_gethostbyname *job = Job_gethostbyname_val(val_job); - if (job->ptr == NULL) caml_raise_not_found(); - return alloc_host_entry(&(job->entry)); -} - -CAMLprim value lwt_unix_gethostbyname_free(value val_job) -{ - struct job_gethostbyname *job = Job_gethostbyname_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: gethostbyaddr | - +-----------------------------------------------------------------+ */ - -struct job_gethostbyaddr { - struct lwt_unix_job job; - struct in_addr addr; - struct hostent entry; - struct hostent *ptr; - char buffer[NETDB_BUFFER_SIZE]; -}; - -#define Job_gethostbyaddr_val(v) *(struct job_gethostbyaddr**)Data_custom_val(v) - -static void worker_gethostbyaddr(struct job_gethostbyaddr *job) -{ - int h_errno; -#if HAS_GETHOSTBYADDR_R == 7 - job->ptr = gethostbyaddr_r(&(job->addr), 4, AF_INET, &(job->entry), job->buffer, NETDB_BUFFER_SIZE, &h_errno); -#elif HAS_GETHOSTBYADDR_R == 8 - if (gethostbyaddr_r(&(job->addr), 4, AF_INET, &(job->entry), job->buffer, NETDB_BUFFER_SIZE, &(job->ptr), &h_errno) != 0) - job->ptr = NULL; -#else - job->ptr = NULL; -#endif -} - -CAMLprim value lwt_unix_gethostbyaddr_job(value val_addr) -{ - struct job_gethostbyaddr *job = lwt_unix_new(struct job_gethostbyaddr); - job->job.worker = (lwt_unix_job_worker)worker_gethostbyaddr; - job->addr = GET_INET_ADDR(val_addr); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_gethostbyaddr_result(value val_job) -{ - struct job_gethostbyaddr *job = Job_gethostbyaddr_val(val_job); - if (job->ptr == NULL) caml_raise_not_found(); - return alloc_host_entry(&(job->entry)); -} - -CAMLprim value lwt_unix_gethostbyaddr_free(value val_job) -{ - struct job_gethostbyaddr *job = Job_gethostbyaddr_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getprotobyname | - +-----------------------------------------------------------------+ */ - -struct job_getprotobyname { - struct lwt_unix_job job; - char *name; - struct protoent *result; -}; - -#define Job_getprotobyname_val(v) *(struct job_getprotobyname**)Data_custom_val(v) - -static value alloc_proto_entry(struct protoent *entry) -{ - value res; - value name = Val_unit, aliases = Val_unit; - - Begin_roots2 (name, aliases); - name = copy_string(entry->p_name); - aliases = copy_string_array((const char**)entry->p_aliases); - res = alloc_small(3, 0); - Field(res,0) = name; - Field(res,1) = aliases; - Field(res,2) = Val_int(entry->p_proto); - End_roots(); - return res; -} - -static void worker_getprotobyname(struct job_getprotobyname *job) -{ - job->result = getprotobyname(job->name); -} - -CAMLprim value lwt_unix_getprotobyname_job(value val_name) -{ - struct job_getprotobyname *job = lwt_unix_new(struct job_getprotobyname); - job->job.worker = (lwt_unix_job_worker)worker_getprotobyname; - job->name = lwt_unix_strdup(String_val(val_name)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getprotobyname_result(value val_job) -{ - struct job_getprotobyname *job = Job_getprotobyname_val(val_job); - if (job->result == NULL) caml_raise_not_found(); - return alloc_proto_entry(job->result); -} - -CAMLprim value lwt_unix_getprotobyname_free(value val_job) -{ - struct job_getprotobyname *job = Job_getprotobyname_val(val_job); - free(job->name); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getprotobynumber | - +-----------------------------------------------------------------+ */ - -struct job_getprotobynumber { - struct lwt_unix_job job; - int number; - struct protoent *result; -}; - -#define Job_getprotobynumber_val(v) *(struct job_getprotobynumber**)Data_custom_val(v) - -static void worker_getprotobynumber(struct job_getprotobynumber *job) -{ - job->result = getprotobynumber(job->number); -} - -CAMLprim value lwt_unix_getprotobynumber_job(value val_number) -{ - struct job_getprotobynumber *job = lwt_unix_new(struct job_getprotobynumber); - job->job.worker = (lwt_unix_job_worker)worker_getprotobynumber; - job->number = Int_val(val_number); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getprotobynumber_result(value val_job) -{ - struct job_getprotobynumber *job = Job_getprotobynumber_val(val_job); - if (job->result == NULL) caml_raise_not_found(); - return alloc_proto_entry(job->result); -} - -CAMLprim value lwt_unix_getprotobynumber_free(value val_job) -{ - struct job_getprotobynumber *job = Job_getprotobynumber_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getservbyname | - +-----------------------------------------------------------------+ */ - -struct job_getservbyname { - struct lwt_unix_job job; - char *name; - char *proto; - struct servent *result; -}; - -#define Job_getservbyname_val(v) *(struct job_getservbyname**)Data_custom_val(v) - -static value alloc_service_entry(struct servent *entry) -{ - value res; - value name = Val_unit, aliases = Val_unit, proto = Val_unit; - - Begin_roots3 (name, aliases, proto); - name = copy_string(entry->s_name); - aliases = copy_string_array((const char**)entry->s_aliases); - proto = copy_string(entry->s_proto); - res = alloc_small(4, 0); - Field(res,0) = name; - Field(res,1) = aliases; - Field(res,2) = Val_int(ntohs(entry->s_port)); - Field(res,3) = proto; - End_roots(); - return res; -} - -static void worker_getservbyname(struct job_getservbyname *job) -{ - job->result = getservbyname(job->name, job->proto); -} - -CAMLprim value lwt_unix_getservbyname_job(value val_name, value val_proto) -{ - struct job_getservbyname *job = lwt_unix_new(struct job_getservbyname); - job->job.worker = (lwt_unix_job_worker)worker_getservbyname; - job->name = lwt_unix_strdup(String_val(val_name)); - job->proto = lwt_unix_strdup(String_val(val_proto)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getservbyname_result(value val_job) -{ - struct job_getservbyname *job = Job_getservbyname_val(val_job); - if (job->result == NULL) caml_raise_not_found(); - return alloc_service_entry(job->result); -} - -CAMLprim value lwt_unix_getservbyname_free(value val_job) -{ - struct job_getservbyname *job = Job_getservbyname_val(val_job); - free(job->name); - free(job->proto); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getservbyport | - +-----------------------------------------------------------------+ */ - -struct job_getservbyport { - struct lwt_unix_job job; - int port; - char *proto; - struct servent *result; -}; - -#define Job_getservbyport_val(v) *(struct job_getservbyport**)Data_custom_val(v) - -static void worker_getservbyport(struct job_getservbyport *job) -{ - job->result = getservbyport(job->port, job->proto); -} - -CAMLprim value lwt_unix_getservbyport_job(value val_port, value val_proto) -{ - struct job_getservbyport *job = lwt_unix_new(struct job_getservbyport); - job->job.worker = (lwt_unix_job_worker)worker_getservbyport; - job->port = Int_val(val_port); - job->proto = lwt_unix_strdup(String_val(val_proto)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getservbyport_result(value val_job) -{ - struct job_getservbyport *job = Job_getservbyport_val(val_job); - if (job->result == NULL) caml_raise_not_found(); - return alloc_service_entry(job->result); -} - -CAMLprim value lwt_unix_getservbyport_free(value val_job) -{ - struct job_getservbyport *job = Job_getservbyport_val(val_job); - free(job->proto); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getaddrinfo | - +-----------------------------------------------------------------+ */ - -struct job_getaddrinfo { - struct lwt_unix_job job; - char *node; - char *service; - struct addrinfo hints; - struct addrinfo *info; - int result; -}; - -#define Job_getaddrinfo_val(v) *(struct job_getaddrinfo**)Data_custom_val(v) - -value cst_to_constr(int n, int *tbl, int size, int deflt) -{ - int i; - for (i = 0; i < size; i++) - if (n == tbl[i]) return Val_int(i); - return Val_int(deflt); -} - -static value convert_addrinfo(struct addrinfo * a) -{ - CAMLparam0(); - CAMLlocal3(vres,vaddr,vcanonname); - union sock_addr_union sa; - socklen_t len; - - len = a->ai_addrlen; - if (len > sizeof(sa)) len = sizeof(sa); - memcpy(&sa.s_gen, a->ai_addr, len); - vaddr = alloc_sockaddr(&sa, len, -1); - vcanonname = copy_string(a->ai_canonname == NULL ? "" : a->ai_canonname); - vres = alloc_small(5, 0); - Field(vres, 0) = cst_to_constr(a->ai_family, socket_domain_table, 3, 0); - Field(vres, 1) = cst_to_constr(a->ai_socktype, socket_type_table, 4, 0); - Field(vres, 2) = Val_int(a->ai_protocol); - Field(vres, 3) = vaddr; - Field(vres, 4) = vcanonname; - CAMLreturn(vres); -} - -static void worker_getaddrinfo(struct job_getaddrinfo *job) -{ - job->result = getaddrinfo(job->node, job->service, &(job->hints), &(job->info)); -} - -CAMLprim value lwt_unix_getaddrinfo_job(value val_node, value val_service, value val_hints) -{ - struct job_getaddrinfo *job = lwt_unix_new(struct job_getaddrinfo); - job->job.worker = (lwt_unix_job_worker)worker_getaddrinfo; - job->node = caml_string_length(val_node) == 0 ? NULL : lwt_unix_strdup(String_val(val_node)); - job->service = caml_string_length(val_service) == 0 ? NULL : lwt_unix_strdup(String_val(val_service)); - job->info = NULL; - memset(&(job->hints), 0, sizeof(struct addrinfo)); - job->hints.ai_family = PF_UNSPEC; - for (/*nothing*/; Is_block(val_hints); val_hints = Field(val_hints, 1)) { - value v = Field(val_hints, 0); - if (Is_block(v)) - switch (Tag_val(v)) { - case 0: /* AI_FAMILY of socket_domain */ - job->hints.ai_family = socket_domain_table[Int_val(Field(v, 0))]; - break; - case 1: /* AI_SOCKTYPE of socket_type */ - job->hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))]; - break; - case 2: /* AI_PROTOCOL of int */ - job->hints.ai_protocol = Int_val(Field(v, 0)); - break; - } - else - switch (Int_val(v)) { - case 0: /* AI_NUMERICHOST */ - job->hints.ai_flags |= AI_NUMERICHOST; break; - case 1: /* AI_CANONNAME */ - job->hints.ai_flags |= AI_CANONNAME; break; - case 2: /* AI_PASSIVE */ - job->hints.ai_flags |= AI_PASSIVE; break; - } - } - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getaddrinfo_result(value val_job) -{ - CAMLparam1(val_job); - CAMLlocal3(vres, e, v); - struct addrinfo *r; - struct job_getaddrinfo *job = Job_getaddrinfo_val(val_job); - if (job->result != 0) unix_error(job->result, "getaddrinfo", Nothing); - vres = Val_int(0); - for (r = job->info; r != NULL; r = r->ai_next) { - e = convert_addrinfo(r); - v = alloc_small(2, 0); - Field(v, 0) = e; - Field(v, 1) = vres; - vres = v; - } - CAMLreturn(vres); -} - -CAMLprim value lwt_unix_getaddrinfo_free(value val_job) -{ - struct job_getaddrinfo *job = Job_getaddrinfo_val(val_job); - if (job->node != NULL) free(job->node); - if (job->service != NULL) free(job->service); - if (job->info != NULL) freeaddrinfo(job->info); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: getnameinfo | - +-----------------------------------------------------------------+ */ - -struct job_getnameinfo { - struct lwt_unix_job job; - union sock_addr_union addr; - socklen_t addr_len; - int opts; - char host[4096]; - char serv[1024]; - struct addrinfo *info; - int result; -}; - -#define Job_getnameinfo_val(v) *(struct job_getnameinfo**)Data_custom_val(v) - -static int getnameinfo_flag_table[] = { - NI_NOFQDN, NI_NUMERICHOST, NI_NAMEREQD, NI_NUMERICSERV, NI_DGRAM -}; - -static void worker_getnameinfo(struct job_getnameinfo *job) -{ - job->result = getnameinfo((const struct sockaddr *)&(job->addr.s_gen), job->addr_len, - job->host, sizeof(job->host), job->serv, sizeof(job->serv), - job->opts); -} - -CAMLprim value lwt_unix_getnameinfo_job(value val_sockaddr, value val_opts) -{ - struct job_getnameinfo *job = lwt_unix_new(struct job_getnameinfo); - job->job.worker = (lwt_unix_job_worker)worker_getnameinfo; - get_sockaddr(val_sockaddr, &(job->addr), &(job->addr_len)); - job->opts = convert_flag_list(val_opts, getnameinfo_flag_table); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_getnameinfo_result(value val_job) -{ - CAMLparam1(val_job); - CAMLlocal3(vres, vhost, vserv); - struct job_getnameinfo *job = Job_getnameinfo_val(val_job); - if (job->result != 0) caml_raise_not_found(); - vhost = caml_copy_string(job->host); - vserv = caml_copy_string(job->serv); - vres = alloc_small(2, 0); - Field(vres, 0) = vhost; - Field(vres, 1) = vserv; - CAMLreturn(vres); -} - -CAMLprim value lwt_unix_getnameinfo_free(value val_job) -{ - struct job_getnameinfo *job = Job_getnameinfo_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | Termios conversion | - +-----------------------------------------------------------------+ */ - -/* TODO: make it reentrant. */ - -static struct termios terminal_status; - -enum { Bool, Enum, Speed, Char, End }; - -enum { Input, Output }; - -#define iflags ((long)(&terminal_status.c_iflag)) -#define oflags ((long)(&terminal_status.c_oflag)) -#define cflags ((long)(&terminal_status.c_cflag)) -#define lflags ((long)(&terminal_status.c_lflag)) - -/* Number of fields in the terminal_io record field. Cf. unix.mli */ - -#define NFIELDS 38 - -/* Structure of the terminal_io record. Cf. unix.mli */ - -static long terminal_io_descr[] = { - /* Input modes */ - Bool, iflags, IGNBRK, - Bool, iflags, BRKINT, - Bool, iflags, IGNPAR, - Bool, iflags, PARMRK, - Bool, iflags, INPCK, - Bool, iflags, ISTRIP, - Bool, iflags, INLCR, - Bool, iflags, IGNCR, - Bool, iflags, ICRNL, - Bool, iflags, IXON, - Bool, iflags, IXOFF, - /* Output modes */ - Bool, oflags, OPOST, - /* Control modes */ - Speed, Output, - Speed, Input, - Enum, cflags, 5, 4, CSIZE, CS5, CS6, CS7, CS8, - Enum, cflags, 1, 2, CSTOPB, 0, CSTOPB, - Bool, cflags, CREAD, - Bool, cflags, PARENB, - Bool, cflags, PARODD, - Bool, cflags, HUPCL, - Bool, cflags, CLOCAL, - /* Local modes */ - Bool, lflags, ISIG, - Bool, lflags, ICANON, - Bool, lflags, NOFLSH, - Bool, lflags, ECHO, - Bool, lflags, ECHOE, - Bool, lflags, ECHOK, - Bool, lflags, ECHONL, - /* Control characters */ - Char, VINTR, - Char, VQUIT, - Char, VERASE, - Char, VKILL, - Char, VEOF, - Char, VEOL, - Char, VMIN, - Char, VTIME, - Char, VSTART, - Char, VSTOP, - End -}; - -#undef iflags -#undef oflags -#undef cflags -#undef lflags - -struct speedtable_entry ; - -static struct { - speed_t speed; - int baud; -} speedtable[] = { - {B50, 50}, - {B75, 75}, - {B110, 110}, - {B134, 134}, - {B150, 150}, - {B300, 300}, - {B600, 600}, - {B1200, 1200}, - {B1800, 1800}, - {B2400, 2400}, - {B4800, 4800}, - {B9600, 9600}, - {B19200, 19200}, - {B38400, 38400}, -#ifdef B57600 - {B57600, 57600}, -#endif -#ifdef B115200 - {B115200, 115200}, -#endif -#ifdef B230400 - {B230400, 230400}, -#endif - {B0, 0} -}; - -#define NSPEEDS (sizeof(speedtable) / sizeof(speedtable[0])) - -static void encode_terminal_status(value *dst) -{ - long * pc; - int i; - - for(pc = terminal_io_descr; *pc != End; dst++) { - switch(*pc++) { - case Bool: - { int * src = (int *) (*pc++); - int msk = *pc++; - *dst = Val_bool(*src & msk); - break; } - case Enum: - { int * src = (int *) (*pc++); - int ofs = *pc++; - int num = *pc++; - int msk = *pc++; - for (i = 0; i < num; i++) { - if ((*src & msk) == pc[i]) { - *dst = Val_int(i + ofs); - break; - } - } - pc += num; - break; } - case Speed: - { int which = *pc++; - speed_t speed = 0; - *dst = Val_int(9600); /* in case no speed in speedtable matches */ - switch (which) { - case Output: - speed = cfgetospeed(&terminal_status); break; - case Input: - speed = cfgetispeed(&terminal_status); break; - } - for (i = 0; i < NSPEEDS; i++) { - if (speed == speedtable[i].speed) { - *dst = Val_int(speedtable[i].baud); - break; - } - } - break; } - case Char: - { int which = *pc++; - *dst = Val_int(terminal_status.c_cc[which]); - break; } - } - } -} - -static void decode_terminal_status(value *src) -{ - long * pc; - int i; - - for (pc = terminal_io_descr; *pc != End; src++) { - switch(*pc++) { - case Bool: - { int * dst = (int *) (*pc++); - int msk = *pc++; - if (Bool_val(*src)) - *dst |= msk; - else - *dst &= ~msk; - break; } - case Enum: - { int * dst = (int *) (*pc++); - int ofs = *pc++; - int num = *pc++; - int msk = *pc++; - i = Int_val(*src) - ofs; - if (i >= 0 && i < num) { - *dst = (*dst & ~msk) | pc[i]; - } else { - unix_error(EINVAL, "tcsetattr", Nothing); - } - pc += num; - break; } - case Speed: - { int which = *pc++; - int baud = Int_val(*src); - int res = 0; - for (i = 0; i < NSPEEDS; i++) { - if (baud == speedtable[i].baud) { - switch (which) { - case Output: - res = cfsetospeed(&terminal_status, speedtable[i].speed); break; - case Input: - res = cfsetispeed(&terminal_status, speedtable[i].speed); break; - } - if (res == -1) uerror("tcsetattr", Nothing); - goto ok; - } - } - unix_error(EINVAL, "tcsetattr", Nothing); - ok: - break; } - case Char: - { int which = *pc++; - terminal_status.c_cc[which] = Int_val(*src); - break; } - } - } -} - -/* +-----------------------------------------------------------------+ - | JOB: tcgetattr | - +-----------------------------------------------------------------+ */ - -struct job_tcgetattr { - struct lwt_unix_job job; - int fd; - struct termios termios; - int result; - int error_code; -}; - -#define Job_tcgetattr_val(v) *(struct job_tcgetattr**)Data_custom_val(v) - -static void worker_tcgetattr(struct job_tcgetattr *job) -{ - job->result = tcgetattr(job->fd, &(job->termios)); - job->error_code = errno; -} - -CAMLprim value lwt_unix_tcgetattr_job(value val_fd) -{ - struct job_tcgetattr *job = lwt_unix_new(struct job_tcgetattr); - job->job.worker = (lwt_unix_job_worker)worker_tcgetattr; - job->fd = Int_val(val_fd); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_tcgetattr_result(value val_job) -{ - struct job_tcgetattr *job = Job_tcgetattr_val(val_job); - if (job->result < 0) unix_error(job->error_code, "tcgetattr", Nothing); - value res = alloc_tuple(NFIELDS); - memcpy(&terminal_status, &(job->termios), sizeof(struct termios)); - encode_terminal_status(&Field(res, 0)); - return res; -} - -CAMLprim value lwt_unix_tcgetattr_free(value val_job) -{ - lwt_unix_free_job(&(Job_tcgetattr_val(val_job))->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: tcsetattr | - +-----------------------------------------------------------------+ */ - -struct job_tcsetattr { - struct lwt_unix_job job; - int fd; - int when; - struct termios termios; - int result; - int error_code; -}; - -#define Job_tcsetattr_val(v) *(struct job_tcsetattr**)Data_custom_val(v) - -static int when_flag_table[] = { - TCSANOW, TCSADRAIN, TCSAFLUSH -}; - -static void worker_tcsetattr(struct job_tcsetattr *job) -{ - job->result = tcsetattr(job->fd, job->when, &(job->termios)); - job->error_code = errno; -} - -CAMLprim value lwt_unix_tcsetattr_job(value val_fd, value val_when, value val_termios) -{ - struct job_tcsetattr *job = lwt_unix_new(struct job_tcsetattr); - job->job.worker = (lwt_unix_job_worker)worker_tcsetattr; - job->fd = Int_val(val_fd); - job->when = when_flag_table[Int_val(val_when)]; - decode_terminal_status(&Field(val_termios, 0)); - memcpy(&(job->termios), &terminal_status, sizeof(struct termios)); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_tcsetattr_result(value val_job) -{ - struct job_tcsetattr *job = Job_tcsetattr_val(val_job); - if (job->result < 0) unix_error(job->error_code, "tcsetattr", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_tcsetattr_free(value val_job) -{ - lwt_unix_free_job(&(Job_tcsetattr_val(val_job))->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: tcdrain | - +-----------------------------------------------------------------+ */ - -struct job_tcdrain { - struct lwt_unix_job job; - int fd; - int result; - int error_code; -}; - -#define Job_tcdrain_val(v) *(struct job_tcdrain**)Data_custom_val(v) - -static void worker_tcdrain(struct job_tcdrain *job) -{ - job->result = tcdrain(job->fd); - job->error_code = errno; -} - -CAMLprim value lwt_unix_tcdrain_job(value val_fd) -{ - struct job_tcdrain *job = lwt_unix_new(struct job_tcdrain); - job->job.worker = (lwt_unix_job_worker)worker_tcdrain; - job->fd = Int_val(val_fd); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_tcdrain_result(value val_job) -{ - struct job_tcdrain *job = Job_tcdrain_val(val_job); - if (job->result < 0) unix_error(job->error_code, "tcdrain", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_tcdrain_free(value val_job) -{ - lwt_unix_free_job(&(Job_tcdrain_val(val_job))->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: tcflush | - +-----------------------------------------------------------------+ */ - -struct job_tcflush { - struct lwt_unix_job job; - int fd; - int queue; - int result; - int error_code; -}; - -#define Job_tcflush_val(v) *(struct job_tcflush**)Data_custom_val(v) - -static int queue_flag_table[] = { - TCIFLUSH, TCOFLUSH, TCIOFLUSH -}; - -static void worker_tcflush(struct job_tcflush *job) -{ - job->result = tcflush(job->fd, job->queue); - job->error_code = errno; -} - -CAMLprim value lwt_unix_tcflush_job(value val_fd, value val_queue) -{ - struct job_tcflush *job = lwt_unix_new(struct job_tcflush); - job->job.worker = (lwt_unix_job_worker)worker_tcflush; - job->fd = Int_val(val_fd); - job->queue = queue_flag_table[Int_val(val_queue)]; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_tcflush_result(value val_job) -{ - struct job_tcflush *job = Job_tcflush_val(val_job); - if (job->result < 0) unix_error(job->error_code, "tcflush", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_tcflush_free(value val_job) -{ - lwt_unix_free_job(&(Job_tcflush_val(val_job))->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: tcflow | - +-----------------------------------------------------------------+ */ - -struct job_tcflow { - struct lwt_unix_job job; - int fd; - int action; - int result; - int error_code; -}; - -#define Job_tcflow_val(v) *(struct job_tcflow**)Data_custom_val(v) - -static int action_flag_table[] = { - TCOOFF, TCOON, TCIOFF, TCION -}; - -static void worker_tcflow(struct job_tcflow *job) -{ - job->result = tcflow(job->fd, job->action); - job->error_code = errno; -} - -CAMLprim value lwt_unix_tcflow_job(value val_fd, value val_action) -{ - struct job_tcflow *job = lwt_unix_new(struct job_tcflow); - job->job.worker = (lwt_unix_job_worker)worker_tcflow; - job->fd = Int_val(val_fd); - job->action = action_flag_table[Int_val(val_action)]; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_tcflow_result(value val_job) -{ - struct job_tcflow *job = Job_tcflow_val(val_job); - if (job->result < 0) unix_error(job->error_code, "tcflow", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_tcflow_free(value val_job) -{ - lwt_unix_free_job(&(Job_tcflow_val(val_job))->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: tcsendbreak | - +-----------------------------------------------------------------+ */ - -struct job_tcsendbreak { - struct lwt_unix_job job; - int fd; - int delay; - int result; - int error_code; -}; - -#define Job_tcsendbreak_val(v) *(struct job_tcsendbreak**)Data_custom_val(v) - -static void worker_tcsendbreak(struct job_tcsendbreak *job) -{ - job->result = tcsendbreak(job->fd, job->delay); - job->error_code = errno; -} - -CAMLprim value lwt_unix_tcsendbreak_job(value val_fd, value val_delay) -{ - struct job_tcsendbreak *job = lwt_unix_new(struct job_tcsendbreak); - job->job.worker = (lwt_unix_job_worker)worker_tcsendbreak; - job->fd = Int_val(val_fd); - job->delay = Int_val(val_delay); - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_tcsendbreak_result(value val_job) -{ - struct job_tcsendbreak *job = Job_tcsendbreak_val(val_job); - if (job->result < 0) unix_error(job->error_code, "tcsendbreak", Nothing); - return Val_unit; -} - -CAMLprim value lwt_unix_tcsendbreak_free(value val_job) -{ - lwt_unix_free_job(&(Job_tcsendbreak_val(val_job))->job); - return Val_unit; -} diff --git a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix_windows.c b/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix_windows.c deleted file mode 100644 index c054729..0000000 --- a/server/thirdparty/lwt-2.3.2/src/unix/lwt_unix_windows.c +++ /dev/null @@ -1,484 +0,0 @@ -/* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Lwt_unix_unix - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - */ - -/* Windows version of stubs. */ - -CAMLprim value lwt_unix_is_socket(value fd) -{ - return (Val_bool(Descr_kind_val(fd) == KIND_SOCKET)); -} - -CAMLprim value lwt_unix_write(value fd, value buf, value vofs, value vlen) -{ - intnat ofs, len, written; - DWORD numbytes, numwritten; - DWORD err = 0; - - Begin_root (buf); - ofs = Long_val(vofs); - len = Long_val(vlen); - written = 0; - if (len > 0) { - numbytes = len; - if (Descr_kind_val(fd) == KIND_SOCKET) { - int ret; - SOCKET s = Socket_val(fd); - ret = send(s, &Byte(buf, ofs), numbytes, 0); - if (ret == SOCKET_ERROR) err = WSAGetLastError(); - numwritten = ret; - } else { - HANDLE h = Handle_val(fd); - if (! WriteFile(h, &Byte(buf, ofs), numbytes, &numwritten, NULL)) - err = GetLastError(); - } - if (err) { - win32_maperr(err); - uerror("write", Nothing); - } - written = numwritten; - } - End_roots(); - return Val_long(written); -} - -CAMLprim value lwt_unix_bytes_write(value fd, value buf, value vofs, value vlen) -{ - intnat ofs, len, written; - DWORD numbytes, numwritten; - DWORD err = 0; - - Begin_root (buf); - ofs = Long_val(vofs); - len = Long_val(vlen); - written = 0; - if (len > 0) { - numbytes = len; - if (Descr_kind_val(fd) == KIND_SOCKET) { - int ret; - SOCKET s = Socket_val(fd); - ret = send(s, (char*)Caml_ba_array_val(buf)->data + ofs, numbytes, 0); - if (ret == SOCKET_ERROR) err = WSAGetLastError(); - numwritten = ret; - } else { - HANDLE h = Handle_val(fd); - if (! WriteFile(h, (char*)Caml_ba_array_val(buf)->data + ofs, numbytes, &numwritten, NULL)) - err = GetLastError(); - } - if (err) { - win32_maperr(err); - uerror("write", Nothing); - } - written = numwritten; - } - End_roots(); - return Val_long(written); -} - -CAMLprim value lwt_unix_read(value fd, value buf, value vofs, value vlen) -{ - intnat ofs, len, written; - DWORD numbytes, numwritten; - DWORD err = 0; - - Begin_root (buf); - ofs = Long_val(vofs); - len = Long_val(vlen); - written = 0; - if (len > 0) { - numbytes = len; - if (Descr_kind_val(fd) == KIND_SOCKET) { - int ret; - SOCKET s = Socket_val(fd); - ret = recv(s, &Byte(buf, ofs), numbytes, 0); - if (ret == SOCKET_ERROR) err = WSAGetLastError(); - numwritten = ret; - } else { - HANDLE h = Handle_val(fd); - if (! ReadFile(h, &Byte(buf, ofs), numbytes, &numwritten, NULL)) - err = GetLastError(); - } - if (err) { - win32_maperr(err); - uerror("write", Nothing); - } - written = numwritten; - } - End_roots(); - return Val_long(written); -} - -CAMLprim value lwt_unix_bytes_read(value fd, value buf, value vofs, value vlen) -{ - intnat ofs, len, written; - DWORD numbytes, numwritten; - DWORD err = 0; - - Begin_root (buf); - ofs = Long_val(vofs); - len = Long_val(vlen); - written = 0; - if (len > 0) { - numbytes = len; - if (Descr_kind_val(fd) == KIND_SOCKET) { - int ret; - SOCKET s = Socket_val(fd); - ret = recv(s, (char*)Caml_ba_array_val(buf)->data + ofs, numbytes, 0); - if (ret == SOCKET_ERROR) err = WSAGetLastError(); - numwritten = ret; - } else { - HANDLE h = Handle_val(fd); - if (! ReadFile(h, (char*)Caml_ba_array_val(buf)->data + ofs, numbytes, &numwritten, NULL)) - err = GetLastError(); - } - if (err) { - win32_maperr(err); - uerror("write", Nothing); - } - written = numwritten; - } - End_roots(); - return Val_long(written); -} - -/* +-----------------------------------------------------------------+ - | Memory mapped files | - +-----------------------------------------------------------------+ */ - -CAMLprim value lwt_unix_get_page_size() -{ - SYSTEM_INFO si; - GetSystemInfo(&si); - return Val_long(si.dwPageSize); -} - -/* +-----------------------------------------------------------------+ - | JOB: read | - +-----------------------------------------------------------------+ */ - -struct job_read { - struct lwt_unix_job job; - union { - HANDLE handle; - SOCKET socket; - } fd; - int kind; - char *buffer; - DWORD length; - DWORD result; - DWORD error_code; -}; - -#define Job_read_val(v) *(struct job_read**)Data_custom_val(v) - -static void worker_read(struct job_read *job) -{ - if (job->kind == KIND_SOCKET) { - int ret; - ret = recv(job->fd.socket, job->buffer, job->length, 0); - if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); - job->result = ret; - } else { - if (!ReadFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) - job->error_code = GetLastError(); - } -} - -CAMLprim value lwt_unix_read_job(value val_fd, value val_length) -{ - struct job_read *job = lwt_unix_new(struct job_read); - struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); - long length = Long_val(val_length); - job->job.worker = (lwt_unix_job_worker)worker_read; - job->kind = fd->kind; - if (fd->kind == KIND_HANDLE) - job->fd.handle = fd->fd.handle; - else - job->fd.socket = fd->fd.socket; - job->buffer = (char*)lwt_unix_malloc(length); - job->length = length; - job->error_code = 0; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_read_result(value val_job, value val_string, value val_offset) -{ - struct job_read *job = Job_read_val(val_job); - if (job->error_code) { - win32_maperr(job->error_code); - uerror("read", Nothing); - } - memcpy(String_val(val_string) + Long_val(val_offset), job->buffer, job->result); - return Val_long(job->result); -} - -CAMLprim value lwt_unix_read_free(value val_job) -{ - struct job_read *job = Job_read_val(val_job); - free(job->buffer); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: bytes_read | - +-----------------------------------------------------------------+ */ - -struct job_bytes_read { - struct lwt_unix_job job; - union { - HANDLE handle; - SOCKET socket; - } fd; - int kind; - char *buffer; - DWORD length; - DWORD result; - DWORD error_code; -}; - -#define Job_bytes_read_val(v) *(struct job_bytes_read**)Data_custom_val(v) - -static void worker_bytes_read(struct job_bytes_read *job) -{ - if (job->kind == KIND_SOCKET) { - int ret; - ret = recv(job->fd.socket, job->buffer, job->length, 0); - if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); - job->result = ret; - } else { - if (!ReadFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) - job->error_code = GetLastError(); - } -} - -CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buffer, value val_offset, value val_length) -{ - struct job_bytes_read *job = lwt_unix_new(struct job_bytes_read); - struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); - long length = Long_val(val_length); - job->job.worker = (lwt_unix_job_worker)worker_bytes_read; - job->kind = fd->kind; - if (fd->kind == KIND_HANDLE) - job->fd.handle = fd->fd.handle; - else - job->fd.socket = fd->fd.socket; - job->buffer = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); - job->length = length; - job->error_code = 0; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_bytes_read_result(value val_job) -{ - struct job_bytes_read *job = Job_bytes_read_val(val_job); - if (job->error_code) { - win32_maperr(job->error_code); - uerror("bytes_read", Nothing); - } - return Val_long(job->result); -} - -CAMLprim value lwt_unix_bytes_read_free(value val_job) -{ - struct job_bytes_read *job = Job_bytes_read_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: write | - +-----------------------------------------------------------------+ */ - -struct job_write { - struct lwt_unix_job job; - union { - HANDLE handle; - SOCKET socket; - } fd; - int kind; - char *buffer; - DWORD length; - DWORD result; - DWORD error_code; -}; - -#define Job_write_val(v) *(struct job_write**)Data_custom_val(v) - -static void worker_write(struct job_write *job) -{ - if (job->kind == KIND_SOCKET) { - int ret; - ret = send(job->fd.socket, job->buffer, job->length, 0); - if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); - job->result = ret; - } else { - if (!WriteFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) - job->error_code = GetLastError(); - } -} - -CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length) -{ - struct job_write *job = lwt_unix_new(struct job_write); - struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); - long length = Long_val(val_length); - job->job.worker = (lwt_unix_job_worker)worker_write; - job->kind = fd->kind; - if (fd->kind == KIND_HANDLE) - job->fd.handle = fd->fd.handle; - else - job->fd.socket = fd->fd.socket; - job->buffer = (char*)lwt_unix_malloc(length); - memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length); - job->length = length; - job->error_code = 0; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_write_result(value val_job) -{ - struct job_write *job = Job_write_val(val_job); - if (job->error_code) { - win32_maperr(job->error_code); - uerror("write", Nothing); - } - return Val_long(job->result); -} - -CAMLprim value lwt_unix_write_free(value val_job) -{ - struct job_write *job = Job_write_val(val_job); - free(job->buffer); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: bytes_write | - +-----------------------------------------------------------------+ */ - -struct job_bytes_write { - struct lwt_unix_job job; - union { - HANDLE handle; - SOCKET socket; - } fd; - int kind; - char *buffer; - DWORD length; - DWORD result; - DWORD error_code; -}; - -#define Job_bytes_write_val(v) *(struct job_bytes_write**)Data_custom_val(v) - -static void worker_bytes_write(struct job_bytes_write *job) -{ - if (job->kind == KIND_SOCKET) { - int ret; - ret = send(job->fd.socket, job->buffer, job->length, 0); - if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); - job->result = ret; - } else { - if (!WriteFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) - job->error_code = GetLastError(); - } -} - -CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length) -{ - struct job_bytes_write *job = lwt_unix_new(struct job_bytes_write); - struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); - long length = Long_val(val_length); - job->job.worker = (lwt_unix_job_worker)worker_bytes_write; - job->kind = fd->kind; - if (fd->kind == KIND_HANDLE) - job->fd.handle = fd->fd.handle; - else - job->fd.socket = fd->fd.socket; - job->buffer = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); - job->length = length; - job->error_code = 0; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_bytes_write_result(value val_job) -{ - struct job_bytes_write *job = Job_bytes_write_val(val_job); - if (job->error_code) { - win32_maperr(job->error_code); - uerror("bytes_write", Nothing); - } - return Val_long(job->result); -} - -CAMLprim value lwt_unix_bytes_write_free(value val_job) -{ - struct job_bytes_write *job = Job_bytes_write_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} - -/* +-----------------------------------------------------------------+ - | JOB: fsync | - +-----------------------------------------------------------------+ */ - -struct job_fsync { - struct lwt_unix_job job; - HANDLE handle; - DWORD error_code; -}; - -#define Job_fsync_val(v) *(struct job_fsync**)Data_custom_val(v) - -static void worker_fsync(struct job_fsync *job) -{ - if (!FlushFileBuffers(job->handle)) - job->error_code = GetLastError(); -} - -CAMLprim value lwt_unix_fsync_job(value val_fd) -{ - struct job_fsync *job = lwt_unix_new(struct job_fsync); - struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); - job->job.worker = (lwt_unix_job_worker)worker_fsync; - job->handle = fd->fd.handle; - job->error_code = 0; - return lwt_unix_alloc_job(&(job->job)); -} - -CAMLprim value lwt_unix_fsync_result(value val_job, value val_string, value val_offset) -{ - struct job_fsync *job = Job_fsync_val(val_job); - if (job->error_code) { - win32_maperr(job->error_code); - uerror("fsync", Nothing); - } - return Val_unit; -} - -CAMLprim value lwt_unix_fsync_free(value val_job) -{ - struct job_fsync *job = Job_fsync_val(val_job); - lwt_unix_free_job(&job->job); - return Val_unit; -} diff --git a/server/thirdparty/lwt-2.3.2/syntax/META b/server/thirdparty/lwt-2.3.2/syntax/META deleted file mode 100644 index 51b02cc..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/META +++ /dev/null @@ -1,10 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: b4e6367f74716c8084939eb1c1a4ccc1) -version = "2.3.2" -description = "Lightweight thread library for Objective Caml" -requires = "camlp4.lib camlp4.quotations.o" -archive(byte) = "optcomp.cma" -archive(native) = "optcomp.cmxa" -exists_if = "optcomp.cma" -# OASIS_STOP - diff --git a/server/thirdparty/lwt-2.3.2/syntax/lwt-syntax-log.mllib b/server/thirdparty/lwt-2.3.2/syntax/lwt-syntax-log.mllib deleted file mode 100644 index 7d67f53..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/lwt-syntax-log.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3dd8f18825465abee972eb9d78d04827) -Pa_lwt_log -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/syntax/lwt-syntax-options.mllib b/server/thirdparty/lwt-2.3.2/syntax/lwt-syntax-options.mllib deleted file mode 100644 index 45f3c5c..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/lwt-syntax-options.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: b07bedaca1c4ada7f18a2dee3e3cb6a0) -Pa_lwt_options -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/syntax/lwt-syntax.mllib b/server/thirdparty/lwt-2.3.2/syntax/lwt-syntax.mllib deleted file mode 100644 index 29def8e..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/lwt-syntax.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 03396b0b9b2d52e4b95f591f2553b12d) -Pa_lwt -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/syntax/optcomp.mllib b/server/thirdparty/lwt-2.3.2/syntax/optcomp.mllib deleted file mode 100644 index 7e1c71a..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/optcomp.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 6072e4752c8626fe698fdb6438b61195) -Pa_optcomp -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/syntax/pa_lwt.ml b/server/thirdparty/lwt-2.3.2/syntax/pa_lwt.ml deleted file mode 100644 index aaa8a8d..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/pa_lwt.ml +++ /dev/null @@ -1,236 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Pa_lwt - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Camlp4 -open Camlp4.PreCast -open Syntax - -(* Generate the catching function from a macth-case. - - The main work of this functions is to add a case: - - {[ - | exn -> fail exn - ]} - - when there is not already one. *) -let gen_catch mc = - (* Does the match case have a rule of the form "| e -> ..." ? *) - let rec have_default = function - | <:match_case< $a$ | $b$ >> -> have_default a || have_default b - | <:match_case< _ -> $_$ >> - | <:match_case< $lid:_$ -> $_$ >> -> true - | _ -> false - in - if have_default mc then - mc - else - let _loc = Ast.loc_of_match_case mc in - <:match_case< $mc$ | exn -> Lwt.fail exn >> - -let gen_binding l = - let rec aux n = function - | [] -> - assert false - | [(_loc, p, e)] -> - <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ >> - | (_loc, p, e) :: l -> - <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ and $aux (n + 1) l$ >> - in - aux 0 l - -let gen_bind l e = - let rec aux n = function - | [] -> - e - | (_loc, p, e) :: l -> - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> - else - <:expr< Lwt.bind $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> - in - aux 0 l - -let gen_top_bind _loc l = - let rec aux n vars = function - | [] -> - <:expr< Lwt.return ($tup:Ast.exCom_of_list (List.rev vars)$) >> - | (_loc, p, e) :: l -> - let id = "__pa_lwt_" ^ string_of_int n in - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> - else - <:expr< Lwt.bind $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> - in - aux 0 [] l - -EXTEND Gram - GLOBAL: expr str_item; - - cases: - [ [ "with"; c = match_case -> Some(gen_catch c) - | -> None ] ]; - - finally: - [ [ "finally"; f = sequence -> Some f - | -> None ] ]; - - letb_binding: - [ [ b1 = SELF; "and"; b2 = SELF -> b1 @ b2 - | p = patt; "="; e = expr -> [(_loc, p, e)] - ] ]; - - for_scheme: - [ [ "="; s = sequence; "to"; e = sequence -> - `CountTo(s, e) - | "="; s = sequence; "downto"; e = sequence -> - `CountDownTo(s, e) - | "in"; e = sequence -> - `IterOver(e) ] ]; - - expr: LEVEL "top" - [ [ "try_lwt"; e = expr LEVEL ";"; c = cases; f = finally -> - begin match c, f with - | None, None -> - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) Lwt.fail >> - else - <:expr< Lwt.catch (fun () -> $e$) Lwt.fail >> - | Some c, None -> - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (function $c$) >> - else - <:expr< Lwt.catch (fun () -> $e$) (function $c$) >> - | None, Some f -> - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_finalize (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (fun () -> (begin $f$ end)) >> - else - <:expr< Lwt.finalize (fun () -> $e$) (fun () -> (begin $f$ end)) >> - | Some c, Some f -> - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_try_bind (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) - (fun __pa_lwt_x -> Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) (begin $f$ end) (fun () -> Lwt.return __pa_lwt_x)) - (fun __pa_lwt_e -> Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) (begin $f$ end) (fun () -> match __pa_lwt_e with $c$)) - >> - else - <:expr< Lwt.try_bind (fun () -> $e$) - (fun __pa_lwt_x -> Lwt.bind (begin $f$ end) (fun () -> Lwt.return __pa_lwt_x)) - (fun __pa_lwt_e -> Lwt.bind (begin $f$ end) (fun () -> match __pa_lwt_e with $c$)) - >> - end - - | "lwt"; l = letb_binding; "in"; e = expr LEVEL ";" -> - <:expr< let $gen_binding l$ in $gen_bind l e$ >> - - | "for_lwt"; p = patt; scheme = for_scheme; "do"; seq = do_sequence -> - (match p, scheme with - | <:patt< $lid:id$ >>, `CountTo(s, e) -> - <:expr< let __pa_lwt_max = $e$ in - let rec __pa_lwt_loop $lid:id$ = - if $lid:id$ > __pa_lwt_max then - Lwt.return () - else - Lwt.bind (begin $seq$ end) (fun () -> __pa_lwt_loop ($lid:id$ + 1)) - in - __pa_lwt_loop $s$ - >> - - | <:patt< $lid:id$ >>, `CountDownTo(s, e) -> - <:expr< let __pa_lwt_min = $e$ in - let rec __pa_lwt_loop $lid:id$ = - if $lid:id$ < __pa_lwt_min then - Lwt.return () - else - Lwt.bind (begin $seq$ end) (fun () -> __pa_lwt_loop ($lid:id$ - 1)) - in - __pa_lwt_loop $s$ - >> - - | p, `IterOver(e) -> - <:expr< Lwt_stream.iter_s (fun $p$ -> $seq$) $e$ >> - - | _ -> - Loc.raise _loc (Failure "syntax error")) - - | "raise_lwt"; e = SELF -> - if !Pa_lwt_options.debug then - <:expr< Lwt.fail (try raise $e$ with exn -> exn) >> - else - <:expr< Lwt.fail $e$ >> - - | "assert_lwt"; e = SELF -> - <:expr< try Lwt.return (assert $e$) with exn -> Lwt.fail exn >> - - | "while_lwt"; cond = sequence; "do"; body = sequence; "done" -> - <:expr< - let rec __pa_lwt_loop () = - if $cond$ then - Lwt.bind (begin $body$ end) __pa_lwt_loop - else - Lwt.return () - in - __pa_lwt_loop () - >> - - | "match_lwt"; e = sequence; "with"; c = match_case -> - <:expr< - Lwt.bind (begin $e$ end) (function $c$) - >> - ] ]; - - str_item: - [ [ "lwt"; l = letb_binding -> begin - match l with - | [(_loc, p, e)] -> - <:str_item< - let $p$ = Lwt_main.run $e$ - >> - | _ -> - <:str_item< - let $tup:Ast.paCom_of_list (List.map (fun (_loc, p, e) -> p) l)$ = - Lwt_main.run begin - let $gen_binding l$ in - $gen_top_bind _loc l$ - end - >> - end - | "lwt"; l = letb_binding; "in"; e = expr -> - <:str_item< let () = Lwt_main.run (let $gen_binding l$ in $gen_bind l e$) >> - ] ]; -END - -(* Replace the anonymous bind [x >> y] by [x >>= fun _ -> y] or [x >>= fun () -> - y] if the strict sequence flag is used. *) -let map_anonymous_bind = object - inherit Ast.map as super - method expr e = match super#expr e with - | <:expr@_loc< $lid:f$ $a$ $b$ >> when f = ">>" -> - if !Pa_lwt_options.strict_sequence then - <:expr< Lwt.bind $a$ (fun () -> $b$) >> - else - <:expr< Lwt.bind $a$ (fun _ -> $b$) >> - | e -> e -end - -let _ = - AstFilters.register_str_item_filter map_anonymous_bind#str_item; - AstFilters.register_topphrase_filter map_anonymous_bind#str_item diff --git a/server/thirdparty/lwt-2.3.2/syntax/pa_lwt.mli b/server/thirdparty/lwt-2.3.2/syntax/pa_lwt.mli deleted file mode 100644 index 6141166..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/pa_lwt.mli +++ /dev/null @@ -1,175 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Pa_lwt - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Syntactic sugars for lwt *) - -(** This extension add the following sugars: - - - anonymous bind: - - {[ - write stdio "Hello, " >> write stdio "world!" - ]} - - - lwt-binding: - - {[ - lwt ch = get_char stdin in - code - ]} - - is the same as [bind (get_char stdin) (fun ch -> code)] - - Moreover it supports parallel binding: - - {[ - lwt x = do_something1 () - and y = do_something2 in - code - ]} - - will let [do_something1 ()] and [do_something2 ()] runs then - bind their result to [x] and [y]. It is the same as: - - {[ - let t1 = do_something1 - and t2 = do_something2 in - bind t1 (fun x -> bind t2 (fun y -> code)) - ]} - - - exception catching: - - {[ - try_lwt - - ]}, - - {[ - try_lwt - - with - - ]}, - - {[ - try_lwt - - finally - - ]} - - and: - - {[ - try_lwt - - with - - finally - - ]} - - For example: - - {[ - try_lwt - f x - with - | Failure msg -> - prerr_endline msg; - return () - ]} - - is expanded to: - - {[ - catch (fun _ -> f x) - (function - | Failure msg -> - prerr_endline msg; - return () - | exn -> - Lwt.fail exn) - ]} - - Note that the [exn -> Lwt.fail exn] branch is automatically addedd - when needed. - - The construction [try_lwt ] just catch regular exception - into lwt exception. i.e. it is the same as [catch (fun _ -> ) fail]. - - - exception raising: - - {[ - raise_lwt - ]} - - This allow exception to be traced when the -lwt-debug switch is passed - to the syntax extension. - - - assertion: - - {[ - assert_lwt - ]} - - - for loop: - - {[ - for_lwt i = to do - - done - ]} - - and: - - {[ - for_lwt i = downto do - - done - ]} - - - iteration over streams: - - {[ - for_lwt in do - - done - ]} - - - while loop: - - {[ - while_lwt do - - done - ]} - - - pattern mattching: - - {[ - match_lwt with - | -> - ... - | -> - ]} -*) diff --git a/server/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.ml b/server/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.ml deleted file mode 100644 index 5bf451c..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.ml +++ /dev/null @@ -1,127 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Pa_lwt_log - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Camlp4.PreCast - -let levels = [ - "Fatal"; - "Error"; - "Warning"; - "Notice"; - "Info"; - "Debug"; -] - -let module_name _loc = - let file_name = Loc.file_name _loc in - if file_name = "" then - "" - else - String.capitalize (Filename.basename (try - Filename.chop_extension file_name - with Invalid_argument _ -> - file_name)) - -let rec apply e = function - | [] -> e - | x :: l -> let _loc = Ast.loc_of_expr x in apply <:expr< $e$ $x$ >> l - -let split e = - let rec aux section acc = function - | <:expr@_loc< Lwt_log.$lid:func$ >> -> - let level = - String.capitalize ( - let len = String.length func in - if len >= 2 && func.[len - 2] = '_' && func.[len - 1] = 'f' then - String.sub func 0 (len - 2) - else - func - ) - in - if level = "Debug" && (not !Pa_lwt_options.debug) then - `Delete - else if List.mem level levels then - `Log(func, section, level, acc) - else - `Not_a_log - | <:expr@loc< $a$ $b$ >> -> begin - match b with - | <:expr< ~section >> -> - aux `Label (b :: acc) a - | <:expr@_loc< ~section:$section$ >> -> - aux (`Expr section) (<:expr< ~section:__pa_log_section >> :: acc) a - | b -> - aux section (b :: acc) a - end - | _ -> - `Not_a_log - in - aux `None [] e - -let make_loc _loc = - <:expr< - ($str:Loc.file_name _loc$, - $int:string_of_int (Loc.start_line _loc)$, - $int:string_of_int (Loc.start_off _loc - Loc.start_bol _loc)$) - >> - -let map = -object - inherit Ast.map as super - - method expr e = - let _loc = Ast.loc_of_expr e in - match split e with - | `Delete -> - <:expr< Lwt.return () >> - | `Log(func, `None, level, args) -> - let args = List.map super#expr args in - <:expr< - if Lwt_log.$uid:level$ >= Lwt_log.Section.level Lwt_log.Section.main then - $apply <:expr< Lwt_log.$lid:func$ ~location:$make_loc _loc$ >> args$ - else - Lwt.return () - >> - | `Log(func, `Label, level, args) -> - let args = List.map super#expr args in - <:expr< - if Lwt_log.$uid:level$ >= Lwt_log.Section.level section then - $apply <:expr< Lwt_log.$lid:func$ ~location:$make_loc _loc$ >> args$ - else - Lwt.return () - >> - | `Log(func, `Expr section, level, args) -> - let args = List.map super#expr args in - <:expr< - let __pa_log_section = $section$ in - if Lwt_log.$uid:level$ >= Lwt_log.Section.level __pa_log_section then - $apply <:expr< Lwt_log.$lid:func$ ~location:$make_loc _loc$ >> args$ - else - Lwt.return () - >> - | `Not_a_log -> - super#expr e -end - -let () = - AstFilters.register_str_item_filter map#str_item; - AstFilters.register_topphrase_filter map#str_item; diff --git a/server/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.mli b/server/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.mli deleted file mode 100644 index 46ca612..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.mli +++ /dev/null @@ -1,47 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Pa_lwt_log - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Logging facility - - It replaces expression of the form: - - {[ - Lwt_log.info_f ~section "x = %d" x - ]} - - by - - {[ - if Lwt_log.Section.level section <= Lwt_log.Info then - Lwt_log.info_f ~section "x = %d" x - else - return () - ]} - - Note: - - - the application must be complete. For example: [Log.info "%d"] - will make compilation to fail - - - it also add the command line flags "-lwt-debug" to keep all debug - messages. By default debug messages are removed. -*) diff --git a/server/thirdparty/lwt-2.3.2/syntax/pa_lwt_options.ml b/server/thirdparty/lwt-2.3.2/syntax/pa_lwt_options.ml deleted file mode 100644 index e980743..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/pa_lwt_options.ml +++ /dev/null @@ -1,31 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Pa_lwt_options - * Copyright (C) 2010 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -let debug = ref false -let strict_sequence = ref false - -let () = - Camlp4.Options.add "-lwt-debug" (Arg.Set debug) "debugging mode" - -let () = - Camlp4.Options.add "-lwt-strict-sequence" (Arg.Set strict_sequence) - "check left hand side of >> for non unit expressions " diff --git a/server/thirdparty/lwt-2.3.2/syntax/pa_optcomp.ml b/server/thirdparty/lwt-2.3.2/syntax/pa_optcomp.ml deleted file mode 100644 index 583248f..0000000 --- a/server/thirdparty/lwt-2.3.2/syntax/pa_optcomp.ml +++ /dev/null @@ -1,709 +0,0 @@ -(* - * pa_optcomp.ml - * ------------- - * Copyright : (c) 2008, Jeremie Dimino - * Licence : BSD3 - * - * This file is a part of optcomp. - *) - -open Camlp4.Sig -open Camlp4.PreCast - -external filter : 'a Gram.not_filtered -> 'a = "%identity" -external not_filtered : 'a -> 'a Gram.not_filtered = "%identity" - -(* Subset of supported caml types *) -type typ = - | Tvar of string - | Tbool - | Tint - | Tchar - | Tstring - | Ttuple of typ list - -(* Subset of supported caml values *) -type value = - | Bool of bool - | Int of int - | Char of char - | String of string - | Tuple of value list - -type ident = string - (* An identifier. It is either a lower or a upper identifier. *) - -module Env = Map.Make(struct type t = ident let compare = compare end) - -type env = value Env.t - -type directive = - | Dir_let of ident * Ast.expr - | Dir_default of ident * Ast.expr - | Dir_if of Ast.expr - | Dir_else - | Dir_elif of Ast.expr - | Dir_endif - | Dir_include of Ast.expr - | Dir_error of Ast.expr - | Dir_warning of Ast.expr - | Dir_directory of Ast.expr - - (* This one is not part of optcomp but this is one of the directives - handled by camlp4 we probably want to use. *) - | Dir_default_quotation of Ast.expr - -(* Quotations are evaluated by the token filters, but are expansed - after. Evaluated quotations are kept in this table, which quotation - id to to values: *) -let quotations : (int, value) Hashtbl.t = Hashtbl.create 42 - -let next_quotation_id = - let r = ref 0 in - fun _ -> incr r; !r - -(* +-------------+ - | Environment | - +-------------+ *) - -let env = ref Env.empty -let define id value = env := Env.add id value !env - -let _ = - define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> Tuple [Int major; Int minor])) - -let dirs = ref [] -let add_include_dir dir = dirs := dir :: !dirs - -(* +--------------+ - | Dependencies | - +--------------+ *) - -module String_set = Set.Make(String) - -(* All depencies of the file being parsed *) -let dependencies = ref String_set.empty - -(* Where to write dependencies *) -let dependency_filename = ref None - -(* The file being parsed. This is set when the first (token, location) - pair is fetched. *) -let source_filename = ref None - -let write_depencies () = - match !dependency_filename, !source_filename with - | None, _ - | _, None -> - () - - | Some dependency_filename, Some source_filename -> - let oc = open_out dependency_filename in - if not (String_set.is_empty !dependencies) then begin - output_string oc "# automatically generated by optcomp\n"; - output_string oc source_filename; - output_string oc ": "; - output_string oc (String.concat " " (String_set.elements !dependencies)); - output_char oc '\n' - end; - close_out oc - -(* +----------------------------------------+ - | Value to expression/pattern conversion | - +----------------------------------------+ *) - -let rec expr_of_value _loc = function - | Bool true -> <:expr< true >> - | Bool false -> <:expr< false >> - | Int x -> <:expr< $int:string_of_int x$ >> - | Char x -> <:expr< $chr:Char.escaped x$ >> - | String x -> <:expr< $str:String.escaped x$ >> - | Tuple [] -> <:expr< () >> - | Tuple [x] -> expr_of_value _loc x - | Tuple l -> <:expr< $tup:Ast.exCom_of_list (List.map (expr_of_value _loc) l)$ >> - -let rec patt_of_value _loc = function - | Bool true -> <:patt< true >> - | Bool false -> <:patt< false >> - | Int x -> <:patt< $int:string_of_int x$ >> - | Char x -> <:patt< $chr:Char.escaped x$ >> - | String x -> <:patt< $str:String.escaped x$ >> - | Tuple [] -> <:patt< () >> - | Tuple [x] -> patt_of_value _loc x - | Tuple l -> <:patt< $tup:Ast.paCom_of_list (List.map (patt_of_value _loc) l)$ >> - -(* +-----------------------+ - | Expression evaluation | - +-----------------------+ *) - -let rec type_of_value = function - | Bool _ -> Tbool - | Int _ -> Tint - | Char _ -> Tchar - | String _ -> Tstring - | Tuple l -> Ttuple (List.map type_of_value l) - -let rec string_of_type = function - | Tvar v -> "'" ^ v - | Tbool -> "bool" - | Tint -> "int" - | Tchar -> "char" - | Tstring -> "string" - | Ttuple l -> "(" ^ String.concat " * " (List.map string_of_type l) ^ ")" - -let invalid_type loc expected real = - Loc.raise loc (Failure - (Printf.sprintf "this expression has type %s but is used with type %s" - (string_of_type real) (string_of_type expected))) - -let type_of_patt patt = - let rec aux (a, n) = function - | <:patt< $tup:x$ >> -> - let l, x = List.fold_left - (fun (l, x) patt -> let t, x = aux x patt in (t :: l, x)) - ([], (a, n)) (Ast.list_of_patt x []) in - (Ttuple(List.rev l), x) - | _ -> - (Tvar(Printf.sprintf "%c%s" - (char_of_int (Char.code 'a' + a)) - (if n = 0 then "" else string_of_int n)), - if a = 25 then (0, n + 1) else (a + 1, n)) - in - fst (aux (0, 0) patt) - -let rec eval env = function - - (* Literals *) - | <:expr< true >> -> Bool true - | <:expr< false >> -> Bool false - | <:expr< $int:x$ >> -> Int(int_of_string x) - | <:expr< $chr:x$ >> -> Char(Camlp4.Struct.Token.Eval.char x) - | <:expr< $str:x$ >> -> String(Camlp4.Struct.Token.Eval.string ~strict:() x) - - (* Tuples *) - | <:expr< $tup:x$ >> -> Tuple(List.map (eval env) (Ast.list_of_expr x [])) - - (* Variables *) - | <:expr@loc< $lid:x$ >> - | <:expr@loc< $uid:x$ >> -> - begin try - Env.find x env - with - Not_found -> - Loc.raise loc (Failure (Printf.sprintf "unbound value %s" x)) - end - - (* Value comparing *) - | <:expr< $x$ = $y$ >> -> let x, y = eval_same env x y in Bool(x = y) - | <:expr< $x$ < $y$ >> -> let x, y = eval_same env x y in Bool(x < y) - | <:expr< $x$ > $y$ >> -> let x, y = eval_same env x y in Bool(x > y) - | <:expr< $x$ <= $y$ >> -> let x, y = eval_same env x y in Bool(x <= y) - | <:expr< $x$ >= $y$ >> -> let x, y = eval_same env x y in Bool(x >= y) - | <:expr< $x$ <> $y$ >> -> let x, y = eval_same env x y in Bool(x <> y) - - (* min and max *) - | <:expr< min $x$ $y$ >> -> let x, y = eval_same env x y in min x y - | <:expr< max $x$ $y$ >> -> let x, y = eval_same env x y in max x y - - (* Arithmetic *) - | <:expr< $x$ + $y$ >> -> Int(eval_int env x + eval_int env y) - | <:expr< $x$ - $y$ >> -> Int(eval_int env x - eval_int env y) - | <:expr< $x$ * $y$ >> -> Int(eval_int env x * eval_int env y) - | <:expr< $x$ / $y$ >> -> Int(eval_int env x / eval_int env y) - | <:expr< $x$ mod $y$ >> -> Int(eval_int env x mod eval_int env y) - - (* Boolean operations *) - | <:expr< not $x$ >> -> Bool(not (eval_bool env x)) - | <:expr< $x$ or $y$ >> -> Bool(eval_bool env x or eval_bool env y) - | <:expr< $x$ || $y$ >> -> Bool(eval_bool env x || eval_bool env y) - | <:expr< $x$ && $y$ >> -> Bool(eval_bool env x && eval_bool env y) - - (* String operations *) - | <:expr< $x$ ^ $y$ >> -> String(eval_string env x ^ eval_string env y) - - (* Pair operations *) - | <:expr< fst $x$ >> -> fst (eval_pair env x) - | <:expr< snd $x$ >> -> snd (eval_pair env x) - - (* Let-binding *) - | <:expr< let $p$ = $x$ in $y$ >> -> - let vx = eval env x in - let env = - try - bind env p vx - with - Exit -> invalid_type (Ast.loc_of_expr x) (type_of_patt p) (type_of_value vx) - in - eval env y - - | e -> Loc.raise (Ast.loc_of_expr e) (Stream.Error "expression not supported") - -and bind env patt value = match patt with - | <:patt< $lid:id$ >> -> - Env.add id value env - - | <:patt< $tup:patts$ >> -> - let patts = Ast.list_of_patt patts [] in - begin match value with - | Tuple values when List.length values = List.length patts -> - List.fold_left2 bind env patts values - | _ -> - raise Exit - end - - | _ -> - Loc.raise (Ast.loc_of_patt patt) (Stream.Error "pattern not supported") - -and eval_same env ex ey = - let vx = eval env ex and vy = eval env ey in - let tx = type_of_value vx and ty = type_of_value vy in - if tx = ty then - (vx, vy) - else - invalid_type (Ast.loc_of_expr ey) tx ty - -and eval_int env e = match eval env e with - | Int x -> x - | v -> invalid_type (Ast.loc_of_expr e) Tint (type_of_value v) - -and eval_bool env e = match eval env e with - | Bool x -> x - | v -> invalid_type (Ast.loc_of_expr e) Tbool (type_of_value v) - -and eval_string env e = match eval env e with - | String x -> x - | v -> invalid_type (Ast.loc_of_expr e) Tstring (type_of_value v) - -and eval_pair env e = match eval env e with - | Tuple [x; y] -> (x, y) - | v -> invalid_type (Ast.loc_of_expr e) (Ttuple [Tvar "a"; Tvar "b"]) (type_of_value v) - -(* +-----------------------+ - | Parsing of directives | - +-----------------------+ *) - -let rec skip_space stream = match Stream.peek stream with - | Some((BLANKS _ | COMMENT _), _) -> - Stream.junk stream; - skip_space stream - | _ -> - () - -let parse_equal stream = - skip_space stream; - match Stream.next stream with - | KEYWORD "=", _ -> () - | _, loc -> Loc.raise loc (Stream.Error "'=' expected") - -let rec parse_eol stream = - let tok, loc = Stream.next stream in - match tok with - | BLANKS _ | COMMENT _ -> - parse_eol stream - | NEWLINE | EOI -> - () - | _ -> - Loc.raise loc (Stream.Error "end of line expected") - -(* Return wether a keyword can be interpreted as an identifier *) -let keyword_is_id str = - let rec aux i = - if i = String.length str then - true - else - match str.[i] with - | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' -> - aux (i + 1) - | _ -> - false - in - aux 0 - -let parse_ident stream = - skip_space stream; - let tok, loc = Stream.next stream in - begin match tok with - | LIDENT id | UIDENT id -> - id - | KEYWORD kwd when keyword_is_id kwd -> - kwd - | _ -> - Loc.raise loc (Stream.Error "identifier expected") - end - -let parse_expr stream = - (* Lists of opened brackets *) - let opened_brackets = ref [] in - - (* Return the next token of [stream] until all opened parentheses - have been closed and a newline is reached *) - let rec next_token _ = - Some(match Stream.next stream, !opened_brackets with - | (NEWLINE, loc), [] -> - EOI, loc - - | (KEYWORD("(" | "[" | "{" as b), _) as x, l -> - opened_brackets := b :: l; - x - - | (KEYWORD ")", loc) as x, "(" :: l -> - opened_brackets := l; - x - - | (KEYWORD "]", loc) as x, "[" :: l -> - opened_brackets := l; - x - - | (KEYWORD "}", loc) as x, "{" :: l -> - opened_brackets := l; - x - - | x, _ -> - x) - in - - Gram.parse_tokens_before_filter Syntax.expr_eoi - (not_filtered (Stream.from next_token)) - -let parse_directive stream = match Stream.peek stream with - | Some(KEYWORD "#", loc) -> - Stream.junk stream; - - (* Move the location to the beginning of the line *) - let (file_name, - start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, - ghost) = Loc.to_tuple loc in - let loc = Loc.of_tuple (file_name, - start_line, start_bol, start_bol, - start_line, start_bol, start_bol, - ghost) in - - begin match parse_ident stream with - - | "let" -> - let id = parse_ident stream in - parse_equal stream; - let expr = parse_expr stream in - Some(Dir_let(id, expr), loc) - - | "let_default" -> - let id = parse_ident stream in - parse_equal stream; - let expr = parse_expr stream in - Some(Dir_default(id, expr), loc) - - (* For compatibility *) - | "define" -> - let id = parse_ident stream in - let expr = parse_expr stream in - Some(Dir_let(id, expr), loc) - - (* For compatibility *) - | "default" -> - let id = parse_ident stream in - let expr = parse_expr stream in - Some(Dir_default(id, expr), loc) - - | "if" -> - Some(Dir_if(parse_expr stream), loc) - - | "else" -> - parse_eol stream; - Some(Dir_else, loc) - - | "elif" -> - Some(Dir_elif(parse_expr stream), loc) - - | "endif" -> - parse_eol stream; - Some(Dir_endif, loc) - - | "include" -> - Some(Dir_include(parse_expr stream), loc) - - | "directory" -> - Some(Dir_directory(parse_expr stream), loc) - - | "error" -> - Some(Dir_error(parse_expr stream), loc) - - | "warning" -> - Some(Dir_warning(parse_expr stream), loc) - - | "default_quotation" -> - Some(Dir_default_quotation(parse_expr stream), loc) - - | dir -> - Loc.raise loc (Stream.Error (Printf.sprintf "bad directive ``%s''" dir)) - end - - | _ -> - None - -let parse_command_line_define str = - match Gram.parse_string Syntax.expr (Loc.mk "") str with - | <:expr< $lid:id$ = $e$ >> - | <:expr< $uid:id$ = $e$ >> -> define id (eval !env e) - | _ -> invalid_arg str - -(* +----------------+ - | BLock skipping | - +----------------+ *) - -let rec skip_line stream = - match Stream.next stream with - | NEWLINE, _ -> () - | EOI, loc -> Loc.raise loc (Stream.Error "#endif missing") - | _ -> skip_line stream - -let rec next_directive stream = match parse_directive stream with - | Some dir -> dir - | None -> skip_line stream; next_directive stream - -let rec next_endif stream = - let dir, loc = next_directive stream in - match dir with - | Dir_if _ -> skip_if stream; next_endif stream - | Dir_else - | Dir_elif _ - | Dir_endif -> dir - | _ -> next_endif stream - -and skip_if stream = - let dir, loc = next_directive stream in - match dir with - | Dir_if _ -> - skip_if stream; - skip_if stream - - | Dir_else -> - skip_else stream - - | Dir_elif _ -> - skip_if stream - - | Dir_endif -> - () - - | _ -> skip_if stream - -and skip_else stream = - let dir, loc = next_directive stream in - match dir with - | Dir_if _ -> - skip_if stream; - skip_else stream - - | Dir_else -> - Loc.raise loc (Stream.Error "#else without #if") - - | Dir_elif _ -> - Loc.raise loc (Stream.Error "#elif without #if") - - | Dir_endif -> - () - - | _ -> - skip_else stream - -(* +-----------------+ - | Token filtering | - +-----------------+ *) - -type context = Ctx_if | Ctx_else - -(* State of the token filter *) -type state = { - stream : (Gram.Token.t * Loc.t) Stream.t; - (* Input stream *) - - mutable bol : bool; - (* Wether we are at the beginning of a line *) - - mutable stack : context list; - (* Nested contexts *) - - on_eoi : Gram.Token.t * Loc.t -> Gram.Token.t * Loc.t; - (* Eoi handler, it is used to restore the previous sate on #include - directives *) -} - -(* Read and return one token *) -let really_read state = - let tok, loc = Stream.next state.stream in - state.bol <- tok = NEWLINE; - match tok with - | QUOTATION ({ q_name = "optcomp" } as quot) -> - let id = next_quotation_id () in - Hashtbl.add quotations id (eval !env (Gram.parse_string - Syntax.expr_eoi - (Loc.move `start quot.q_shift loc) - quot.q_contents)); - - (* Replace the quotation by its id *) - (QUOTATION { quot with q_contents = string_of_int id }, loc) - - | EOI -> - (* If end of input is reached, we call the eoi handler. It may - continue if we were parsing an included file *) - if state.stack <> [] then - Loc.raise loc (Stream.Error "#endif missing"); - state.on_eoi (tok, loc) - - | _ -> - (tok, loc) - -(* Return the next token from a stream, interpreting directives. *) -let rec next_token state_ref = - let state = !state_ref in - if state.bol then - match parse_directive state.stream, state.stack with - | Some(Dir_if e, _), _ -> - let rec aux e = - if eval_bool !env e then begin - state.stack <- Ctx_if :: state.stack; - next_token state_ref - end else - match next_endif state.stream with - | Dir_else -> - state.stack <- Ctx_else :: state.stack; - next_token state_ref - - | Dir_elif e -> - aux e - - | Dir_endif -> - next_token state_ref - - | _ -> - assert false - in - aux e - - | Some(Dir_else, loc), ([] | Ctx_else :: _) -> - Loc.raise loc (Stream.Error "#else without #if") - - | Some(Dir_elif _, loc), ([] | Ctx_else :: _) -> - Loc.raise loc (Stream.Error "#elif without #if") - - | Some(Dir_endif, loc), [] -> - Loc.raise loc (Stream.Error "#endif without #if") - - | Some(Dir_else, loc), Ctx_if :: l -> - skip_else state.stream; - state.stack <- l; - next_token state_ref - - | Some(Dir_elif _, loc), Ctx_if :: l -> - skip_if state.stream; - state.stack <- l; - next_token state_ref - - | Some(Dir_endif, loc), _ :: l -> - state.stack <- l; - next_token state_ref - - | Some(Dir_let(id, e), _), _ -> - define id (eval !env e); - next_token state_ref - - | Some(Dir_default(id, e), _), _ -> - if not (Env.mem id !env) then - define id (eval !env e); - next_token state_ref - - | Some(Dir_include e, _), _ -> - let fname = eval_string !env e in - (* Try to looks up in all include directories *) - let fname = - try - List.find (fun dir -> Sys.file_exists (Filename.concat dir fname)) !dirs - with - (* Just try in the current directory *) - Not_found -> fname - in - dependencies := String_set.add fname !dependencies; - let ic = open_in fname in - let nested_state = { - stream = Gram.Token.Filter.filter (Gram.get_filter ()) (filter (Gram.lex (Loc.mk fname) (Stream.of_channel ic))); - bol = true; - stack = []; - on_eoi = (fun _ -> - (* Restore previous state and close channel on - eoi *) - state_ref := state; - close_in ic; - next_token state_ref) - } in - (* Replace current state with the new one *) - state_ref := nested_state; - next_token state_ref - - | Some(Dir_directory e, loc), _ -> - let dir = eval_string !env e in - add_include_dir dir; - next_token state_ref - - | Some(Dir_error e, loc), _ -> - Loc.raise loc (Failure (eval_string !env e)) - - | Some(Dir_warning e, loc), _ -> - Syntax.print_warning loc (eval_string !env e); - next_token state_ref - - | Some(Dir_default_quotation e, loc), _ -> - Syntax.Quotation.default := eval_string !env e; - next_token state_ref - - | None, _ -> - really_read state - - else - really_read state - -let stream_filter filter stream = - (* Set the source filename *) - begin match !source_filename with - | Some _ -> - () - | None -> - match Stream.peek stream with - | None -> - () - | Some(tok, loc) -> - source_filename := Some(Loc.file_name loc) - end; - let state_ref = ref { stream = stream; - bol = true; - stack = []; - on_eoi = (fun x -> x) } in - filter (Stream.from (fun _ -> Some(next_token state_ref))) - -(* +----------------------+ - | Quotations expansion | - +----------------------+ *) - -let expand f loc _ contents = - try - f loc (Hashtbl.find quotations (int_of_string contents)) - with - exn -> Loc.raise loc (Failure "fatal error in optcomp!") - -(* +--------------+ - | Registration | - +--------------+ *) - -let _ = - Camlp4.Options.add "-let" (Arg.String parse_command_line_define) - " Binding for a #let directive."; - Camlp4.Options.add "-depend" - (Arg.String (fun filename -> dependency_filename := Some filename)) - " Write dependencies to ."; - - Pervasives.at_exit write_depencies; - - Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.expr_tag (expand expr_of_value); - Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.patt_tag (expand patt_of_value); - - Gram.Token.Filter.define_filter (Gram.get_filter ()) stream_filter diff --git a/server/thirdparty/lwt-2.3.2/tests/META b/server/thirdparty/lwt-2.3.2/tests/META deleted file mode 100644 index ceba0ee..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/META +++ /dev/null @@ -1,9 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 5cec65fa74f26fc5d2c2466b1d89ccdf) -version = "2.3.2" -description = "Lightweight thread library for Objective Caml" -archive(byte) = "test.cma" -archive(native) = "test.cmxa" -exists_if = "test.cma" -# OASIS_STOP - diff --git a/server/thirdparty/lwt-2.3.2/tests/core/main.ml b/server/thirdparty/lwt-2.3.2/tests/core/main.ml deleted file mode 100644 index 44aa78a..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/core/main.ml +++ /dev/null @@ -1,27 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Main - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -Test.run "core" [ - Test_lwt.suite; - Test_lwt_stream.suite; - Test_lwt_util.suite; -] diff --git a/server/thirdparty/lwt-2.3.2/tests/core/test_lwt.ml b/server/thirdparty/lwt-2.3.2/tests/core/test_lwt.ml deleted file mode 100644 index 711cdef..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/core/test_lwt.ml +++ /dev/null @@ -1,552 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Test_lwt - * Copyright (C) 2010 Jérémie Dimino, Pierre Chambart - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Test -open Lwt - -let ( <=> ) v v' = - assert ( state v = v') - -let test_exn f v e = - assert ( try f v;assert false with exn -> exn = e) - -let f x = return ("test"^x) -let g x = ("test"^x) - -exception Exn - -let key : int key = new_key () - -let suite = suite "lwt" [ - test "0" - (fun () -> - return "test" <=> Return "test"; - fail Exn <=> Fail Exn; - bind (return "test") f <=> Return "testtest"; - bind (fail Exn) return <=> Fail Exn; - (return "test") >>= f <=> Return "testtest"; - f =<< (return "test") <=> Return "testtest"; - map g (return "test") <=> Return "testtest"; - (return "test") >|= g <=> Return "testtest"; - g =|< (return "test") <=> Return "testtest"; - return true); - - test "1" - (fun () -> - catch return (fun e -> return ()) <=> Return (); - catch (fun () -> fail Exn) (function Exn -> return ()| e -> assert false) <=> Return (); - catch (fun () -> fail Exn) (fun e -> fail e) <=> Fail Exn; - return true); - - test "2" - (fun () -> - try_bind return return ( fun e -> assert false ) <=> Return (); - try_bind (fun () -> fail Exn) return (function Exn -> return ()| e -> assert false) <=> Return (); - return true); - - test "3" - (fun () -> - finalize return return <=> Return (); - finalize (fun () -> fail Exn) return <=> Fail Exn; - return true); - - test "4" - (fun () -> - apply (fun () -> raise Exn) () <=> Fail Exn; - return true); - - test "5" - (fun () -> - choose [return ()] <=> Return (); - return () return () <=> Return (); - return true); - - test "6" - (fun () -> - join [return ()] <=> Return (); - return () <&> return () <=> Return (); - return true); - - test "7" - (fun () -> - assert (ignore_result (return ()) = ()); - test_exn ignore_result (fail Exn) Exn; - return true); - - test "8" - (fun () -> - let t,w = wait () in - t <=> Sleep; - wakeup w (); - t <=> Return (); - return true); - - test "9" - (fun () -> - let t,w = wait () in - wakeup_exn w Exn; - t <=> Fail Exn; - return true); - - test "10" - (fun () -> - let t,w = task () in - t <=> Sleep; - wakeup w (); - t <=> Return (); - return true); - - test "11" - (fun () -> - let t,w = wait () in - let r1 = choose [t] in r1 <=> Sleep; - choose [t;return ()] <=> Return (); - join [fail Exn;t] <=> Sleep; - let r2 = join [t] in r2 <=> Sleep; - let r3 = join [t;return ()] in r3 <=> Sleep; - wakeup w (); - r1 <=> Return (); r2 <=> Return (); r3 <=> Return (); - return true); - - test "12" - (fun () -> - let t,w = wait () in - let t',w' = wait () in - let r1 = join [return ();t] in - let r2 = join [t;t'] in - wakeup_exn w Exn; - r1 <=> Fail Exn; - r2 <=> Sleep; - return true); - - test "13" - (fun () -> - let t,w = wait () in - let t',w' = wait () in - let r = bind (choose [t;t']) return in - r <=> Sleep; - wakeup w' (); - r <=> Return (); - let r' = bind (choose [t;t]) return in - wakeup w (); - r' <=> Return (); - return true); - - test "14" - (fun () -> - assert ( poll (return ()) = Some () ); - test_exn poll (fail Exn) Exn; - let t,w = wait () in - assert ( poll t = None ); - return true); - - test "15" - (fun () -> - let t,w = wait () in - assert ( ignore_result t = () ); - wakeup w (); - let t,w = wait () in - ignore_result t; - (* XXX c'est quand meme un comportement bizare *) - test_exn (wakeup_exn w) Exn Exn; - return true); - - test "16" - (fun () -> - let t,w = wait () in - let r1 = catch (fun () -> t) (fun e -> return ()) in r1 <=> Sleep; - let r2 = try_bind (fun () -> t) return ( fun e -> assert false ) in r2 <=> Sleep; - wakeup w (); - r1 <=> Return (); - r2 <=> Return (); - return true); - - (****) - - test "17" - (fun () -> - let t,w = task () in - let t',w' = wait () in - let t'' = return () in - cancel t; - cancel t'; - cancel t''; - t <=> Fail Canceled; - t' <=> Sleep; - t'' <=> Return () ; - return true); - - test "18" - (fun () -> - let t,w = task () in - let r = bind t return in - cancel r; - r <=> Fail Canceled; - return true); - - test "19" - (fun () -> - let t,w = task () in - on_cancel t (fun () -> ()); - on_cancel t (fun () -> raise Exn); - on_cancel (return ()) (fun () -> assert false); - cancel t; - on_cancel t (fun () -> ()); - let t,w = wait () in - on_cancel t (fun () -> ()); - wakeup w (); - return true); - - test "20" - (fun () -> - let t,w = task () in - let t',w' = wait () in - let r = pick [t;t'] in r <=> Sleep; - wakeup w' (); - r <=> Return (); - t <=> Fail Canceled; - return true); - - test "21" - (fun () -> - pick [return ()] <=> Return (); - return true); - - test "22" - (fun () -> - let t,w = task () in - let t',w' = wait () in - let r = pick [t;t'] in - cancel r; - r <=> Fail Canceled; - t <=> Fail Canceled; - return true); - - test "23" - (fun () -> - let t,w = task () in - let r = join [t] in - cancel r; - r <=> Fail Canceled; - t <=> Fail Canceled; - return true); - - test "24" - (fun () -> - let t,w = task () in - let r = choose [t] in - cancel r; - r <=> Fail Canceled; - t <=> Fail Canceled; - return true); - - test "25" - (fun () -> - let t,w = task () in - let r = catch (fun () -> t) (function Canceled -> return ()| _ -> assert false) in - cancel r; - r <=> Return (); - t <=> Fail Canceled; - return true); - - test "26" - (fun () -> - let t,w = task () in - let r = try_bind (fun () -> t) (fun _ -> assert false) (function Canceled -> return ()| _ -> assert false) in - cancel r; - r <=> Return (); - t <=> Fail Canceled; - return true); - - test "27" - (fun () -> - let t,w = wait () in - wakeup w (); - test_exn (wakeup w) () (Invalid_argument "Lwt.wakeup"); - return true); - - test "28" - (fun () -> - let t,w = task () in - cancel t; - wakeup w (); - return true); - - test "29" - (fun () -> - let t,w = wait () in - let t',w' = wait () in - let r = bind t ( fun () -> t' ) in - let r' = bind t ( fun () -> r ) in - wakeup w (); - r <=> Sleep; - r' <=> Sleep; - wakeup w' (); - r <=> Return (); - r' <=> Return (); - return true); - - test "30" - (fun () -> - let t,w = wait () in - let t',w' = wait () in - let t'',w'' = wait () in - let r = bind t ( fun () -> t' ) in - let r' = bind t'' ( fun () -> r ) in - wakeup w'' (); - r <=> Sleep; - r' <=> Sleep; - wakeup w (); - wakeup w' (); - r' <=> Return (); - r <=> Return (); - return true); - - test "31" - (fun () -> - let t,w = wait () in - let a = ref (return ()) in - let r = bind t ( fun () -> !a ) in - a := r; - wakeup w (); - return true); - - test "choose" - (fun () -> - let t1,w1 = wait () in - let t2,w2 = wait () in - let rec f = function - | 0 -> [] - | i -> (choose [t1;t2])::(f (i-1)) - in - let l = f 100 in - t1 <=> Sleep; - t2 <=> Sleep; - List.iter (fun t -> t <=> Sleep) l; - wakeup w1 (); - List.iter (fun t -> t <=> Return ()) l; - t1 <=> Return (); - t2 <=> Sleep; - return true); - - test "protected return" - (fun () -> - let t = return 1 in - let t' = protected t in - return ((state t' = Return 1) && (state t = Return 1))); - - test "protected fail" - (fun () -> - let t = fail Exn in - let t' = protected t in - return ((state t' = Fail Exn) && (state t = Fail Exn))); - - test "protected wait 1" - (fun () -> - let t,w = wait () in - let t' = protected t in - wakeup w 1; - return ((state t' = Return 1) && (state t = Return 1))); - - test "protected wait 2" - (fun () -> - let t,w = wait () in - let t' = protected t in - wakeup_exn w Exn; - return ((state t' = Fail Exn) && (state t = Fail Exn))); - - test "protected wait 3" - (fun () -> - let t,w = wait () in - let t' = protected t in - cancel t'; - return ((state t' = Fail Canceled) && (state t = Sleep))); - - test "protected wait 4" - (fun () -> - let t,w = wait () in - let t' = protected t in - cancel t'; - wakeup w 1; - return ((state t' = Fail Canceled) && (state t = Return 1))); - - test "protected wait 5" - (fun () -> - let t,w = wait () in - let t' = protected t in - cancel t'; - wakeup_exn w Exn; - return ((state t' = Fail Canceled) && (state t = Fail Exn))); - - test "protected wait 6" - (fun () -> - let t,w = wait () in - let t' = protected t in - wakeup_exn w Exn; - cancel t'; - return ((state t' = Fail Exn) && (state t = Fail Exn))); - - test "protected wait 7" - (fun () -> - let t,w = wait () in - let t' = protected t in - wakeup w 1; - cancel t'; - return ((state t' = Return 1) && (state t = Return 1))); - - test "join 1" - (fun () -> - let t1 = fail Exn in - let t2 = join [t1] in - return ((state t1 = Fail Exn) && (state t2 = Fail Exn))); - - test "join 2" - (fun () -> - let t1,w1 = wait () in - let t2 = join [t1] in - wakeup_exn w1 Exn; - return ((state t1 = Fail Exn) && (state t2 = Fail Exn))); - - test "join 3" - (fun () -> - let t1 = fail Exn in - let t2,w2 = wait () in - let t3 = fail Not_found in - let t4 = join [t2;t1;t3] in - return ((state t1 = Fail Exn) && (state t2 = Sleep) && - (state t3 = Fail Not_found) && (state t4 = Sleep))); - - test "join 4" - (fun () -> - let t1 = fail Exn in - let t2,w2 = wait () in - let t3 = return () in - let rec f = function - | 0 -> return true - | i -> - let t = join [t2;t3;t1] in - if ((state t1 = Fail Exn) && (state t2 = Sleep) - && (state t = Sleep) && (state t3 = Return ())) - then f (i-1) - else return false - in - f 100); - - test "cancel loop" - (fun () -> - let rec loop () = - lwt () = Lwt_unix.yield () in - loop () - in - let t = loop () in - cancel t; - return (state t = Fail Canceled)); - - test "cancel loop 2" - (fun () -> - let rec loop () = - lwt () = Lwt_unix.yield () in - loop () - in - let t = loop () in - lwt () = Lwt_unix.yield () in - cancel t; - return (state t = Fail Canceled)); - - test "nchoose" - (fun () -> - lwt l = nchoose [return 1; return 2] in - return (l = [1; 2])); - - test "npick" - (fun () -> - lwt l = npick [return 1; return 2] in - return (l = [1; 2])); - - test "bind/cancel 1" - (fun () -> - let waiter, wakener = wait () in - let t = - lwt () = waiter in - let waiter, wakener = task () in - waiter - in - wakeup wakener (); - cancel t; - return (state t = Fail Canceled)); - - test "bind/cancel 2" - (fun () -> - let waiter, wakener = wait () in - let t = - lwt () = waiter in - let waiter, wakener = task () in - waiter - in - let t = t >>= return in - wakeup wakener (); - cancel t; - return (state t = Fail Canceled)); - - test "bind/cancel 3" - (fun () -> - let waiter1, wakener1 = wait () in - let waiter2, wakener2 = wait () in - let t = - lwt () = waiter1 in - try_lwt - lwt () = waiter2 in - fst (task ()) - with Canceled -> - return true - in - wakeup wakener1 (); - wakeup wakener2 (); - cancel t; - return (state t = Return true)); - - test "data 1" - (fun () -> - with_value key (Some 1) - (fun () -> return (get key = Some 1))); - - test "data 2" - (fun () -> - with_value key (Some 1) - (fun () -> - with_value key (Some 2) - (fun () -> return (get key = Some 2)))); - - test "data 3" - (fun () -> - with_value key (Some 1) - (fun () -> - let waiter, wakener = wait () in - let t = - with_value key (Some 2) - (fun () -> - lwt () = waiter in - return (get key = Some 2)) - in - wakeup wakener (); - t)); -] diff --git a/server/thirdparty/lwt-2.3.2/tests/core/test_lwt_stream.ml b/server/thirdparty/lwt-2.3.2/tests/core/test_lwt_stream.ml deleted file mode 100644 index 76b15da..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/core/test_lwt_stream.ml +++ /dev/null @@ -1,221 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Test_lwt_stream - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt -open Test - -let suite = suite "lwt_stream" [ - test "from" - (fun () -> - let mvar = Lwt_mvar.create_empty () in - let stream = Lwt_stream.from (fun () -> - lwt x = Lwt_mvar.take mvar in - return (Some x)) in - let t1 = Lwt_stream.next stream in - let t2 = Lwt_stream.next stream in - let t3 = Lwt_stream.next stream in - lwt () = Lwt_mvar.put mvar 1 in - lwt () = Lwt_mvar.put mvar 2 in - lwt () = Lwt_mvar.put mvar 3 in - lwt x1 = t1 and x2 = t2 and x3 = t3 in - return ([x1; x2; x3] = [1; 2; 3])); - - test "clone" - (fun () -> - let stream1 = Lwt_stream.of_list [1; 2; 3] in - let stream2 = Lwt_stream.clone stream1 in - lwt x1_1 = Lwt_stream.next stream1 in - lwt x2_1 = Lwt_stream.next stream2 in - lwt x1_2 = Lwt_stream.next stream1 - and x1_3 = Lwt_stream.next stream1 - and x2_2 = Lwt_stream.next stream2 - and x2_3 = Lwt_stream.next stream2 in - return ([x1_1; x1_2; x1_3] = [1; 2; 3] && [x2_1; x2_2; x2_3] = [1; 2; 3])); - - test "clone 2" - (fun () -> - let stream1, push = Lwt_stream.create () in - push (Some 1); - let stream2 = Lwt_stream.clone stream1 in - let x1_1 = poll (Lwt_stream.next stream1) in - let x1_2 = poll (Lwt_stream.next stream1) in - let x2_1 = poll (Lwt_stream.next stream2) in - let x2_2 = poll (Lwt_stream.next stream2) in - return ([x1_1;x1_2;x2_1;x2_2] = [Some 1;None;Some 1;None])); - - test "create" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - push None; - lwt l = Lwt_stream.to_list stream in - return (l = [1; 2; 3])); - - test "create 2" - (fun () -> - let stream, push = Lwt_stream.create () in - push None; - let t = Lwt_stream.next stream in - return (Lwt.state t = Fail Lwt_stream.Empty)); - - test "get_while" - (fun () -> - let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in - lwt l1 = Lwt_stream.get_while (fun x -> x < 3) stream in - lwt l2 = Lwt_stream.to_list stream in - return (l1 = [1; 2] && l2 = [3; 4; 5])); - - test "peek" - (fun () -> - let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in - lwt x = Lwt_stream.peek stream in - lwt y = Lwt_stream.peek stream in - lwt l = Lwt_stream.to_list stream in - return (x = Some 1 && y = Some 1 && l = [1; 2; 3; 4; 5])); - - test "npeek" - (fun () -> - let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in - lwt x = Lwt_stream.npeek 3 stream in - lwt y = Lwt_stream.npeek 1 stream in - lwt l = Lwt_stream.to_list stream in - return (x = [1; 2; 3] && y = [1] && l = [1; 2; 3; 4; 5])); - - test "get_available" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - let l = Lwt_stream.get_available stream in - push (Some 4); - lwt x = Lwt_stream.get stream in - return (l = [1; 2; 3] && x = Some 4)); - - test "get_available_up_to" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - push (Some 4); - let l = Lwt_stream.get_available_up_to 2 stream in - lwt x = Lwt_stream.get stream in - return (l = [1; 2] && x = Some 3)); - - test "filter" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - push (Some 4); - let filtered = Lwt_stream.filter ((=) 3) stream in - lwt x = Lwt_stream.get filtered in - let l = Lwt_stream.get_available filtered in - return (x = Some 3 && l = [])); - - test "filter_map" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - push (Some 4); - let filtered = Lwt_stream.filter_map (function 3 -> Some "3" | _ -> None ) stream in - lwt x = Lwt_stream.get filtered in - let l = Lwt_stream.get_available filtered in - return (x = Some "3" && l = [])); - - test "last_new" - (fun () -> - let stream, push = Lwt_stream.create () in - push (Some 1); - push (Some 2); - push (Some 3); - lwt x = Lwt_stream.last_new stream in - return (x = 3)); - - test "cancel push stream 1" - (fun () -> - let stream, push = Lwt_stream.create () in - let t = Lwt_stream.next stream in - cancel t; - return (state t = Fail Canceled)); - - test "cancel push stream 2" - (fun () -> - let stream, push = Lwt_stream.create () in - let t = Lwt_stream.next stream in - cancel t; - push (Some 1); - let t' = Lwt_stream.next stream in - return (state t' = Return 1)); - - (* check if the push function keeps references to the elements in - the stream *) - test "push and GC" - (fun () -> - let w = Weak.create 5 in - (* Count the number of reachable elements in the stream. *) - let count () = - let rec loop acc idx = - if idx = Weak.length w then - acc - else - match Weak.get w idx with - | None -> loop acc (idx + 1) - | Some v -> loop (acc + 1) (idx + 1) - in - loop 0 0 - in - (* Run some test and return the push function of the stream. *) - let test () = - let stream, push = Lwt_stream.create () in - assert (count () = 0); - let r1 = Some(ref 1) in - push r1; - Weak.set w 1 r1; - let r2 = Some(ref 2) in - push r2; - Weak.set w 2 r2; - let r3 = Some(ref 3) in - push r3; - Weak.set w 3 r3; - assert (count () = 3); - assert (state (Lwt_stream.next stream) = Return {contents = 1}); - Gc.full_major (); - (* Ocaml can consider that stream is unreachable before the - next line, hence freeing the whole data. *) - assert (count () <= 3); - push - in - let push = test () in - Gc.full_major (); - (* At this point [stream] is unreachable. *) - assert (count () = 0); - (* We have that to force caml to keep a reference on [push]. *) - push (Some(ref 4)); - return true); -] diff --git a/server/thirdparty/lwt-2.3.2/tests/core/test_lwt_util.ml b/server/thirdparty/lwt-2.3.2/tests/core/test_lwt_util.ml deleted file mode 100644 index 3e216af..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/core/test_lwt_util.ml +++ /dev/null @@ -1,226 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Test_lwt_util - * Copyright (C) 2009 Jérémie Dimino, Pierre Chambart - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - - -open Test -open Lwt -open Lwt_util - -let ( <=> ) v v' = - assert ( state v = v') - -let test_exn f v e = - assert ( try f v;assert false with exn -> exn = e) - -exception Exn - -let test_iter f test_list = - let incr_ x = return ( incr x ) in - let () = - let l = [ref 0;ref 0; ref 0] in - let t = f incr_ l in - t <=> Return (); - List.iter2 (fun v r -> assert (v = !r)) [1;1;1] l - in - let () = - let l = [ref 0;ref 0; ref 0] in - let t,w = wait () in - let r = ref [incr_;(fun x -> t >>= ( fun () -> incr_ x ));incr_] in - let t' = f (fun x -> - let f = List.hd !r in - let t = f x in - r := List.tl !r; - t ) l - in - t' <=> Sleep; - List.iter2 (fun v r -> assert (v = !r)) test_list l; - wakeup w (); - List.iter2 (fun v r -> assert (v = !r)) [1;1;1] l; - t' <=> Return () - in - () - -let test_exception f = - let g = - let r = ref 0 in - fun _ -> - incr r; - match !r with - | 2 -> raise Exn - | _ -> return () - in - (* XXX est-ce le comportement souhaite ? - On pourrait plutot vouloir que iter et map - passent leur fonctions en parametre dans Lwt.apply. - - Une autre maniere serait d'avoir 2 bind, un tail recursif un non. - *) - test_exn (f g) [();();()] Exn - -let test_map f test_list = - let t,w = wait () in - let t',w' = task () in - let get = - let r = ref 0 in - let c = ref 0 in - fun () -> - let th = - incr c; - match !c with - | 5 -> t - | 8 -> t' - | _ -> return () - in - th >>= ( fun () -> - incr r; - return (!r) ) - in - let () = - let l = [();();()] in - let t1 = f get l in - t1 <=> Return [1;2;3]; - let t2 = f get l in - t2 <=> Sleep; - let t3 = f get l in - t3 <=> Sleep; - cancel t'; - t3 <=> Fail Canceled; - wakeup w (); - t2 <=> Return test_list; - in - () - -let suite = suite "lwt_util" [ - test "0" - (fun () -> - test_iter iter [1;0;1]; - test_exception iter; - return true); - - test "1" - (fun () -> - test_iter iter_serial [1;0;0]; - test_exception iter; - return true); - - test "2" - (fun () -> - test_map map [4;8;5]; - test_exception map; - return true); - - test "3" - (fun () -> - test_map map_serial [4;7;8]; - test_exception map_serial; - return true); - - test "4" - (fun () -> - let l = [1;2;3] in - let f acc v = return (v::acc) in - let t = fold_left f [] l in - t <=> Return (List.rev l); - return true); - - (* XXX l'espace semble mal compte dans les regions: on peut lancer - un thread tant que l'espace n'est pas nul, ca ne prends pas en - compte la taille du thread. ca devrait bloquer si il n'y a pas - assez de place. De plus resize region devrait permetre de - reveiller des threads. - - Une maniere de corriger est de ne pas permetre aux threads de - faire une taille superieur a 1. *) - - test "5" - (fun () -> - let t1,w1 = wait () in - let t2,w2 = wait () in - let t3,w3 = task () in - let region = make_region 3 in - run_in_region region 1 return <=> Return (); - (* XXX ne devrait pas pouvoir se lancer *) - run_in_region region 4 return <=> Return (); - let a = run_in_region region 3 (fun () -> t1) in - a <=> Sleep; - let b = run_in_region region 1 return in - b <=> Sleep; - let c = run_in_region region 3 (fun () -> t2) in - c <=> Sleep; - let d = run_in_region region 1 return in - d <=> Sleep; - let e = run_in_region region 3 (fun () -> t3) in - e <=> Sleep; - let f = run_in_region region 1 return in - f <=> Sleep; - wakeup w1 (); - a <=> Return (); - b <=> Return (); - c <=> Sleep; - d <=> Sleep; - e <=> Sleep; - f <=> Sleep; - cancel t3; - e <=> Sleep; - f <=> Sleep; - wakeup w2 (); - c <=> Return (); - d <=> Return (); - e <=> Fail Canceled; - f <=> Return (); - return true); - - test "6" - (fun () -> - let f () = raise Exn in - let region = make_region 1 in - run_in_region region 1 f <=> Fail Exn; - run_in_region region 1 return <=> Return (); - return true); -] - -(* XXX le comportement souhaite devrait etre: - ( avec resize qui renvoie un lwt qui se reveille - quand il y a suffisement de resources libres ) -*) -(* -let () = - let region = make_region 1 in - run_in_region region 1 return <=> Return (); - let t = run_in_region region 2 return in - t <=> Sleep; - resize_region region 2 <=> Return (); - t <=> Return (); - let t,w = wait () in - let t = run_in_region region 2 (fun () -> t) in - t <=> Sleep; - let t2 = run_in_region region 2 return in - let t3 = resize_region region 1 in - t2 <=> Sleep; - t3 <=> Sleep; - wakeup w (); - t <=> Return (); - t3 <=> Return (); - t2 <=> Sleep -*) - -(* XXX ca ne gere pas les cancel non plus *) diff --git a/server/thirdparty/lwt-2.3.2/tests/react/main.ml b/server/thirdparty/lwt-2.3.2/tests/react/main.ml deleted file mode 100644 index 8384a18..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/react/main.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Main - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -Test.run "react" [ - Test_lwt_event.suite; - Test_lwt_signal.suite; -] diff --git a/server/thirdparty/lwt-2.3.2/tests/react/test_lwt_event.ml b/server/thirdparty/lwt-2.3.2/tests/react/test_lwt_event.ml deleted file mode 100644 index 7567a5b..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/react/test_lwt_event.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Test_lwt_event - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Test -open Lwt - -let suite = suite "lwt_event" [ - test "to_stream" - (fun () -> - let event, push = React.E.create () in - let stream = Lwt_event.to_stream event in - let t = Lwt_stream.next stream in - assert (state t = Sleep); - push 42; - return (state t = Return 42)); - - test "to_stream 2" - (fun () -> - let event, push = React.E.create () in - let stream = Lwt_event.to_stream event in - push 1; - push 2; - push 3; - lwt l = Lwt_stream.nget 3 stream in - return (l = [1; 2; 3])); - - test "map_s" - (fun () -> - let l = ref [] in - let event, push = React.E.create () in - let event' = Lwt_event.map_s (fun x -> l := x :: !l; return ()) event in - ignore event'; - push 1; - return (!l = [1])); - - test "map_p" - (fun () -> - let l = ref [] in - let event, push = React.E.create () in - let event' = Lwt_event.map_p (fun x -> l := x :: !l; return ()) event in - ignore event'; - push 1; - return (!l = [1])); - - test "of_stream" - (fun () -> - let stream, push = Lwt_stream.create () in - let l = ref [] in - let event = React.E.map (fun x -> l := x :: !l) (Lwt_event.of_stream stream) in - ignore event; - push (Some 1); - push (Some 2); - push (Some 3); - Lwt.wakeup_paused (); - return (!l = [3; 2; 1])); -] diff --git a/server/thirdparty/lwt-2.3.2/tests/react/test_lwt_signal.ml b/server/thirdparty/lwt-2.3.2/tests/react/test_lwt_signal.ml deleted file mode 100644 index 75e2151..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/react/test_lwt_signal.ml +++ /dev/null @@ -1,27 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Test_lwt_signal - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Test -open Lwt - -let suite = suite "lwt_signal" [ -] diff --git a/server/thirdparty/lwt-2.3.2/tests/test.ml b/server/thirdparty/lwt-2.3.2/tests/test.ml deleted file mode 100644 index d52e1df..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/test.ml +++ /dev/null @@ -1,78 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Test - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt -open Lwt_io - -type t = { - name : string; - run : unit -> bool Lwt.t; -} - -type suite = { - suite_name : string; - suite_tests : t list; -} - -let test ~name ~run = { name = name; run = run } -let suite ~name ~tests = { suite_name = name; suite_tests = tests } - -let run ~name ~suites = - let n = Lwt_main.run begin - (* Count the number of tests in [suites] *) - let total = List.fold_left (fun n { suite_tests = l } -> n + List.length l) 0 suites in - - lwt () = printlf "Running %d tests for library %S." total name in - - (* Iterate over suites: *) - let rec loop_suites failures number = function - | [] -> - if failures = 0 then - lwt () = printl "\r\027[JDone. All tests succeeded." in - return 0 - else - lwt () = printlf "\r\027[JDone. %d of %d tests failed." failures total in - return 1 - | suite :: suites -> - loop_tests failures suite.suite_name number suites suite.suite_tests - - (* Iterate over tests: *) - and loop_tests failures suite_name number suites = function - | [] -> - loop_suites failures number suites - | test :: tests -> - lwt () = printf "\r\027[J(%d/%d) Running test %S from suite %S" number total test.name suite_name in - lwt () = flush stdout in - try_lwt - test.run () >>= function - | false -> - lwt () = printlf "\r\027[J\027[31;1mTest %S from suite %S failed.\027[0m" test.name suite_name in - loop_tests (failures + 1) suite_name (number + 1) suites tests - | true -> - loop_tests failures suite_name (number + 1) suites tests - with exn -> - lwt () = printlf "\r\027[J\027[31;1mTest %S from suite %S failed. It raised: %S.\027[0m" test.name suite_name (Printexc.to_string exn) in - loop_tests (failures + 1) suite_name (number + 1) suites tests - in - loop_suites 0 1 suites - end in - exit n diff --git a/server/thirdparty/lwt-2.3.2/tests/test.mli b/server/thirdparty/lwt-2.3.2/tests/test.mli deleted file mode 100644 index 83b8ee5..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/test.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Interface Test - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -(** Helpers for test *) - -type t - (** Type of a test *) - -type suite - (** Type of a suite of tests *) - -val test : name : string -> run : (unit -> bool Lwt.t) -> t - (** Defines a test. [run] must returns [true] if the test succeeded - and [false] otherwise. *) - -val suite : name : string -> tests : t list -> suite - (** Defines a suite of tests *) - -val run : name : string -> suites : suite list -> unit - (** Run all the given tests and exit the program with an exit code - of [0] if all tests succeeded and with [1] otherwise. *) diff --git a/server/thirdparty/lwt-2.3.2/tests/test.mllib b/server/thirdparty/lwt-2.3.2/tests/test.mllib deleted file mode 100644 index 147c9c2..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/test.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 0cbc6611f5540bd0809a388dc95a615b) -Test -# OASIS_STOP diff --git a/server/thirdparty/lwt-2.3.2/tests/unix/main.ml b/server/thirdparty/lwt-2.3.2/tests/unix/main.ml deleted file mode 100644 index d7a0435..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/unix/main.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Main - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -Test.run "unix" [ - Test_lwt_io.suite; - Test_lwt_io_non_block.suite; -] diff --git a/server/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io.ml b/server/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io.ml deleted file mode 100644 index 32f4c2e..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Test_lwt_io - * Copyright (C) 2009 Jérémie Dimino - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt -open Lwt_io -open Test - -let suite = suite "lwt_io" [ - test "auto-flush" - (fun () -> - let sent = ref [] in - let oc = Lwt_io.make ~mode:output (fun buf ofs len -> - let str = String.create len in - Lwt_bytes.blit_bytes_string buf ofs str 0 len; - sent := str :: !sent; - return len) in - lwt () = write oc "foo" in - lwt () = write oc "bar" in - if !sent <> [] then - return false - else - lwt () = Lwt_unix.yield () in - return (!sent = ["foobar"])); - - test "auto-flush in atomic" - (fun () -> - let sent = ref [] in - let oc = make ~mode:output (fun buf ofs len -> - let str = String.create len in - Lwt_bytes.blit_bytes_string buf ofs str 0 len; - sent := str :: !sent; - return len) in - atomic - (fun oc -> - lwt () = write oc "foo" in - lwt () = write oc "bar" in - if !sent <> [] then - return false - else - lwt () = Lwt_unix.yield () in - return (!sent = ["foobar"])) - oc); -] diff --git a/server/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io_non_block.ml b/server/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io_non_block.ml deleted file mode 100644 index 9182f61..0000000 --- a/server/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io_non_block.ml +++ /dev/null @@ -1,66 +0,0 @@ -(* Lightweight thread library for Objective Caml - * http://www.ocsigen.org/lwt - * Module Test_lwt_io - * Copyright (C) 2010 Pierre Chambart - * - * This program 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, with linking exceptions; - * either version 2.1 of the License, or (at your option) any later - * version. See COPYING file for details. - * - * 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - * 02111-1307, USA. - *) - -open Lwt -open Lwt_io -open Test - -let test_file = "Lwt_io_test" -let file_contents = "test file content" - -let open_and_read_filename () = - lwt in_chan = open_file ~mode:input test_file in - lwt s = read in_chan in - lwt () = close in_chan in - assert (s = file_contents); - return () - -let suite = suite "lwt_io non blocking io" [ - test "create file" - (fun () -> - lwt out_chan = open_file ~mode:output test_file in - lwt () = write out_chan file_contents in - lwt () = close out_chan in - return true); - - test "read file" - (fun () -> - lwt in_chan = open_file ~mode:input test_file in - lwt s = read in_chan in - lwt () = close in_chan in - return (s = file_contents)); - - test "many read file" - (fun () -> - lwt () = for_lwt i = 0 to 10000 do - try_lwt - open_and_read_filename () - with e -> lwt () = printf "\nstep %i\n" i in raise_lwt e - done in - return true); - - test "remove file" - (fun () -> - Unix.unlink test_file; - return true); - -] diff --git a/server/thirdparty/lwt-2.3.2/utils/ocamlinit b/server/thirdparty/lwt-2.3.2/utils/ocamlinit deleted file mode 100644 index 668e93f..0000000 --- a/server/thirdparty/lwt-2.3.2/utils/ocamlinit +++ /dev/null @@ -1,38 +0,0 @@ -(* -*- tuareg -*- *) - -(* This file is a sample ocaml init file for friendly interactive use - of Lwt. - - You can copy it to ~/.ocamlinit. -*) - -(* Use topfind, this is the minimum: *) -#use "topfind";; -(* Note: if you use lwt/toplevel.byte, you should remove this line *) - -(* Syntax to use, you can replace that with #camlp4r if you prefer - revised syntax: *) -#camlp4o;; - -(* Load Lwt syntactic sugars: *) -#require "lwt.syntax";; - -(* Load the lwt.top package, with line-editing support :) *) -#require "lwt.top";; - -(* Open useful Lwt modules for scripting: *) -open Lwt_unix;; -open Lwt;; -open Lwt_io;; -open Lwt_process;; - -(* Useful definitions for interactive use of Lwt, so you can write: - - $ run& printl "plop";; - - or: - - $ let l = run& read_line stdin;; -*) -let ( & ) a b = a b;; -let run = Lwt_main.run;; diff --git a/server/thirdparty/lwt-2.3.2/utils/style.css b/server/thirdparty/lwt-2.3.2/utils/style.css deleted file mode 100644 index fb02716..0000000 --- a/server/thirdparty/lwt-2.3.2/utils/style.css +++ /dev/null @@ -1,171 +0,0 @@ -/* A style for ocamldoc. Daniel C. Buenzli, Jérémie Dimino */ - -body { - padding: 0em; - border: 0em; - margin: 2em 10% 2em 10%; - font-weight: normal; - line-height: 130%; - text-align: justify; - background: white; - color : black; - min-width: 40ex; -} - -pre, p, div, span, img, table, td, ol, ul, li { - padding: 0em; - border: 0em; - margin: 0em -} - -h1, h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { - fontsize: 100%; - margin-bottom: 1em - padding: 1ex 0em 0em 0em; - border: 0em; - margin: 1em 0em 0em 0em; - font-weight : bold; - text-align: center; -} - -h1 { - font-size : 140% -} - -h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { - font-size : 100%; - border-top-style : none; - margin: 1ex 0em 0em 0em; - border: 1px solid #000000; - margin-top: 5px; - margin-bottom: 2px; - text-align: center; - padding: 2px; -} - -h2 { - font-size : 120%; - background-color: #90BDFF ; -} -h3 { - background-color: #90DDFF; -} -h4 { - background-color: #90EDFF; -} -h5 { - background-color: #90FDFF; -} -h6 { - background-color: #C0FFFF; -} -div.h7 { - background-color: #E0FFFF; -} -div.h8 { - background-color: #F0FFFF; -} -div.h9 { - background-color: #FFFFFF; -} - -.navbar { - padding-bottom : 1em; - margin-bottom: 1em; - border-bottom: 1px solid #000000; - border-bottom-style: dotted; -} - -p { - padding: 1em 0ex 0em 0em -} - -a, a:link, a:visited, a:active, a:hover { - color : #009; - text-decoration: none -} -a:hover { - color : #009; - text-decoration : none; - background-color: #5FFF88 -} - -hr { - border-style: none; -} -table { - font-size : 100% /* Why ? */ -} -ul li { - padding: 1em 0em 0em 0em; - margin:0em 0em 0em 2.5ex -} -ol li { - padding: 1em 0em 0em 0em; - margin:0em 0em 0em 2em -} - -pre { - margin: 3ex 0em 1ex 0em; - background-color: #edf0f9; -} -.keyword { - font-weight: bold; - color: #a020f0; -} -.keywordsign { - font-weight: bold; - color: #a020f0; -} -.typefieldcomment { - color : #b22222; -} -.keywordsign { - color: #a020f0; - -} -.code { - font-size: 120%; - color: #5f5f5f; -} -.info { - margin: 0em 0em 0em 2em -} -.comment { - color : #b22222; -} -.constructor { - color : #072 -} -.type { - color : #228b22; -} -.string { - color : #bc8f8f; -} -.warning { - color : Red; - font-weight : bold -} - -div.sig_block { - margin-left: 2em -} -.typetable { - color : #b8860b; - border-style : hidden -} -.indextable { - border-style : hidden -} -.paramstable { - border-style : hidden; - padding: 5pt 5pt -} - -.superscript { - font-size : 80% -} -.subscript { - font-size : 80% -} diff --git a/server/thirdparty/lwt-2.3.2/utils/tuareg.patch b/server/thirdparty/lwt-2.3.2/utils/tuareg.patch deleted file mode 100644 index a611392..0000000 --- a/server/thirdparty/lwt-2.3.2/utils/tuareg.patch +++ /dev/null @@ -1,377 +0,0 @@ -diff --git a/tuareg.el b/tuareg.el -index 7529577..e5b3b71 100644 ---- a/tuareg.el -+++ b/tuareg.el -@@ -693,7 +693,7 @@ and `tuareg-xemacs-w3-manual' (XEmacs only)." - "Return relative indentation of the keyword given in argument." - (let ((ind (symbol-value (cdr (assoc kwop tuareg-keyword-alist)))) - (looking-let-or-and (and look-for-let-or-and -- (looking-at "\\<\\(let\\|and\\)\\>")))) -+ (looking-at "\\<\\(let\\|lwt\\|and\\)\\>")))) - (if (string-match "\\<\\(with\\|function\\|parser?\\)\\>" kwop) - (+ (if (and tuareg-let-always-indent - looking-let-or-and (< ind tuareg-let-indent)) -@@ -1015,7 +1015,8 @@ Regexp match data 0 points to the chars." - '("module" "class" "functor" "object" "type" "val" "inherit" - "include" "virtual" "constraint" "exception" "external" "open" - "method" "and" "initializer" "to" "downto" "do" "done" "else" -- "begin" "end" "let" "in" "then" "with")) -+ "begin" "end" "let" "in" "then" "with" -+ "lwt" "try_lwt" "for_lwt" "finally")) - (setq abbrevs-changed nil)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -@@ -1143,7 +1144,7 @@ Special keys for Tuareg mode:\\{tuareg-mode-map}" - tuareg-font-lock-keywords - (append - (list -- (list "\\<\\(external\\|open\\|include\\|rule\\|s\\(ig\\|truct\\)\\|module\\|functor\\|with[ \t\n]+\\(type\\|module\\)\\|val\\|type\\|method\\|virtual\\|constraint\\|class\\|in\\|inherit\\|initializer\\|let\\|rec\\|and\\|begin\\|object\\|end\\)\\>" -+ (list "\\<\\(external\\|open\\|include\\|rule\\|s\\(ig\\|truct\\)\\|module\\|functor\\|with[ \t\n]+\\(type\\|module\\)\\|val\\|type\\|method\\|virtual\\|constraint\\|class\\|in\\|inherit\\|initializer\\|let\\|lwt\\|rec\\|and\\|begin\\|object\\|end\\)\\>" - 0 'tuareg-font-lock-governing-face nil nil)) - (if tuareg-support-metaocaml - (list (list "\\.<\\|>\\.\\|\\.~\\|\\.!" -@@ -1152,19 +1153,19 @@ Special keys for Tuareg mode:\\{tuareg-mode-map}" - (list - (list "\\<\\(false\\|true\\)\\>" - 0 'font-lock-constant-face nil nil) -- (list "\\<\\(as\\|do\\(ne\\|wnto\\)?\\|else\\|for\\|if\\|m\\(atch\\|utable\\)\\|new\\|p\\(arser\\|rivate\\)\\|t\\(hen\\|o\\|ry\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|lazy\\|exception\\|raise\\|failwith\\|exit\\|assert\\|fun\\(ction\\)?\\)\\>" -+ (list "\\<\\(raise_lwt\\|as\\|do\\(ne\\|wnto\\)?\\|else\\|for\\(_lwt\\)?\\|if\\|m\\(atch\\|utable\\)\\|new\\|p\\(arser\\|rivate\\)\\|t\\(hen\\|o\\|ry\\(_lwt\\)?\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|lazy\\|exception\\|raise\\|failwith\\|exit\\|assert\\|fun\\(ction\\)?\\|finally\\)\\>" - 0 'font-lock-keyword-face nil nil) - (list "[][;,()|{}]\\|[@^!:*=<>&/%+~?#---]\\.?\\|\\.\\.\\.*\\|\\<\\(asr\\|asl\\|lsr\\|lsl\\|l?or\\|l?and\\|xor\\|not\\|mod\\|of\\|ref\\)\\>" - 0 'tuareg-font-lock-operator-face nil nil) -- (list (concat "\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(['_" tuareg-lower "]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)") -+ (list (concat "\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\|lwt\\)\\>[ \t\n]*\\(['_" tuareg-lower "]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)") - 8 'font-lock-function-name-face 'keep nil) - (list "\\[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" - 3 'font-lock-function-name-face 'keep nil) - (list "\\<\\(fun\\(ction\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_ \t()*,]\\)+\\)" - 3 'font-lock-variable-name-face 'keep nil) -- (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" -+ (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\|lwt\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" - 4 'font-lock-variable-name-face 'keep nil) -- (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" -+ (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\|lwt\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" - 6 'font-lock-variable-name-face 'keep nil) - (list "\\<\\(open\\|\\(class\\([ \t\n]+type\\)?\\)\\([ \t\n]+virtual\\)?\\|inherit\\|include\\|module\\([ \t\n]+\\(type\\|rec\\)\\)?\\|type\\)\\>[ \t\n]*\\(['~?]*\\([_--->.* \t]\\|\\w\\|(['~?]*\\([_--->.,* \t]\\|\\w\\)*)\\)*\\)" - 7 'font-lock-type-face 'keep nil) -@@ -1279,7 +1280,7 @@ possible." - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Indentation stuff - --(defconst tuareg-keyword-regexp "\\<\\(object\\|initializer\\|and\\|c\\(onstraint\\|lass\\)\\|m\\(atch\\|odule\\|ethod\\|utable\\)\\|s\\(ig\\|truct\\)\\|begin\\|e\\(lse\\|x\\(ception\\|ternal\\)\\)\\|t\\(o\\|hen\\|ry\\|ype\\)\\|v\\(irtual\\|al\\)\\|w\\(h\\(ile\\|en\\)\\|ith\\)\\|i\\(f\\|n\\(herit\\)?\\)\\|f\\(or\\|un\\(ct\\(or\\|ion\\)\\)?\\)\\|let\\|do\\(wnto\\)?\\|parser?\\|rule\\|of\\)\\>\\|->\\|[;,|]" -+(defconst tuareg-keyword-regexp "\\<\\(object\\|initializer\\|and\\|c\\(onstraint\\|lass\\)\\|m\\(atch\\|odule\\|ethod\\|utable\\)\\|s\\(ig\\|truct\\)\\|begin\\|e\\(lse\\|x\\(ception\\|ternal\\)\\)\\|t\\(o\\|hen\\|ry\\(_lwt\\)?\\|ype\\)\\|v\\(irtual\\|al\\)\\|w\\(h\\(ile\\|en\\)\\|ith\\)\\|i\\(f\\|n\\(herit\\)?\\)\\|f\\(inally\\|or\\(_lwt\\)?\\|un\\(ct\\(or\\|ion\\)\\)?\\)\\|l\\(e\\|w\\)t\\|do\\(wnto\\)?\\|parser?\\|rule\\|of\\)\\>\\|->\\|[;,|]" - "Regexp for all recognized keywords.") - - (defconst tuareg-match-|-keyword-regexp -@@ -1298,11 +1299,11 @@ considered as a special keyword.") - "Regexp matching Caml keywords which act as end block delimiters.") - - (defconst tuareg-leading-kwop-regexp -- (concat tuareg-matching-keyword-regexp "\\|\\\\|[|>]?\\]\\|>?}\\|[|)]\\|;;") -+ (concat tuareg-matching-keyword-regexp "\\|\\<\\(with\\|finally\\)\\>\\|[|>]?\\]\\|>?}\\|[|)]\\|;;") - "Regexp matching Caml keywords which need special indentation.") - - (defconst tuareg-governing-phrase-regexp -- "\\<\\(val\\|type\\|m\\(ethod\\|odule\\)\\|c\\(onstraint\\|lass\\)\\|in\\(herit\\|itializer\\)\\|ex\\(ternal\\|ception\\)\\|open\\|let\\|object\\|include\\)\\>" -+ "\\<\\(val\\|type\\|m\\(ethod\\|odule\\)\\|c\\(onstraint\\|lass\\)\\|in\\(herit\\|itializer\\)\\|ex\\(ternal\\|ception\\)\\|open\\|l\\(e\\|w\\)t\\|object\\|include\\)\\>" - "Regexp matching tuareg phrase delimitors.") - - (defconst tuareg-governing-phrase-regexp-with-break -@@ -1318,6 +1319,7 @@ considered as a special keyword.") - ("begin" . tuareg-begin-indent) - (".<" . tuareg-begin-indent) - ("for" . tuareg-for-while-indent) -+ ("for_lwt" . tuareg-for-while-indent) - ("while" . tuareg-for-while-indent) - ("do" . tuareg-do-indent) - ("type" . tuareg-type-indent) ; in some cases, `type' acts like a match -@@ -1327,8 +1329,10 @@ considered as a special keyword.") - ("then" . tuareg-if-then-else-indent) - ("else" . tuareg-if-then-else-indent) - ("let" . tuareg-let-indent) -+ ("lwt" . tuareg-let-indent) - ("match" . tuareg-match-indent) - ("try" . tuareg-try-indent) -+ ("try_lwt" . tuareg-try-indent) - ("rule" . tuareg-rule-indent) - - ;; Case match keywords -@@ -1338,6 +1342,7 @@ considered as a special keyword.") - ("parser" . tuareg-parser-indent) - - ;; Default indentation keywords -+ ("finally" . tuareg-default-indent) - ("when" . tuareg-default-indent) - ("functor" . tuareg-default-indent) - ("exception" . tuareg-default-indent) -@@ -1372,6 +1377,7 @@ considered as a special keyword.") - ("done" . tuareg-find-done-match) - ("in" . tuareg-find-in-match) - ("with" . tuareg-find-with-match) -+ ("finally" . tuareg-find-finally-match) - ("else" . tuareg-find-else-match) - ("then" . tuareg-find-match) - ("do" . tuareg-find-do-match) -@@ -1400,7 +1406,7 @@ Returns the actual text of the word, if found." - - (defconst tuareg-find-kwop-regexp - (concat tuareg-matching-keyword-regexp -- "\\|\\<\\(for\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|object\\)\\>\\|[][(){}]\\|\\*)")) -+ "\\|\\<\\(for\\(_lwt\\)?\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|object\\)\\>\\|[][(){}]\\|\\*)")) - - (defun tuareg-make-find-kwop-regexp (kwop-regexp) - (concat tuareg-find-kwop-regexp "\\|" kwop-regexp)) -@@ -1440,45 +1446,55 @@ If found, return the actual text of the keyword or operator." - - (defconst tuareg-find-,-match-regexp - (tuareg-make-find-kwop-regexp -- "\\<\\(and\\|match\\|begin\\|else\\|exception\\|then\\|try\\|with\\|or\\|fun\\|function\\|let\\|do\\)\\>\\|->\\|[[{(]")) -+ "\\<\\(and\\|match\\|begin\\|else\\|exception\\|then\\|try\\(_lwt\\)?\\|with\\|or\\|fun\\|function\\|l\\(e\\|w\\)t\\|do\\)\\>\\|->\\|[[{(]")) - (defun tuareg-find-,-match () - (tuareg-find-kwop tuareg-find-,-match-regexp)) - - (defconst tuareg-find-with-match-regexp - (tuareg-make-find-kwop-regexp -- "\\<\\(match\\|try\\|module\\|begin\\|with\\)\\>\\|[[{(]")) -+ "\\<\\(match\\|try\\(_lwt\\)?\\|module\\|begin\\|with\\)\\>\\|[[{(]")) - (defun tuareg-find-with-match () - (let ((kwop (tuareg-find-kwop tuareg-find-with-match-regexp - "\\"))) -- (if (string= kwop "with") -+ (if (or (string= kwop "with")) - (progn - (tuareg-find-with-match) - (tuareg-find-with-match))) - kwop)) - -+(defun tuareg-find-finally-match () -+ (let ((kwop (tuareg-find-kwop tuareg-find-with-match-regexp -+ "\\"))) -+ (if (or (string= kwop "with")) -+ (tuareg-find-with-match)) -+ kwop)) -+ - (defconst tuareg-find-in-match-regexp -- (tuareg-make-find-kwop-regexp "\\")) -+ (tuareg-make-find-kwop-regexp "\\")) - (defun tuareg-find-in-match () - (let ((kwop (tuareg-find-kwop tuareg-find-in-match-regexp "\\"))) - (cond ((string= kwop "and") (tuareg-find-in-match)) - (t kwop)))) - - (defconst tuareg-find-else-match-regexp -- (tuareg-make-find-kwop-regexp ";\\|->\\|\\")) -+ (tuareg-make-find-kwop-regexp ";\\|->\\|\\<\\(with\\|finally\\)\\>")) - (defun tuareg-find-else-match () - (let ((kwop (tuareg-find-kwop tuareg-find-else-match-regexp -- "->\\|\\<\\(with\\|then\\)\\>"))) -+ "->\\|\\<\\(with\\|finally\\|then\\)\\>"))) - (cond - ((string= kwop "then") - (tuareg-find-match)) - ((string= kwop "with") - (tuareg-find-with-match)) -+ ((string= kwop "finally") -+ (tuareg-find-finally-match)) - ((string= kwop "->") - (setq kwop (tuareg-find-->-match)) - (while (string= kwop "|") - (setq kwop (tuareg-find-|-match))) -- (if (string= kwop "with") -- (tuareg-find-with-match)) -+ (cond -+ ((string= kwop "with") (tuareg-find-with-match)) -+ ((string= kwop "finally") (tuareg-find-finally-match))) - (tuareg-find-else-match)) - ((string= kwop ";") - (tuareg-find-semi-colon-match) -@@ -1497,7 +1513,7 @@ If found, return the actual text of the keyword or operator." - (tuareg-find-do-match) kwop))) - - (defconst tuareg-find-and-match-regexp -- "\\<\\(do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|then\\|\\(down\\)?to\\)\\>\\|\\<\\(for\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|class\\)\\>\\|[][(){}]\\|\\*)\\|\\<\\(rule\\|exception\\|let\\|in\\|type\\|val\\|module\\)\\>") -+ "\\<\\(do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|then\\|\\(down\\)?to\\)\\>\\|\\<\\(for\\(_lwt\\)\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|class\\)\\>\\|[][(){}]\\|\\*)\\|\\<\\(rule\\|exception\\|l\\(e\\|w\\)t\\|in\\|type\\|val\\|module\\)\\>") - (defconst tuareg-find-and-match-regexp-dnr - (concat tuareg-find-and-match-regexp "\\|\\")) - (defun tuareg-find-and-match (&optional do-not-recurse) -@@ -1519,7 +1535,7 @@ If found, return the actual text of the keyword or operator." - (t kwop)))) - - (defconst tuareg-find-=-match-regexp -- (tuareg-make-find-kwop-regexp "\\<\\(val\\|let\\|m\\(ethod\\|odule\\)\\|type\\|class\\|when\\|i[fn]\\)\\>\\|=")) -+ (tuareg-make-find-kwop-regexp "\\<\\(val\\|l\\(e\\\|w\\)t\\|m\\(ethod\\|odule\\)\\|type\\|class\\|when\\|i[fn]\\)\\>\\|=")) - (defun tuareg-find-=-match () - (let ((kwop (tuareg-find-kwop tuareg-find-=-match-regexp - "\\<\\(and\\|in\\)\\>\\|="))) -@@ -1542,7 +1558,7 @@ If found, return the actual text of the keyword or operator." - (defun tuareg-captive-= () - (save-excursion - (tuareg-find-=-match) -- (looking-at "\\<\\(let\\|if\\|when\\|module\\|type\\|class\\)\\>"))) -+ (looking-at "\\<\\(l\\(e\\|w\\)t\\|if\\|when\\|module\\|type\\|class\\)\\>"))) - - (defconst tuareg-find-|-match-regexp - (tuareg-make-find-kwop-regexp -@@ -1575,7 +1591,7 @@ If found, return the actual text of the keyword or operator." - (t kwop)))) - - (defconst tuareg-find-->-match-regexp -- (tuareg-make-find-kwop-regexp "\\<\\(external\\|val\\|method\\|let\\|with\\|fun\\(ction\\|ctor\\)?\\|parser\\)\\>\\|[|:;]")) -+ (tuareg-make-find-kwop-regexp "\\<\\(external\\|val\\|method\\|l\\(e\\|w\\)t\\|with\\|fun\\(ction\\|ctor\\)?\\|parser\\)\\>\\|[|:;]")) - (defun tuareg-find-->-match () - (let ((kwop (tuareg-find-kwop tuareg-find-->-match-regexp "\\"))) - (cond -@@ -1600,7 +1616,7 @@ If found, return the actual text of the keyword or operator." - kwop))))))) - - (defconst tuareg-find-semi-colon-match-regexp -- (tuareg-make-find-kwop-regexp ";[ \t]*\\((\\*\\|$\\)\\|->\\|\\<\\(let\\|method\\|with\\|try\\|initializer\\)\\>")) -+ (tuareg-make-find-kwop-regexp ";[ \t]*\\((\\*\\|$\\)\\|->\\|\\<\\(l\\(e\\|w\\)t\\|method\\|with\\|finally\\|try\\(_lwt\\)?\\|initializer\\)\\>")) - (defun tuareg-find-semi-colon-match (&optional leading-semi-colon) - (tuareg-find-kwop tuareg-find-semi-colon-match-regexp - "\\<\\(in\\|end\\|and\\|do\\|with\\)\\>") -@@ -1644,7 +1660,7 @@ If found, return the actual text of the keyword or operator." - (tuareg-find-in-match) - (tuareg-back-to-paren-or-indentation) - (+ (current-column) tuareg-in-indent)) -- ((looking-at "\\") -+ ((looking-at "\\") - (+ (current-column) tuareg-let-indent)) - (t (tuareg-back-to-paren-or-indentation t) - (+ (current-column) tuareg-default-indent)))) -@@ -1660,7 +1676,7 @@ If found, return the actual text of the keyword or operator." - (if (and (looking-at "\\<\\(type\\|module\\)\\>") (> (point) (point-min)) - (save-excursion - (tuareg-find-meaningful-word) -- (looking-at "\\<\\(module\\|with\\|and\\|let\\)\\>"))) -+ (looking-at "\\<\\(module\\|with\\|and\\|l\\(e\\|w\\)t\\)\\>"))) - (progn - (tuareg-find-meaningful-word) - (+ (current-column) tuareg-default-indent)) -@@ -1669,7 +1685,7 @@ If found, return the actual text of the keyword or operator." - (if phrase-break - tuareg-find-phrase-indentation-regexp-pb - tuareg-find-phrase-indentation-regexp) -- "\\<\\(end\\|and\\|with\\|in\\)\\>")) -+ "\\<\\(end\\|and\\|with\\|finally\\|in\\)\\>")) - (tmpkwop nil) (curr nil)) - (if (and kwop (string= kwop "and")) - (setq kwop (tuareg-find-and-match))) -@@ -1698,7 +1714,7 @@ If found, return the actual text of the keyword or operator." - (if (string= tmpkwop "and") - (setq tmpkwop (tuareg-find-and-match))) - (setq curr (point)) -- (and (string= tmpkwop "let") -+ (and (or (string= tmpkwop "let") (string= tmpkwop "lwt")) - (not (tuareg-looking-at-expression-let)))))) - (goto-char curr) - (tuareg-find-phrase-indentation phrase-break)) -@@ -1706,12 +1722,14 @@ If found, return the actual text of the keyword or operator." - (end-of-line) - (tuareg-skip-blank-and-comments) - (current-column)) -- ((string= kwop "let") -+ ((or (string= tmpkwop "let") (string= tmpkwop "lwt")) - (if (tuareg-looking-at-expression-let) - (tuareg-find-phrase-indentation phrase-break) - (current-column))) - ((string= kwop "with") - (current-column)) -+ ((string= kwop "finally") -+ (current-column)) - ((string= kwop "end") - (current-column)) - ((string= kwop "in") -@@ -1765,12 +1783,12 @@ Returns t iff skipped to indentation." - (if forward-in - tuareg-back-to-paren-or-indentation-in-regexp - tuareg-back-to-paren-or-indentation-regexp)) -- "\\")) -+ "\\")) - (retval)) -- (if (string= kwop "with") -+ (if (or (string= kwop "with") (string= kwop "finally")) - (let ((with-point (point))) - (setq kwop (tuareg-find-with-match)) -- (if (or (string= kwop "match") (string= kwop "try")) -+ (if (or (string= kwop "match") (string= kwop "try") (string= kwop "try_lwt")) - (tuareg-find-kwop - tuareg-back-to-paren-or-indentation-regexp - "\\") -@@ -1778,6 +1796,7 @@ Returns t iff skipped to indentation." - (setq retval - (cond - ((string= kwop "with") nil) -+ ((string= kwop "finally") nil) - ((string= kwop "in") (tuareg-in-indentation-p)) - ((looking-at "[[{(]") (tuareg-search-forward-paren) nil) - ((looking-at "\\.<") -@@ -1792,7 +1811,7 @@ Returns t iff skipped to indentation." - ((and forward-in (string= kwop "in")) - (tuareg-find-in-match) - (tuareg-back-to-paren-or-indentation forward-in) -- (if (looking-at "\\<\\(let\\|and\\)\\>") -+ (if (looking-at "\\<\\(l\\(e\\|w\\)t\\|and\\)\\>") - (forward-char tuareg-in-indent)) nil) - (t retval))))) - -@@ -1993,7 +2012,7 @@ Returns t iff skipped to indentation." - (+ tuareg-type-indent - tuareg-|-extra-unindent)))) - ((looking-at -- "\\<\\(val\\|let\\|m\\(ethod\\|odule\\)\\|class\\|when\\|\\|for\\|if\\)\\>") -+ "\\<\\(val\\|l\\(e\\|w\\)t\\|m\\(ethod\\|odule\\)\\|class\\|when\\|\\|for\\|if\\)\\>") - (let ((matched-string (tuareg-match-string 0))) - (tuareg-back-to-paren-or-indentation t) - (setq current-column-module-type (current-column)) -@@ -2020,12 +2039,12 @@ Returns t iff skipped to indentation." - (not (and tuareg-support-metaocaml - (looking-at "\\.") - (char-equal ?> (preceding-char)))) -- (or (looking-at "[[({;=]\\|\\<\\(begin\\|i[fn]\\|do\\|t\\(ry\\|hen\\)\\|else\\|match\\|wh\\(ile\\|en\\)\\)\\>") -+ (or (looking-at "[[({;=]\\|\\<\\(begin\\|i[fn]\\|do\\|t\\(ry\\(_lwt\\)?\\|hen\\)\\|else\\|match\\|wh\\(ile\\|en\\)\\)\\>") - (looking-at tuareg-operator-regexp))))) - - (defun tuareg-looking-at-false-module () - (save-excursion (tuareg-find-meaningful-word) -- (looking-at "\\<\\(let\\|with\\|and\\)\\>"))) -+ (looking-at "\\<\\(l\\(e\\|w\\)t\\|with\\|and\\)\\>"))) - - (defun tuareg-looking-at-false-sig-struct () - (save-excursion (tuareg-find-module) -@@ -2109,7 +2128,7 @@ Compute new indentation based on Caml syntax." - (t (current-column)))) - ((tuareg-in-literal-p) - (current-column)) -- ((looking-at "\\") -+ ((looking-at "\\") - (if (tuareg-looking-at-expression-let) - (if (tuareg-looking-at-in-let) - (progn -@@ -2339,7 +2358,7 @@ by |, insert one |." - (tuareg-beginning-of-literal-or-comment) (skip-chars-backward " \t\n"))) - - (defconst tuareg-beginning-phrase-regexp -- "^#[ \t]*[a-z][_a-z]*\\>\\|\\<\\(end\\|type\\|module\\|sig\\|struct\\|class\\|exception\\|open\\|let\\)\\>\\|;;" -+ "^#[ \t]*[a-z][_a-z]*\\>\\|\\<\\(end\\|type\\|module\\|sig\\|struct\\|class\\|exception\\|open\\|l\\(e\\|w\\)t\\)\\>\\|;;" - "Regexp matching tuareg phrase delimitors.") - (defun tuareg-find-phrase-beginning () - "Find `real' phrase beginning and return point." -@@ -2351,7 +2370,7 @@ by |, insert one |." - (tuareg-find-kwop tuareg-beginning-phrase-regexp) - (while (and (> (point) (point-min)) (< (point) old-point) - (or (not (looking-at tuareg-beginning-phrase-regexp)) -- (and (looking-at "\\") -+ (and (looking-at "\\") - (tuareg-looking-at-expression-let)) - (and (looking-at "\\") - (tuareg-looking-at-false-module)) -@@ -3280,7 +3299,7 @@ current phrase else insert a newline and indent." - ;; Designed from original code by M. Quercia - - (defconst tuareg-definitions-regexp -- "\\<\\(and\\|val\\|type\\|module\\|class\\|exception\\|let\\)\\>" -+ "\\<\\(and\\|val\\|type\\|module\\|class\\|exception\\|l\\(e\\|w\\)t\\)\\>" - "Regexp matching definition phrases.") - - (defconst tuareg-definitions-bind-skip-regexp