lwt-2.4.3/0000755000000000000000000000000012067037511010516 5ustar0000000000000000lwt-2.4.3/Makefile0000644000000000000000000000266212067037511012164 0ustar0000000000000000# Makefile # -------- # Copyright : (c) 2012, Jeremie Dimino # Licence : BSD3 # # Generic Makefile for oasis project # Set to setup.exe for the release SETUP := setup.exe # Default rule default: build # Setup for the development version setup-dev.exe: _oasis setup.ml sed '/^#/D' setup.ml > setup_dev.ml ocamlfind ocamlopt -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || \ ocamlfind ocamlc -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || true rm -f setup_dev.* # Setup for the release setup.exe: setup.ml ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< rm -f setup.cmx setup.cmi setup.o setup.obj setup.cmo build: $(SETUP) setup.data ./$(SETUP) -build $(BUILDFLAGS) doc: $(SETUP) setup.data build ./$(SETUP) -doc $(DOCFLAGS) test: $(SETUP) setup.data build ./$(SETUP) -test $(TESTFLAGS) all: $(SETUP) ./$(SETUP) -all $(ALLFLAGS) install: $(SETUP) setup.data ./$(SETUP) -install $(INSTALLFLAGS) uninstall: $(SETUP) setup.data ./$(SETUP) -uninstall $(UNINSTALLFLAGS) reinstall: $(SETUP) setup.data ./$(SETUP) -reinstall $(REINSTALLFLAGS) clean: $(SETUP) ./$(SETUP) -clean $(CLEANFLAGS) distclean: $(SETUP) ./$(SETUP) -distclean $(DISTCLEANFLAGS) configure: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) setup.data: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) .PHONY: default build doc test all install uninstall reinstall clean distclean configure lwt-2.4.3/lwt-api.odocl0000644000000000000000000000142212067037511013114 0ustar0000000000000000# 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 lwt-2.4.3/CHANGES.darcs0000644000000000000000000026750312067037505012624 0ustar0000000000000000Thu Dec 27 13:29:50 CET 2012 Jeremie Dimino tagged 2.4.3 Thu Dec 27 13:29:43 CET 2012 Jeremie Dimino * version 2.4.3 Thu Dec 27 13:29:25 CET 2012 Jeremie Dimino * update CHANGES Fri Nov 23 20:41:44 CET 2012 Jeremie Dimino * Lwt_ssl.*_channel_of_decr now close the socket when the channel is closed Sat Nov 17 10:03:43 CET 2012 Jeremie Dimino * fix doc for Lwt_io.open_connection Wed Oct 17 18:07:55 CEST 2012 Jeremie Dimino * add a Makefile It compiles setup.ml to a native executable. Mon Oct 15 21:04:08 CEST 2012 Jeremie Dimino * add tag use_toploop to src/top/* Fri Sep 28 16:29:31 CEST 2012 Jeremie Dimino tagged 2.4.2 Fri Sep 28 16:29:24 CEST 2012 Jeremie Dimino * version 2.4.2 Fri Sep 28 16:28:55 CEST 2012 Jeremie Dimino * upadte CHANGES Fri Sep 28 16:26:34 CEST 2012 Jeremie Dimino * change the default method of Lwt_glib.install to `lwt_into_glib Fri Sep 21 14:35:25 CEST 2012 Jeremie Dimino * fix the exception raised by Lwt_unix.readdir when the end is reached raise End_of_file instead of Not_found (like Unix.readdir) Fri Sep 21 14:20:41 CEST 2012 Jeremie Dimino * fix the stub for Lwt_unix.readdir The job->dir field was not initialized. Tue Sep 18 14:23:52 CEST 2012 Jeremie Dimino * ignore invalid file descriptors returned by glib Fri Sep 14 15:14:24 CEST 2012 Jeremie Dimino * remove old comment It was for a bug that was not in Lwt Wed Sep 12 17:13:33 CEST 2012 Jeremie Dimino * fix split_path in discover.ml Wed Sep 12 16:43:21 CEST 2012 Jeremie Dimino * also use LIBRARY_PATH in discover.ml Wed Sep 12 15:46:21 CEST 2012 Jeremie Dimino * add directories from C_INCLUDE_PATH to search_lists in discover.ml Wed Sep 12 10:14:03 CEST 2012 Jeremie Dimino * use environment variables to pass C library flags to discover.ml Wed Aug 22 19:26:58 CEST 2012 Jeremie Dimino * add Lwt_unix.on_signal_full Same as Lwt_unix.on_signal but also pass the handler id so it can be disabled from inside the handler. Wed Aug 22 09:31:29 CEST 2012 Jeremie Dimino tagged 2.4.1 Wed Aug 22 09:31:20 CEST 2012 Jeremie Dimino * version 2.4.1 Wed Aug 22 09:30:49 CEST 2012 Jeremie Dimino * update CHANGES Sat Aug 18 08:32:32 CEST 2012 Jeremie Dimino * use SO_PEERCRED by default Fri Aug 17 21:00:44 CEST 2012 Jeremie Dimino * fix get_credentials on *BSD Fri Aug 17 09:34:38 CEST 2012 Jeremie Dimino * add a .keepme file in the empty directory src/unix/jobs-unix Thu Aug 16 23:30:50 CEST 2012 Jeremie Dimino * fix get_credentials on OpenBSD Wed Aug 15 18:00:38 CEST 2012 Jeremie Dimino * add Lwt_stream.on_terminate Mon Jul 30 15:49:51 CEST 2012 Jeremie Dimino * fix Lwt_gc Just send a notification inside the finaliser to avoid race conditions. Thu Jul 19 13:28:35 CEST 2012 Jeremie Dimino tagged 2.4.0 Thu Jul 19 13:27:48 CEST 2012 Jeremie Dimino * make the C compiler happy when a job is not available Thu Jul 19 13:17:39 CEST 2012 Jeremie Dimino * update CHANGES Thu Jul 19 13:13:44 CEST 2012 Jeremie Dimino * avoid using async/ignore_result in Lwt_process Thu Jul 19 11:30:53 CEST 2012 Jeremie Dimino * avoid loosing exceptions in Lwt_pool Wed Jul 18 23:41:20 CEST 2012 Jeremie Dimino * Change the signature of Lwt.async and the way uncaught exceptions are handled Wed Jul 18 14:34:51 CEST 2012 jerome.vouillon@pps.univ-paris-diderot.fr * getaddrinfo: empty OCaml string arguments should be mapped to NULL Tue Jul 17 11:34:03 CEST 2012 Jeremie Dimino * Lwt.ignore_result --> Lwt.async Tue Jul 17 11:27:11 CEST 2012 Jeremie Dimino * set the job async method to NONE in run_job_sync If left unset, lwt_unix_free_job might try to destroy an uninitialized mutex. Mon Jul 16 16:59:23 CEST 2012 Jeremie Dimino * update CHANGES Mon Jul 16 16:58:44 CEST 2012 Jeremie Dimino * bump version number Mon Jul 16 16:54:41 CEST 2012 Jeremie Dimino * mark lwt.text and lwt.top as deprecated Mon Jul 16 16:49:47 CEST 2012 Jeremie Dimino * fix compilation of the toplevel with 4.00 Fri Jul 13 16:53:37 CEST 2012 jerome.vouillon@pps.univ-paris-diderot.fr * lwt.ml: initialize the random state lazily (to take advantage of Js_of_ocaml dead code elimination) Thu Jul 12 18:41:04 CEST 2012 jerome.vouillon@pps.univ-paris-diderot.fr * Fix getaddrinfo return value (addresses were returned in reverse order) Thu Jul 12 13:48:15 CEST 2012 Jeremie Dimino * do not use camlp4 in lwt.react Thu Jul 12 13:48:06 CEST 2012 Jeremie Dimino * add the type Lwt.result to wakeup a thread with either a value or an exception Thu Jul 12 13:21:10 CEST 2012 Jeremie Dimino * add Lwt_stream.from_direct for stream with a non-lwt from function Thu Jul 12 13:13:42 CEST 2012 Jeremie Dimino * refactoring of core lib - remove all "open" - use Lwt.map instead Lwt.bind when possible - use constant threads for "return ()", "return None", ... - do not create a new thread when the same one already exists Wed Jul 11 14:31:44 CEST 2012 Jeremie Dimino * do not use camlp4 for the core library Sat Jul 7 16:11:16 CEST 2012 Jeremie Dimino * avoid duplicating lines in setup.data Sat Jul 7 15:58:38 CEST 2012 Jeremie Dimino * check for availability of get{serv,port}..._r functions Tue Jul 3 02:46:14 CEST 2012 Jeremie Dimino * remove extra casts in C stubs Wed Jun 20 11:56:16 CEST 2012 jerome.vouillon@pps.univ-paris-diderot.fr * Fix windows version of lwt_unix_read_job Fri Jun 15 14:45:11 CEST 2012 Jeremie Dimino * add -package compiler-libs.toplevel for simple-top when ocaml >= 4 Thu Jun 14 10:31:10 CEST 2012 Jeremie Dimino * change the way the master lock is handled in libev stubs Instead of checking in each libev callback whether the runtime system must be re-acquired, we tell libev not to invoke pending callbacks and we execute them ourself outside the blocking section. Fri May 18 10:15:47 CEST 2012 Jeremie Dimino * handle exceptions in Lwt.map if the thread is already terminated Lwt.map already breaks tail-recursion so there is no reason not to catch exceptions and wrap them into a thread. Thanks to Daniel B[__]nzli for the remark. Fri May 11 15:32:53 CEST 2012 Jeremie Dimino * simplify generated stubs Wed May 9 18:07:32 CEST 2012 Jeremie Dimino * add a patch for tuareg 2.0.4 Wed Apr 25 07:58:56 CEST 2012 Jeremie Dimino * update setup.ml for oasis 0.3.0 Sat Apr 14 11:48:08 CEST 2012 Jeremie Dimino * better handling of uncaught exceptions Now exceptions raised by ignore_result or on_* cannot leave threads in an unsound state, and when using lwt.unix these exceptions are raised at toplevel only and not at random places. Sat Apr 7 23:53:07 CEST 2012 Jeremie Dimino * better implementation of cancel + more tests Thanks to first class modules the thread(s) to cancel can be stored directly in the sleeper. Sat Apr 7 00:57:49 CEST 2012 Jeremie Dimino * simplify react's events <-> streams functions Fri Apr 6 23:47:05 CEST 2012 Jeremie Dimino * ensure that on_cancel functions are executed first Code using on_cancel always assume it is the case. Fri Apr 6 18:10:31 CEST 2012 Jeremie Dimino * fix Lwt_unix.wrap_syscall When "lwt blocking = ... in" yielded, the exception raised by "action ()" escaped the try ... with. Thu Apr 5 22:35:45 CEST 2012 Jeremie Dimino * add a .mli for generated jobs to fix building of documentation Mon Apr 2 14:50:19 CEST 2012 Jeremie Dimino * document the fact that jobs must not call OCaml code Sun Apr 1 11:11:31 CEST 2012 Jeremie Dimino * update the manual Sun Apr 1 09:47:12 CEST 2012 Jeremie Dimino * add bounded push-streams Sun Apr 1 09:33:01 CEST 2012 Jeremie Dimino * fix myocamlbuild.ml Sat Mar 31 22:30:15 CEST 2012 Jeremie Dimino * simplify stubs for jobs - now a job requires only one external instead of 3 - add a script to generate stubs for jobs Fri Mar 30 17:50:34 CEST 2012 Jeremie Dimino * fix #277: add a function to return the Ssl.socket of a Lwt_ssl.socket Fri Mar 30 16:59:44 CEST 2012 gregoire.henry@pps.univ-paris-diderot.fr * Doc: add title. Thu Mar 29 17:35:54 CEST 2012 Jeremie Dimino * add Lwt_stream.map_exn Thu Mar 29 11:00:56 CEST 2012 Jeremie Dimino * better behavior when accessing the same stream from multiple threads Now iter, fold, find, ... iterate over all the element of the stream, even if another thread consume some of them. Thu Mar 29 09:29:31 CEST 2012 Jeremie Dimino * create a new notification thread only when needed for push streams Thu Mar 29 01:00:20 CEST 2012 Jeremie Dimino * much simpler implementation of streams - use the same custom queue for all cloned streams, only the start pointer change: less memory footprint and no weak pointers needed - push streams add directly their elements at the end of the queue so they only keep a reference to the end of the queue other change: - removed the mutex, now calling get on the same stream from multiple threads at the same time will return the same value. The behavioir was not specified before in this case. Wed Mar 28 17:49:54 CEST 2012 Jeremie Dimino * create the weak array of clones of a stream when it is cloned for the first time Tue Mar 27 21:27:54 CEST 2012 Jeremie Dimino * fix #276 #require "lwt" --> #require "lwt.simple-top" Thu Mar 22 12:46:05 CET 2012 Anil Madhavapeddy * ocamldoc-typos Fix various typos in function descriptions. No functional change. Thu Mar 22 12:38:42 CET 2012 Anil Madhavapeddy * support-getpeereid Add support for Lwt_unix.get_credentials on MacOS X/OpenBSD. A peer uid/gid can be obtained via getpeereid(2) on some platforms, but the peer pid will not be available. In this case, fill in the uid,gid in the credentials, and set pid to -1 to signify that it is not available. Wed Mar 21 02:53:31 CET 2012 gregoire.henry@pps.univ-paris-diderot.fr * Doc: add rules for building the ocamldoc with the wiki syntax Mon Mar 19 11:34:11 CET 2012 Jeremie Dimino * upgrade oasis format to 0.3 Mon Mar 19 01:05:41 CET 2012 Jeremie Dimino * protect the "loop" argument with CAMLparam* macros in libev stubs Sat Mar 17 11:04:54 CET 2012 Jeremie Dimino * handle flag tests in _oasis Mon Mar 12 18:17:40 CET 2012 Jeremie Dimino * assume poll with a 0 timeout might be interrupted Mon Mar 12 00:01:43 CET 2012 Jeremie Dimino * fix a dead-lock between lwt_unix_send_notification and lwt_unix_recv_notifications lwt_unix_send_notification may be called in a signal handler, thus while lwt_unix_recv_notifications has the mutex, leading to a dead-lock. The fix is to block all signals while reading/sending the notification. Wed Mar 7 15:23:53 CET 2012 zol@benozol.de * Lwt_pool: validate elements before usage Tue Feb 14 11:49:07 CET 2012 Jeremie Dimino * do not try to cancel jobs It is too much unpredictable and it allows signals to be received in threads other than ocaml threads (=> segfault if the user defined a signal handler with the module Sys) Tue Feb 14 10:18:54 CET 2012 Jeremie Dimino * fix signal handlers - empty the signal mask if using sigaction - reinstall the signal handler in the handler if using signal Sun Feb 12 20:03:12 CET 2012 Jeremie Dimino * fix the stub for lockf Sun Feb 12 18:45:45 CET 2012 Jeremie Dimino * add Lwt_log.ign_log Thu Feb 9 12:42:53 CET 2012 Jeremie Dimino * do not use ocaml signal handling - it segfault when using non-ocaml threads - we don't need it for sending notifications Wed Feb 8 20:00:30 CET 2012 Jeremie Dimino * update Lwt_unix.system - use Lwt_unix.fork - remove exit hooks in case the exec fail to prevent them from being executed - use CreateProcess(..., "cmd.exe /c ...", ...) on windows Wed Feb 8 10:52:21 CET 2012 Jeremie Dimino * fix lwt.text Mon Jan 30 14:44:22 CET 2012 Jeremie Dimino * port Lwt_process to windows Sun Jan 29 18:48:48 CET 2012 Jeremie Dimino * export the socketpair emulation on windows Sun Jan 29 18:06:45 CET 2012 Jeremie Dimino * put the "windows" optcomp variable in lwt_config.ml Mon Jan 23 22:47:21 CET 2012 Jeremie Dimino * fix a race condition in Lwt_stream.EQueue.pop Sat Jan 21 20:14:45 CET 2012 Jeremie Dimino * close the event used for condition variables on windows Fri Jan 20 16:37:16 CET 2012 Jeremie Dimino * use a null timeout instead of an infinite one for testing if a fd is readable on windows Fri Jan 20 10:40:10 CET 2012 Jeremie Dimino * typo in lwt_unix_stubs.c Tue Jan 17 10:28:48 CET 2012 Jeremie Dimino * add Lwt_preemptive.run_in_main Tue Jan 17 09:55:48 CET 2012 Jeremie Dimino * pass -lws2_32 instead of ws2_32.lib if building with mingw Wed Jan 4 15:00:47 CET 2012 Jeremie Dimino * depend on camlp4 instead of camlp4.lib Wed Dec 28 14:09:07 CET 2011 Jeremie Dimino * fix linker arguments order Wed Dec 28 10:45:22 CET 2011 Jeremie Dimino * add O_SHARE_DELETE to Unix.open_flag for ocaml >= 3.13 Tue Dec 20 21:48:41 CET 2011 Jeremie Dimino * typo in the manual Fri Dec 16 16:44:53 CET 2011 Jeremie Dimino * better configure step for C libraries - save C flags discovered by discover.ml in setup.data and reuse them in myocamlbuild.ml - use pkg-config for libev if possible - detect more problems at configure time Wed Dec 7 17:50:01 CET 2011 Jeremie Dimino * typos in the manual Thu Dec 1 10:49:29 CET 2011 Jeremie Dimino * remove Lwt_main.is_running Thu Dec 1 10:37:31 CET 2011 Jeremie Dimino * add Lwt_main.is_running Sat Nov 12 12:56:23 CET 2011 Jeremie Dimino * add dependencies between flags Fri Nov 4 17:49:55 CET 2011 chambart@crans.org * set the darcs predist option 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 lwt-2.4.3/setup.ml0000644000000000000000000067301112067037511012220 0ustar0000000000000000(* * setup.ml * -------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of lwt. *) (* OASIS_START *) (* DO NOT EDIT (digest: cd0047e1db530cc0543b25fa4b5b7adb) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: 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 prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; } let quiet = {!default with quiet = true} let args () = ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), (s_ " Run quietly"); "-info", Arg.Unit (fun () -> default := {!default with info = true}), (s_ " Display information message"); "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), (s_ " Output debug message")] end module OASISString = struct (* # 1 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; if !what_idx = String.length what then true else false let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; if !what_idx = -1 then true else false let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = String.make (String.length s) 'X' in for i = 0 to String.length s - 1 do buf.[i] <- f s.[i] done; buf end module OASISUtils = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISUtils.ml" *) open OASISGettext 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 varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in String.lowercase buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt end module PropList = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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 () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 71 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true 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 end module OASISVersion = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr 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 = 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) let version_0_3_or_after t = comparator_apply t (VGreaterEqual (string_of_version "0.3")) end module OASISLicense = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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/dim/.opam/4.00.1/build/oasis.0.3.0/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/dim/.opam/4.00.1/build/oasis.0.3.0/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_pack: bool; 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 section_kind = [ `Library | `Executable | `Flag | `SrcRepo | `Test | `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/dim/.opam/4.00.1/build/oasis.0.3.0/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 is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in 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 OASISHostPath = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISHostPath.ml" *) open Filename module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.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) (OASISString.nsplit ufn '/')) end module OASISSection = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** 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 | `Library -> "library" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc") ^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * library * group_t list) (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists (cs, bs, lib) modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) [modul; OASISUnixPath.uncapitalize_file modul; OASISUnixPath.capitalize_file modul] in (* TODO: we should be able to be able to determine the source for every * files. Hence we should introduce a Module(source: fn) for the fields * Modules and InternalModules *) List.fold_left (fun acc base_fn -> match acc with | `No_sources _ -> begin let file_found = List.fold_left (fun acc ext -> if source_file_exists (base_fn^ext) then (base_fn^ext) :: acc else acc) [] [".ml"; ".mli"; ".mll"; ".mly"] in match file_found with | [] -> acc | lst -> `Sources (base_fn, lst) end | `Sources _ -> acc) (`No_sources possible_base_fn) possible_base_fn let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module source_file_exists (cs, bs, lib) modul with | `Sources (base_fn, _) -> [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; lst in List.map (fun nm -> List.map (fun base_fn -> base_fn ^"."^ext) (find_module nm)) lst in (* The headers that should be compiled along *) let headers = if lib.lib_pack then [] else find_modules lib.lib_modules "cmi" in (* The .cmx that be compiled along *) let cmxs = let should_be_built = (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [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^"_stubs"^ext_lib] :: ["dll"^cs.cs_name^"_stubs"^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 @ cmxs) type data = common_section * build_section * library type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children : tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let rec group_of_tree mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> Package (nm, cs, bs, lib, group_of_tree children) | Node (None, children) -> Container (nm, group_of_tree children) | Leaf (cs, bs, lib) -> Package (nm, cs, bs, lib, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, lib) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = Lazy.lazy_from_fun (fun () -> (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty) in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) 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 (if case_sensitive then file_exists_case else Sys.file_exists) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [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 ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end let glob ~ctxt 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 file_exists_case fn then [fn] else [] end end # 2142 "setup.ml" module BaseEnvLight = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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 # 2240 "setup.ml" module BaseContext = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseContext.ml" *) open OASISContext let args = args let default = default end module BaseMessage = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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 end module BaseEnv = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseEnv.ml" *) 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] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.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 | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (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, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> 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) (o, v) -> if res = None then begin try errors, Some (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, _) -> Pervasives.compare o2 o1) 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, fun () -> 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 (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (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" (fun () -> "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 () = env_from_file := MapString.empty; Data.clear env let dump ?(filename=default_filename) () = let chn = open_out_bin filename in let output nm value = Printf.fprintf chn "%s=%S\n" nm value in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try let value = Schema.get schema env nm in output nm value with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; (* End of the dump *) 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 Printf.printf "\nConfiguration: \n"; List.iter (fun (name,value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" 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 -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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) (failwithf (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/dim/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default 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 (fun () -> 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 failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (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 = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> 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/dim/.opam/4.00.1/build/oasis.0.3.0/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 let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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 var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (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 flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) 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 OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> 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") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s : string = ocamlopt () in "true" with PropList.Not_set _ -> let _s : string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage let to_filename fn = let fn = OASISHostPath.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 = OASISHostPath.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/dim/.opam/4.00.1/build/oasis.0.3.0/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/dim/.opam/4.00.1/build/oasis.0.3.0/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 OASISFileUtil.file_exists_case 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 OASISFileUtil.file_exists_case 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 ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (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/dim/.opam/4.00.1/build/oasis.0.3.0/src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, exec) -> if var_choose bs.bs_build then 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) (OASISUtils.varname_of_string cs.cs_name) (fun () -> 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/dim/.opam/4.00.1/build/oasis.0.3.0/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; (* Possible explanation why the tests where not run. *) if OASISVersion.version_0_3_or_after pkg.oasis_version && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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; if OASISVersion.version_0_3_or_after pkg.oasis_version && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* 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 -> failwithf (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 (fun () -> (* Reload if preconf has changed it *) begin try unload (); load (); with _ -> () end; (* Run plugin's configure *) t.configure t.package args; (* Dump to allow postconf to change it *) dump ()) (); (* Reload environment *) unload (); load (); (* Save environment *) print (); (* 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"; ] (failwithf (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; (* Call distclean code *) generic_clean t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test 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)) in clean, distclean let version t _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> "_oasis" in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | n -> failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in try let act_ref = ref (fun _ -> failwithf (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."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (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) (fun () -> 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; if t.setup_update && update_setup_ml t then () else !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end # 4480 "setup.ml" module InternalConfigurePlugin = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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" (Printexc.to_string 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; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || BaseStandardVar.os_type () = "Cygwin" then begin try var_ignore_eval BaseStandardVar.flexlink with e -> warn_exception e; add_errors (f_ "Cannot find 'flexlink'") 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; (* Check if we need native dynlink (presence of libraries that compile to * native) *) begin let has_cmxa = List.exists (function | Library (_, bs, _) -> var_choose bs.bs_build && (bs.bs_compiled_object = Native || (bs.bs_compiled_object = Best && bool_of_string (BaseStandardVar.is_native ()))) | _ -> false) pkg.sections in if has_cmxa then var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) if SetString.empty != !errors then begin List.iter (fun e -> error "%s" e) (SetString.elements !errors); failwithf (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) (SetString.cardinal !errors) end end module InternalInstallPlugin = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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 win32_max_command_line_length = 8000 let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) let first_args = ["install"; findlib_name; meta] in (* Arguments for remaining commands: *) let other_args = ["install"; findlib_name; "-add"] in (* Extract as much files as possible from [files], [len] is the current command line length: *) let rec get_files len acc files = match files with | [] -> (List.rev acc, []) | file :: rest -> let len = len + 1 + String.length file in if len > win32_max_command_line_length then (List.rev acc, files) else get_files len (file :: acc) rest in (* Split the command into several commands. *) let rec split args files = match files with | [] -> [] | _ -> (* Length of "ocamlfind install [META|-add]" *) let len = List.fold_left (fun len arg -> len + 1 (* for the space *) + String.length arg) (String.length ocamlfind) args in match get_files len [] files with | ([], _) -> failwith (s_ "Command line too long.") | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) let () = let findlib_ge_132 = OASISVersion.comparator_apply (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf (f_ "Installing the library %s require to use the flag \ '-add' of ocamlfind because the command line is too \ long. This flag is only available for findlib 1.3.2. \ Please upgrade findlib from %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in cmd :: cmds in (* The first command does not use -add: *) split first_args files else ["install" :: findlib_name :: meta :: files] 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 ?tgt_fn src_file envdir = let tgt_dir = in_destdir (envdir ()) in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) OASISFileUtil.mkdir_parent ~ctxt:!BaseContext.default (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; OASISFileUtil.cp ~ctxt:!BaseContext.default 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 = OASISHostPath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file fn (fun () -> match tgt_opt with | Some s -> OASISHostPath.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 = OASISHostPath.of_unix bs.bs_path in List.fold_left (fun acc modul -> try List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) [modul^".mli"; modul^".ml"; String.uncapitalize modul^".mli"; String.capitalize modul^".mli"; String.uncapitalize modul^".ml"; String.capitalize 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 (OASISFileUtil.file_exists_case res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else n in List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") findlib_name; let ocamlfind = ocamlfind () in let commands = split_install_command ocamlfind findlib_name meta files in List.iter (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) commands; BaseLog.register install_findlib_ev findlib_name end; (* Install data files *) f_data (); in let group_libs, _, _ = findlib_mapping pkg in (* We install libraries in groups *) List.iter install_group_lib group_libs 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 ~tgt_fn:(cs.cs_name ^ ext_program ()) 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 = OASISHostPath.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 OASISFileUtil.file_exists_case 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; OASISFileUtil.rmdir ~ctxt:!BaseContext.default 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; OASISExec.run ~ctxt:!BaseContext.default (ocamlfind ()) ["remove"; data] end else failwithf (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 # 5233 "setup.ml" module OCamlbuildCommon = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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" (fun () -> "") (** 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 []; OASISString.nsplit (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 OASISExec.run ~ctxt:!BaseContext.default (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 *) OASISExec.run ~ctxt:!BaseContext.default (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/dim/.opam/4.00.1/build/oasis.0.3.0/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 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 (OASISHostPath.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.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cma" fn || ends_with ".cmxs" fn || ends_with ".cmxa" fn || ends_with (ext_lib ()) fn || ends_with (ext_dll ()) fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for library %s") 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 target ext = let unix_tgt = (OASISUnixPath.concat bs.bs_path (OASISUnixPath.chop_extension exec.exec_main_is))^ext in let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs in evs, [unix_tgt] 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 OASISFileUtil.file_exists_case fns) then failwithf (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 let cond_targets = (* Run the hook *) !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets)) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) 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/dim/.opam/4.00.1/build/oasis.0.3.0/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 = OASISUnixPath.make [ path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix path; cs.cs_name^".docdir"; ] in run_ocamlbuild [index_html] argv; List.iter (fun glb -> BaseBuilt.register BaseBuilt.BDoc cs.cs_name [OASISFileUtil.glob ~ctxt:!BaseContext.default (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 # 5558 "setup.ml" module CustomPlugin = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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 OASISHostPath.of_unix (cs, bs, lib) in evs end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable OASISHostPath.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 # 5694 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build; test = [ ("core", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_core", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }); ("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)]; }); ("preemptive", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_preemptive", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }) ]; doc = [ ("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)]; }); ("lwt-api", OCamlbuildDocPlugin.doc_build "./") ]; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = [ ("core", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_core", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }); ("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)]; }); ("preemptive", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_preemptive", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }) ]; clean_doc = [ ("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)]; }); ("lwt-api", OCamlbuildDocPlugin.doc_clean "./") ]; distclean = []; distclean_test = [ ("core", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_core", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)]; }); ("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)]; }); ("preemptive", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_preemptive", []))]; 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.3"; ocaml_version = Some (OASISVersion.VGreaterEqual "3.12"); findlib_version = None; name = "lwt"; version = "2.4.3"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "LGPL"; excption = Some "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.3"); 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"; "-use-glib"; "$glib"; "-ccomp-type"; "$ccomp_type"; "-use-pthread"; "$pthread"; "-use-unix"; "$unix" ]))) ]; }; build_type = (`Build, "ocamlbuild", Some "0.3"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; install_type = (`Install, "internal", Some "0.3"); 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"; "src/unix/lwt_unix_jobs_generated.ml"; "src/unix/jobs-unix/*" ]))) ]; }; files_ab = []; sections = [ 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)]; }); Flag ({ cs_name = "syntax"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { flag_description = Some "Build the syntax extension"; flag_default = [(OASISExpr.EBool true, true)]; }); 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 = "react"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { flag_description = Some "React helpers"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "all", true) ]; }); Flag ({ cs_name = "glib"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { flag_description = Some "Glib integration"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "all", true) ]; }); Flag ({ cs_name = "ssl"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { flag_description = Some "SSL support"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "all", true) ]; }); Flag ({ cs_name = "text"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { flag_description = Some "Text mode utilities (deprecated)"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "all", true) ]; }); Flag ({ cs_name = "preemptive"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { flag_description = Some "Preemptive threads support"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "unix", true) ]; }); Flag ({ cs_name = "extra"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { flag_description = Some "Asynchronous unix functions"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "preemptive", true) ]; }); Flag ({ cs_name = "toplevel"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { flag_description = Some "Enhanced toplevel"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "all", true) ]; }); 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) ]; }); Flag ({ cs_name = "pthread"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { flag_description = Some "Use pthread"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), true) ]; }); Library ({ cs_name = "optcomp"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "syntax", OASISExpr.EFlag "all"), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "syntax"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("camlp4", 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_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = []; }); 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_pack = false; 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"; "lwt_process_stubs.c"; "jobs-unix/lwt_unix_job_access.c"; "jobs-unix/lwt_unix_job_chdir.c"; "jobs-unix/lwt_unix_job_chmod.c"; "jobs-unix/lwt_unix_job_chown.c"; "jobs-unix/lwt_unix_job_chroot.c"; "jobs-unix/lwt_unix_job_close.c"; "jobs-unix/lwt_unix_job_fchmod.c"; "jobs-unix/lwt_unix_job_fchown.c"; "jobs-unix/lwt_unix_job_fdatasync.c"; "jobs-unix/lwt_unix_job_fsync.c"; "jobs-unix/lwt_unix_job_ftruncate.c"; "jobs-unix/lwt_unix_job_link.c"; "jobs-unix/lwt_unix_job_lseek.c"; "jobs-unix/lwt_unix_job_mkdir.c"; "jobs-unix/lwt_unix_job_mkfifo.c"; "jobs-unix/lwt_unix_job_rename.c"; "jobs-unix/lwt_unix_job_rmdir.c"; "jobs-unix/lwt_unix_job_symlink.c"; "jobs-unix/lwt_unix_job_tcdrain.c"; "jobs-unix/lwt_unix_job_tcflow.c"; "jobs-unix/lwt_unix_job_tcflush.c"; "jobs-unix/lwt_unix_job_tcsendbreak.c"; "jobs-unix/lwt_unix_job_truncate.c"; "jobs-unix/lwt_unix_job_unlink.c" ]; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [ (OASISExpr.EBool true, []); (OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32")), ["-lws2_32"]); (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), ["ws2_32.lib"]); (OASISExpr.EAnd (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32"))), ["ws2_32.lib"; "-lws2_32"]) ]; 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_pack = false; lib_internal_modules = ["Lwt_log_rules"; "Lwt_unix_jobs_generated"]; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "unix"; lib_findlib_containers = []; }); 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_pack = false; lib_internal_modules = ["Lwt_simple_top"]; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "simple-top"; 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_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "react"; 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_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "preemptive"; lib_findlib_containers = []; }); 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_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "extra"; lib_findlib_containers = []; }); 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_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "glib"; 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_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "ssl"; 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_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "text"; lib_findlib_containers = []; }); 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_pack = false; lib_internal_modules = ["Lwt_ocaml_completion"]; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "top"; lib_findlib_containers = []; }); Library ({ cs_name = "lwt-syntax"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "syntax", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "syntax", OASISExpr.EFlag "all"), true) ]; bs_path = "syntax"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("camlp4", 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_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "syntax"; lib_findlib_containers = []; }); Library ({ cs_name = "lwt-syntax-options"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "syntax", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "syntax", OASISExpr.EFlag "all"), true) ]; bs_path = "syntax"; bs_compiled_object = Best; bs_build_depends = [FindlibPackage ("camlp4", 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_pack = false; lib_internal_modules = ["Pa_lwt_options"]; lib_findlib_parent = Some "lwt-syntax"; lib_findlib_name = Some "options"; lib_findlib_containers = []; }); Library ({ cs_name = "lwt-syntax-log"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "syntax", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "syntax", OASISExpr.EFlag "all"), true) ]; bs_path = "syntax"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("camlp4", 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_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt-syntax"; lib_findlib_name = Some "log"; lib_findlib_containers = []; }); 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"; }); Doc ({ cs_name = "lwt-manual"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { doc_type = (`Doc, "custom", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", 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"]; }); Doc ({ cs_name = "lwt-api"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", 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"]; }); 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"; }); 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 = "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 = "test"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", 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 = [ 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, [])]; }, { lib_modules = ["Test"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = []; }); Executable ({ cs_name = "test_core"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", 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"; }); Executable ({ cs_name = "test_unix"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", 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"; }); Executable ({ cs_name = "test_react"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", 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_preemptive"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EAnd (OASISExpr.EFlag "preemptive", OASISExpr.EFlag "unix"), OASISExpr.EFlag "all")), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "tests/preemptive"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "test"; InternalLibrary "lwt"; FindlibPackage ("unix", None); InternalLibrary "lwt-unix"; InternalLibrary "lwt-preemptive"; 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, [])]; }, {exec_custom = false; exec_main_is = "main.ml"; }); Test ({ cs_name = "core"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { test_type = (`Test, "custom", Some "0.3"); 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.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"))), true) ]; test_tools = [ ExternalTool "ocamlbuild"; InternalExecutable "test_core" ]; }); Test ({ cs_name = "unix"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { test_type = (`Test, "custom", Some "0.3"); 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.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"))), true) ]; test_tools = [ ExternalTool "ocamlbuild"; InternalExecutable "test_unix" ]; }); Test ({ cs_name = "react"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { test_type = (`Test, "custom", Some "0.3"); 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.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EAnd (OASISExpr.EFlag "unix", OASISExpr.EFlag "react"), OASISExpr.EFlag "all"))), true) ]; test_tools = [ ExternalTool "ocamlbuild"; InternalExecutable "test_react" ]; }); Test ({ cs_name = "preemptive"; cs_data = PropList.Data.create (); cs_plugin_data = []; }, { test_type = (`Test, "custom", Some "0.3"); test_command = [(OASISExpr.EBool true, ("$test_preemptive", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)]; }; test_working_directory = None; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EAnd (OASISExpr.EFlag "preemptive", OASISExpr.EFlag "unix"), OASISExpr.EFlag "all"))), true) ]; test_tools = [ ExternalTool "ocamlbuild"; InternalExecutable "test_preemptive" ]; }); 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; }) ]; plugins = [(`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3")]; schema_data = PropList.Data.create (); plugin_data = []; }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; oasis_digest = Some "F}\204\233\235\176 5\138\233\223\1934Q\250G"; oasis_exec = None; oasis_setup_args = []; setup_update = false; };; let setup () = BaseSetup.setup setup_t;; # 7417 "setup.ml" (* 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 ();; lwt-2.4.3/myocamlbuild.ml0000644000000000000000000006652512067037511013547 0ustar0000000000000000(* 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. *) (* OASIS_START *) (* DO NOT EDIT (digest: f8bb682062d00fda8435ad960078cac2) *) module OASISGettext = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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/dim/.opam/4.00.1/build/oasis.0.3.0/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 # 117 "myocamlbuild.ml" module BaseEnvLight = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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 # 215 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) | _ -> () end module MyOCamlbuildBase = struct (* # 21 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall *) open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler type dir = string type file = string type name = string type tag = string (* # 56 "/home/dim/.opam/4.00.1/build/oasis.0.3.0/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; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) includes: (dir * dir list) list; } let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = fun e -> List.iter (fun dispatch -> dispatch e) lst let tag_libstubs nm = "use_lib"^nm^"_stubs" let nm_libstubs nm = nm^"_stubs" 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 | nm, [] -> ocaml_lib nm | nm, dir :: tl -> ocaml_lib ~dir:dir (dir^"/"^nm); List.iter (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) tl) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; (* Declare C libraries *) List.iter (fun (lib, dir, headers) -> (* Handle C part of library *) flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. *) dep ["link"; "ocaml"; "program"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; "program"; tag_libstubs lib] [dir/"lib"^(nm_libstubs 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 # 476 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [ ("optcomp", ["syntax"]); ("lwt", ["src/core"]); ("lwt-unix", ["src/unix"]); ("lwt-simple-top", ["src/simple_top"]); ("lwt-react", ["src/react"]); ("lwt-preemptive", ["src/preemptive"]); ("lwt-extra", ["src/extra"]); ("lwt-glib", ["src/glib"]); ("lwt-ssl", ["src/ssl"]); ("lwt-text", ["src/text"]); ("lwt-top", ["src/top"]); ("lwt-syntax", ["syntax"]); ("lwt-syntax-options", ["syntax"]); ("lwt-syntax-log", ["syntax"]); ("test", ["tests"]) ]; lib_c = [ ("lwt-unix", "src/unix", ["src/unix/lwt_config.h"; "src/unix/lwt_unix.h"]); ("lwt-glib", "src/glib", []); ("lwt-text", "src/text", []) ]; flags = [ (["oasis_library_lwt_unix_cclib"; "link"], [ (OASISExpr.EBool true, S []); (OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32")), S [A "-cclib"; A "-lws2_32"]); (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), S [A "-cclib"; A "ws2_32.lib"]); (OASISExpr.EAnd (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32"))), S [A "-cclib"; A "ws2_32.lib"; A "-cclib"; A "-lws2_32"]) ]); (["oasis_library_lwt_unix_cclib"; "ocamlmklib"; "c"], [ (OASISExpr.EBool true, S []); (OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32")), S [A "-lws2_32"]); (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), S [A "ws2_32.lib"]); (OASISExpr.EAnd (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32"))), S [A "ws2_32.lib"; A "-lws2_32"]) ]) ]; includes = [ ("tests/unix", ["src/core"; "src/unix"; "tests"]); ("tests/react", ["src/core"; "src/react"; "src/unix"; "tests"]); ("tests/preemptive", ["src/core"; "src/preemptive"; "src/unix"; "tests"]); ("tests/core", ["src/core"; "src/unix"; "tests"]); ("tests", ["src/core"; "src/unix"]); ("src/unix", ["src/core"]); ("src/top", ["src/core"; "src/react"; "src/text"]); ("src/text", ["src/core"; "src/react"; "src/unix"]); ("src/ssl", ["src/unix"]); ("src/simple_top", ["src/core"; "src/unix"]); ("src/react", ["src/core"]); ("src/preemptive", ["src/core"; "src/unix"]); ("src/glib", ["src/core"; "src/unix"]); ("src/extra", ["src/core"; "src/preemptive"]); ("examples/unix", ["src/unix"; "syntax"]) ]; } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; # 586 "myocamlbuild.ml" (* OASIS_STOP *) open Ocamlbuild_plugin let split str = let rec skip_spaces i = if i = String.length str then [] else if str.[i] = ' ' then skip_spaces (i + 1) else extract i (i + 1) and extract i j = if j = String.length str then [String.sub str i (j - i)] else if str.[j] = ' ' then String.sub str i (j - i) :: skip_spaces (j + 1) else extract i (j + 1) in skip_spaces 0 let define_c_library name env = if BaseEnvLight.var_get name env = "true" then begin let tag = Printf.sprintf "use_C_%s" name in let opt = List.map (fun x -> A x) (split (BaseEnvLight.var_get (name ^ "_opt") env)) and lib = List.map (fun x -> A x) (split (BaseEnvLight.var_get (name ^ "_lib") env)) 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) end 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"]; (* Stubs: *) let env = BaseEnvLight.load ~allow_empty:true ~filename:MyOCamlbuildBase.env_filename () in (* Check for "unix" because other variables are not present in the setup.data file if lwt.unix is disabled. *) if BaseEnvLight.var_get "unix" env = "true" then begin define_c_library "glib" env; define_c_library "libev" env; define_c_library "pthread" env; flag ["c"; "compile"; "use_lwt_headers"] & S [A"-ccopt"; A"-Isrc/unix"]; (* With ocaml >= 4, toploop.cmi is not in the stdlib path *) let ocaml_major_version = Scanf.sscanf (BaseEnvLight.var_get "ocaml_version" env) "%d" (fun x -> x) in if ocaml_major_version >= 4 then List.iter (fun stage -> flag ["ocaml"; stage; "use_toploop"] & S[A "-package"; A "compiler-libs.toplevel"]) ["compile"; "ocamldep"; "doc"]; (* Toplevel stuff *) flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg"; 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))])) end | _ -> ()) (* Compile the wiki version of the Ocamldoc. Thanks to Till Varoquaux on usenet: http://www.digipedia.pl/usenet/thread/14273/231/ *) let ocamldoc_wiki tags deps docout docdir = let tags = tags -- "extension:html" in Ocamlbuild_pack.Ocaml_tools.ocamldoc_l_dir tags deps docout docdir let () = try let wikidoc_dir = let base = Ocamlbuild_pack.My_unix.run_and_read "ocamlfind query wikidoc" in String.sub base 0 (String.length base - 1) in Ocamlbuild_pack.Rule.rule "ocamldoc: document ocaml project odocl & *odoc -> wikidocdir" ~insert:`top ~prod:"%.wikidocdir/index.wiki" ~stamp:"%.wikidocdir/wiki.stamp" ~dep:"%.odocl" (Ocamlbuild_pack.Ocaml_tools.document_ocaml_project ~ocamldoc:ocamldoc_wiki "%.odocl" "%.wikidocdir/index.wiki" "%.wikidocdir"); tag_file "lwt-api.wikidocdir/index.wiki" ["apiref";"wikidoc"]; flag ["wikidoc"] & S[A"-i";A wikidoc_dir;A"-g";A"odoc_wiki.cma"] with Failure e -> () (* Silently fail if the package wikidoc isn't available *) lwt-2.4.3/discover.ml0000644000000000000000000004255612067037505012705 0ustar0000000000000000(* 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 *) open Printf (* +-----------------------------------------------------------------+ | Search path | +-----------------------------------------------------------------+ *) (* List of search paths for header files, mostly for MacOS users. libev is installed by port systems into non-standard locations by default on MacOS. We use a hardcorded list of path + the ones from C_INCLUDE_PATH and LIBRARY_PATH. *) let ( // ) = Filename.concat let default_search_paths = List.map (fun dir -> (dir ^ "/include", dir ^ "/lib")) [ "/usr"; "/usr/local"; "/opt"; "/opt/local"; "/sw"; "/mingw"; ] let path_sep = if Sys.os_type = "Win32" then ';' else ':' let split_path str = let len = String.length str in let rec aux i = if i >= len then [] else let j = try String.index_from str i path_sep with Not_found -> len in String.sub str i (j - i) :: aux (j + 1) in aux 0 let search_paths = let get var f = try List.map f (split_path (Sys.getenv var)) with Not_found -> [] in List.flatten [ get "C_INCLUDE_PATH" (fun dir -> (dir, dir // ".." // "lib")); get "LIBRARY_PATH" (fun dir -> (dir // ".." // "include", dir)); default_search_paths; ] (* +-----------------------------------------------------------------+ | 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 struct_name = " #define _GNU_SOURCE #include #include #include CAMLprim value lwt_test() { struct " ^ struct_name ^ " cred; socklen_t cred_len = sizeof(cred); getsockopt(0, SOL_SOCKET, SO_PEERCRED, &cred, &cred_len); return Val_unit; } " let get_peereid_code = " #include #include #include CAMLprim value lwt_test() { uid_t euid; gid_t egid; getpeereid(0, &euid, &egid); return Val_unit; } " let fdatasync_code = " #include #include CAMLprim value lwt_test() { fdatasync(0); return Val_unit; } " let glib_code = " #include #include CAMLprim value lwt_test() { g_main_context_dispatch(0); return Val_unit; } " let netdb_reentrant_code = " #include #include CAMLprim value lwt_test() { getprotobyname_r(0, 0, 0, 0, 0); getprotobynumber_r(0, 0, 0, 0, 0); getservbyname_r(0, 0, 0, 0, 0, 0); getservbyport_r(0, 0, 0, 0, 0, 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 use_glib = ref false let use_pthread = ref true let use_unix = ref true let os_type = ref "Unix" let ccomp_type = ref "cc" 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_include, dir_lib) :: dirs -> if Sys.file_exists (dir_include // header) then Some (dir_include, dir_lib) else loop dirs in loop search_paths let compile (opt, lib) stub_file = ksprintf Sys.command "%s -custom %s %s %s %s > %s 2>&1" !ocamlc (String.concat " " (List.map (sprintf "-ccopt %s") opt)) (Filename.quote stub_file) (Filename.quote !caml_file) (String.concat " " (List.map (sprintf "-cclib %s") lib)) (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 () = fprintf config "\ #ifndef __LWT_CONFIG_H #define __LWT_CONFIG_H " let not_available = ref [] let test_feature ?(do_check = true) name macro test = if do_check then begin printf "testing for %s:%!" name; if test () then begin if macro <> "" then begin fprintf config "#define %s\n" macro; fprintf config_ml "#let %s = true\n" macro end; printf " %s available\n%!" (String.make (34 - String.length name) '.') end else begin if macro <> "" then begin fprintf config "//#define %s\n" macro; fprintf config_ml "#let %s = false\n" macro end; printf " %s unavailable\n%!" (String.make (34 - String.length name) '.'); not_available := name :: !not_available end end else begin printf "not checking for %s\n%!" name; if macro <> "" then begin fprintf config "//#define %s\n" macro; fprintf config_ml "#let %s = false\n" macro end end (* +-----------------------------------------------------------------+ | pkg-config | +-----------------------------------------------------------------+ *) let split str = let rec skip_spaces i = if i = String.length str then [] else if str.[i] = ' ' then skip_spaces (i + 1) else extract i (i + 1) and extract i j = if j = String.length str then [String.sub str i (j - i)] else if str.[j] = ' ' then String.sub str i (j - i) :: skip_spaces (j + 1) else extract i (j + 1) in skip_spaces 0 let pkg_config flags = if ksprintf Sys.command "pkg-config %s > %s 2>&1" flags !log_file = 0 then begin let ic = open_in !log_file in let line = input_line ic in close_in ic; split line end else raise Exit let pkg_config_flags name = try (* Get compile flags. *) let opt = ksprintf pkg_config "--cflags %s" name in (* Get linking flags. *) let lib = if !ccomp_type = "msvc" then (* With msvc we need to pass "glib-2.0.lib" instead of "-lglib-2.0" otherwise executables will fail. *) ksprintf pkg_config "--libs-only-L %s" name @ ksprintf pkg_config "--libs-only-l --msvc-syntax %s" name else ksprintf pkg_config "--libs %s" name in Some (opt, lib) with Exit -> None let lib_flags env_var_prefix fallback = let get var = try Some (split (Sys.getenv var)) with Not_found -> None in match get (env_var_prefix ^ "_CFLAGS"), get (env_var_prefix ^ "_LIBS") with | Some opt, Some lib -> (opt, lib) | x -> let opt, lib = fallback () in match x with | Some opt, Some lib -> assert false | Some opt, None -> (opt, lib) | None, Some lib -> (opt, lib) | None, None -> (opt, lib) (* +-----------------------------------------------------------------+ | Entry point | +-----------------------------------------------------------------+ *) let arg_bool r = Arg.Symbol (["true"; "false"], function | "true" -> r := true | "false" -> r := false | _ -> assert false) 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_bool use_libev, " whether to check for libev"; "-use-glib", arg_bool use_glib, " whether to check for glib"; "-use-pthread", arg_bool use_pthread, " whether to use pthread"; "-use-unix", arg_bool use_unix, " whether to build lwt.unix"; "-os-type", Arg.Set_string os_type, " type of the target os"; "-ccomp-type", Arg.Set_string ccomp_type, " C compiler type"; ] in Arg.parse args ignore "check for external C libraries and available features\noptions are:"; (* Check nothing if we do not build lwt.unix. *) if not !use_unix then exit 0; (* 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 setup_data = ref [] in (* Test for pkg-config. *) test_feature ~do_check:(!use_libev || !use_glib) "pkg-config" "" (fun () -> ksprintf Sys.command "pkg-config --version > %s 2>&1" !log_file = 0); (* Not having pkg-config is not fatal. *) let have_pkg_config = !not_available = [] in not_available := []; let test_libev () = let opt, lib = lib_flags "LIBEV" (fun () -> match if have_pkg_config then pkg_config_flags "libev" else None with | Some (opt, lib) -> (opt, lib) | None -> match search_header "ev.h" with | Some (dir_i, dir_l) -> (["-I" ^ dir_i], ["-L" ^ dir_l; "-lev"]) | None -> ([], ["-lev"])) in setup_data := ("libev_opt", opt) :: ("libev_lib", lib) :: !setup_data; test_code (opt, lib) libev_code in let test_pthread () = let opt, lib = lib_flags "PTHREAD" (fun () -> match search_header "pthread.h" with | Some (dir_i, dir_l) -> (["-I" ^ dir_i], ["-L" ^ dir_l; "-lpthread"]) | None -> ([], ["-lpthread"])) in setup_data := ("pthread_opt", opt) :: ("pthread_lib", lib) :: !setup_data; test_code (opt, lib) pthread_code in let test_glib () = let opt, lib = lib_flags "GLIB" (fun () -> match if have_pkg_config then pkg_config_flags "glib-2.0" else None with | Some (opt, lib) -> (opt, lib) | None -> ([], ["-lglib-2.0"])) in setup_data := ("glib_opt", opt) :: ("glib_lib", lib) :: !setup_data; test_code (opt, lib) glib_code in test_feature ~do_check:!use_libev "libev" "HAVE_LIBEV" test_libev; test_feature ~do_check:!use_pthread "pthread" "HAVE_PTHREAD" test_pthread; test_feature ~do_check:!use_glib "glib" "" test_glib; if !not_available <> [] then begin if not have_pkg_config then printf "Warning: the 'pkg-config' command is not available."; printf " The following recquired C libraries are missing: %s. Please install them and retry. If they are installed in a non-standard location or need special flags, set the environment variables _CLFAGS and _LIBS accordingly and retry. For example, if libev is installed in /opt/local, you can type: export LIBEV_CLFAGS=-I/opt/local/include export LIBEV_LIBS=-L/opt/local/lib To compile without libev support, use ./configure --disable-libev ... " (String.concat ", " !not_available); exit 1 end; if !os_type <> "Win32" && not !use_pthread then begin printf " No threading library available! One is needed if you want to build lwt.unix. Lwt can use pthread or the win32 API. "; exit 1 end; let do_check = !os_type <> "Win32" in test_feature ~do_check "eventfd" "HAVE_EVENTFD" (fun () -> test_code ([], []) eventfd_code); test_feature ~do_check "fd passing" "HAVE_FD_PASSING" (fun () -> test_code ([], []) fd_passing_code); test_feature ~do_check "sched_getcpu" "HAVE_GETCPU" (fun () -> test_code ([], []) getcpu_code); test_feature ~do_check "affinity getting/setting" "HAVE_AFFINITY" (fun () -> test_code ([], []) affinity_code); test_feature ~do_check "credentials getting (Linux)" "HAVE_GET_CREDENTIALS_LINUX" (fun () -> test_code ([], []) (get_credentials_code "ucred")); test_feature ~do_check "credentials getting (NetBSD)" "HAVE_GET_CREDENTIALS_NETBSD" (fun () -> test_code ([], []) (get_credentials_code "sockcred")); test_feature ~do_check "credentials getting (OpenBSD)" "HAVE_GET_CREDENTIALS_OPENBSD" (fun () -> test_code ([], []) (get_credentials_code "sockpeercred")); test_feature ~do_check "credentials getting (FreeBSD)" "HAVE_GET_CREDENTIALS_FREEBSD" (fun () -> test_code ([], []) (get_credentials_code "cmsgcred")); test_feature ~do_check "credentials getting (getpeereid)" "HAVE_GETPEEREID" (fun () -> test_code ([], []) get_peereid_code); test_feature ~do_check "fdatasync" "HAVE_FDATASYNC" (fun () -> test_code ([], []) fdatasync_code); test_feature ~do_check "netdb_reentrant" "HAVE_NETDB_REENTRANT" (fun () -> test_code ([], []) netdb_reentrant_code); let get_cred_vars = [ "HAVE_GET_CREDENTIALS_LINUX"; "HAVE_GET_CREDENTIALS_NETBSD"; "HAVE_GET_CREDENTIALS_OPENBSD"; "HAVE_GET_CREDENTIALS_FREEBSD"; "HAVE_GETPEEREID"; ] in Printf.fprintf config "\ #if %s # define HAVE_GET_CREDENTIALS #endif " (String.concat " || " (List.map (Printf.sprintf "defined(%s)") get_cred_vars)); Printf.fprintf config_ml "#let HAVE_GET_CREDENTIALS = %s\n" (String.concat " || " get_cred_vars); if !os_type = "Win32" then begin output_string config "#define LWT_ON_WINDOWS\n"; output_string config_ml "#let windows=true\n" end else begin output_string config "//#define LWT_ON_WINDOWS\n"; output_string config_ml "#let windows=false\n" end; fprintf config "#endif\n"; (* Our setup.data keys. *) let setup_data_keys = [ "libev_opt"; "libev_lib"; "pthread_lib"; "pthread_opt"; "glib_opt"; "glib_lib"; ] in (* Load setup.data *) let setup_data_lines = match try Some (open_in "setup.data") with Sys_error _ -> None with | Some ic -> let rec aux acc = match try Some (input_line ic) with End_of_file -> None with | None -> close_in ic; acc | Some line -> match try Some(String.index line '=') with Not_found -> None with | Some idx -> let key = String.sub line 0 idx in if List.mem key setup_data_keys then aux acc else aux (line :: acc) | None -> aux (line :: acc) in aux [] | None -> [] in (* Add flags to setup.data *) let setup_data_lines = List.fold_left (fun lines (name, args) -> sprintf "%s=%S" name (String.concat " " args) :: lines) setup_data_lines !setup_data in let oc = open_out "setup.data" in List.iter (fun str -> output_string oc str; output_char oc '\n') (List.rev setup_data_lines); close_out oc; close_out config; close_out config_ml; (* Generate stubs. *) print_endline "Generating C stubs..."; exit (Sys.command "ocaml src/unix/gen_stubs.ml") lwt-2.4.3/configure0000755000000000000000000000055412067037511012431 0ustar0000000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7) set -e FST=true for i in "$@"; do if $FST; then set -- FST=false fi case $i in --*=*) ARG=${i%%=*} VAL=${i##*=} set -- "$@" "$ARG" "$VAL" ;; *) set -- "$@" "$i" ;; esac done ocaml setup.ml -configure "$@" # OASIS_STOP lwt-2.4.3/apiref-intro0000644000000000000000000000442712067037505013052 0ustar0000000000000000{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} lwt-2.4.3/_tags0000644000000000000000000003223212067037511011540 0ustar0000000000000000# -*- 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 # Disable camlp4 for at least the core and react libraries, we will # see for other ones latter: : -syntax_camlp4o, -pkg_camlp4, -pa_lwt_options, -pa_lwt, -pa_lwt_log, -pa_optcomp : use_toploop : use_toploop : use_compiler_libs, pkg_text, pkg_text.bigarray, pkg_findlib, pkg_react, pkg_unix, pkg_bigarray : syntax_camlp4o, pkg_camlp4, pa_optcomp # Stubs : use_C_libev, use_C_pthread : use_C_glib : use_C_pthread <**/*.c>: use_lwt_headers <**/*.h>: use_lwt_headers # OASIS_START # DO NOT EDIT (digest: af5c8b5eda7464ee6955bf7247d5f091) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse ".bzr": not_hygienic ".hg": -traverse ".hg": not_hygienic ".git": -traverse ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic # Library optcomp "syntax/optcomp.cmxs": use_optcomp # Library lwt "src/core/lwt.cmxs": use_lwt # Library lwt-unix "src/unix/lwt-unix.cmxs": use_lwt-unix : oasis_library_lwt_unix_cclib "src/unix/liblwt-unix_stubs.lib": oasis_library_lwt_unix_cclib "src/unix/dlllwt-unix_stubs.dll": oasis_library_lwt_unix_cclib "src/unix/liblwt-unix_stubs.a": oasis_library_lwt_unix_cclib "src/unix/dlllwt-unix_stubs.so": oasis_library_lwt_unix_cclib : use_liblwt-unix_stubs : 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 "src/unix/lwt_process_stubs.c": use_lwt "src/unix/lwt_process_stubs.c": pkg_unix "src/unix/lwt_process_stubs.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_access.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_access.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_access.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_chdir.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_chdir.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_chdir.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_chmod.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_chmod.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_chmod.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_chown.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_chown.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_chown.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_chroot.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_chroot.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_chroot.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_close.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_close.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_close.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_fchmod.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_fchmod.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_fchmod.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_fchown.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_fchown.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_fchown.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_fdatasync.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_fdatasync.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_fdatasync.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_fsync.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_fsync.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_fsync.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_ftruncate.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_ftruncate.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_ftruncate.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_link.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_link.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_link.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_lseek.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_lseek.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_lseek.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_mkdir.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_mkdir.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_mkdir.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_mkfifo.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_mkfifo.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_mkfifo.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_rename.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_rename.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_rename.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_rmdir.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_rmdir.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_rmdir.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_symlink.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_symlink.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_symlink.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_tcdrain.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_tcdrain.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_tcdrain.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_tcflow.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_tcflow.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_tcflow.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_tcflush.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_tcflush.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_tcflush.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_tcsendbreak.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_tcsendbreak.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_tcsendbreak.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_truncate.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_truncate.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_truncate.c": pkg_bigarray "src/unix/jobs-unix/lwt_unix_job_unlink.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_unlink.c": pkg_unix "src/unix/jobs-unix/lwt_unix_job_unlink.c": pkg_bigarray # Library lwt-simple-top "src/simple_top/lwt-simple-top.cmxs": use_lwt-simple-top : use_lwt-unix : use_lwt : pkg_unix : pkg_bigarray # Library lwt-react "src/react/lwt-react.cmxs": use_lwt-react : use_lwt : pkg_react # Library lwt-preemptive "src/preemptive/lwt-preemptive.cmxs": use_lwt-preemptive : use_lwt-unix : use_lwt : pkg_unix : pkg_threads : pkg_bigarray # Library lwt-extra "src/extra/lwt-extra.cmxs": use_lwt-extra : use_lwt-preemptive : use_lwt-unix : use_lwt : pkg_unix : pkg_threads : pkg_bigarray # Library lwt-glib "src/glib/lwt-glib.cmxs": use_lwt-glib : use_liblwt-glib_stubs : 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 # Library lwt-ssl "src/ssl/lwt-ssl.cmxs": use_lwt-ssl : use_lwt-unix : use_lwt : pkg_unix : pkg_ssl : pkg_bigarray # Library lwt-text "src/text/lwt-text.cmxs": use_lwt-text : use_liblwt-text_stubs : use_lwt-react : use_lwt-unix : use_lwt : pkg_unix : pkg_react : pkg_text : pkg_text.bigarray : 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_react "src/text/lwt_text_stubs.c": pkg_text "src/text/lwt_text_stubs.c": pkg_text.bigarray "src/text/lwt_text_stubs.c": pkg_bigarray # Library lwt-top "src/top/lwt-top.cmxs": use_lwt-top # Library lwt-syntax "syntax/lwt-syntax.cmxs": use_lwt-syntax : pkg_camlp4.extend # Library lwt-syntax-options "syntax/lwt-syntax-options.cmxs": use_lwt-syntax-options # Library lwt-syntax-log "syntax/lwt-syntax-log.cmxs": use_lwt-syntax-log : pkg_camlp4 : pkg_camlp4.quotations.o # 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_react "src/top/lwt_toplevel.byte": pkg_text "src/top/lwt_toplevel.byte": pkg_findlib "src/top/lwt_toplevel.byte": pkg_text.bigarray "src/top/lwt_toplevel.byte": pkg_bigarray : use_lwt-top : use_lwt-text : use_lwt-react : use_lwt-unix : use_lwt : pkg_unix : pkg_react : pkg_text : pkg_findlib : pkg_text.bigarray : pkg_bigarray # Executable logging : use_lwt-unix : use_lwt : use_lwt-syntax : pkg_unix : pkg_camlp4 : pkg_camlp4.quotations.o : pkg_camlp4.extend : pkg_bigarray # Executable relay : use_lwt-unix : use_lwt : use_lwt-syntax : pkg_unix : pkg_camlp4 : pkg_camlp4.quotations.o : pkg_camlp4.extend : pkg_bigarray # Executable parallelize : use_lwt-unix : use_lwt : use_lwt-syntax : pkg_unix : pkg_camlp4 : pkg_camlp4.quotations.o : pkg_camlp4.extend : pkg_bigarray : use_lwt-unix : use_lwt : use_lwt-syntax : pkg_unix : pkg_camlp4 : pkg_camlp4.quotations.o : pkg_camlp4.extend : pkg_bigarray # Library test "tests/test.cmxs": use_test : use_lwt-unix : use_lwt : pkg_unix : 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 # 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 # 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_preemptive : use_test : use_lwt-preemptive : use_lwt-unix : use_lwt : pkg_unix : pkg_threads : pkg_bigarray : use_test : use_lwt-preemptive : use_lwt-unix : use_lwt : pkg_unix : pkg_threads : pkg_bigarray # OASIS_STOP lwt-2.4.3/_oasis0000644000000000000000000002724312067037505011731 0ustar0000000000000000# +-------------------------------------------------------------------+ # | Package parameters | # +-------------------------------------------------------------------+ OASISFormat: 0.3 OCamlVersion: >= 3.12 Name: lwt Version: 2.4.3 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.3), META (0.3) XDevFilesEnableMakefile: false PostConfCommand: ocaml discover.ml -ocamlc $ocamlc -ext-obj $ext_obj -exec-name $default_executable_name -use-libev $libev -os-type $os_type -use-glib $glib -ccomp-type $ccomp_type -use-pthread $pthread -use-unix $unix PostDistCleanCommand: $rm src/unix/lwt_config.h src/unix/lwt_config.ml src/unix/lwt_unix_jobs_generated.ml src/unix/jobs-unix/* 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 syntax Description: Build the syntax extension Default: true Flag unix Description: Unix support Default: true Flag react Description: React helpers Default$: flag(all) Flag glib Description: Glib integration Default$: flag(all) Flag ssl Description: SSL support Default$: flag(all) Flag text Description: Text mode utilities (deprecated) Default$: flag(all) Flag preemptive Description: Preemptive threads support Default$: flag(unix) Flag extra Description: Asynchronous unix functions Default$: flag(preemptive) Flag toplevel Description: Enhanced toplevel Default$: flag(all) Flag libev Description: Compile with libev support Default$: !os_type(Win32) Flag pthread Description: Use pthread Default$: !os_type(Win32) # +-------------------------------------------------------------------+ # | Libraries | # +-------------------------------------------------------------------+ Library "optcomp" Install: false Build$: flag(syntax) || flag(all) Path: syntax Modules: Pa_optcomp BuildDepends: camlp4, 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, Lwt_unix_jobs_generated BuildDepends: lwt, unix, bigarray XMETADescription: Unix support for lwt CSources: lwt_config.h, lwt_unix.h, lwt_unix_stubs.c, lwt_libev_stubs.c, lwt_process_stubs.c, jobs-unix/lwt_unix_job_access.c, jobs-unix/lwt_unix_job_chdir.c, jobs-unix/lwt_unix_job_chmod.c, jobs-unix/lwt_unix_job_chown.c, jobs-unix/lwt_unix_job_chroot.c, jobs-unix/lwt_unix_job_close.c, jobs-unix/lwt_unix_job_fchmod.c, jobs-unix/lwt_unix_job_fchown.c, jobs-unix/lwt_unix_job_fdatasync.c, jobs-unix/lwt_unix_job_fsync.c, jobs-unix/lwt_unix_job_ftruncate.c, jobs-unix/lwt_unix_job_link.c, jobs-unix/lwt_unix_job_lseek.c, jobs-unix/lwt_unix_job_mkdir.c, jobs-unix/lwt_unix_job_mkfifo.c, jobs-unix/lwt_unix_job_rename.c, jobs-unix/lwt_unix_job_rmdir.c, jobs-unix/lwt_unix_job_symlink.c, jobs-unix/lwt_unix_job_tcdrain.c, jobs-unix/lwt_unix_job_tcflow.c, jobs-unix/lwt_unix_job_tcflush.c, jobs-unix/lwt_unix_job_tcsendbreak.c, jobs-unix/lwt_unix_job_truncate.c, jobs-unix/lwt_unix_job_unlink.c if os_type(Win32) && ccomp_type(msvc) CCLib+: ws2_32.lib else if os_type(Win32) CCLib+: -lws2_32 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 (deprecated) 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 (deprecated) Library "lwt-syntax" Build$: flag(syntax) || flag(all) Install$: flag(syntax) || flag(all) FindlibName: syntax FindlibParent: lwt Path: syntax Modules: Pa_lwt BuildDepends: camlp4, camlp4.quotations.o, camlp4.extend XMETAType: syntax XMETADescription: Syntactic sugars for Lwt XMETARequires: camlp4, lwt.syntax.options Library "lwt-syntax-options" Build$: flag(syntax) || flag(all) Install$: flag(syntax) || flag(all) FindlibName: options FindlibParent: lwt-syntax Path: syntax InternalModules: Pa_lwt_options BuildDepends: camlp4 XMETAType: syntax XMETADescription: Options for syntax extensions XMETARequires: camlp4 Library "lwt-syntax-log" Build$: flag(syntax) || flag(all) Install$: flag(syntax) || flag(all) FindlibName: log FindlibParent: lwt-syntax Path: syntax Modules: Pa_lwt_log BuildDepends: camlp4, 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.3) 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.3) 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(tests) && (flag(unix) || flag(all)) BuildDepends: lwt, unix, lwt.unix Executable test_core Path: tests/core Build$: flag(tests) && (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(tests) && (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(tests) && ((flag(unix) && flag(react)) || flag(all)) Install: false CompiledObject: best MainIs: main.ml BuildDepends: test, lwt, unix, lwt.unix, react, lwt.react Executable test_preemptive Path: tests/preemptive Build$: flag(tests) && ((flag(preemptive) && flag(unix)) || flag(all)) Install: false CompiledObject: best MainIs: main.ml BuildDepends: test, lwt, unix, lwt.unix, lwt.preemptive, threads Test core Command: $test_core TestTools: test_core Run$: flag(tests) && (flag(unix) || flag(all)) Test unix Command: $test_unix TestTools: test_unix Run$: flag(tests) && (flag(unix) || flag(all)) Test react Command: $test_react TestTools: test_react Run$: flag(tests) && ((flag(unix) && flag(react)) || flag(all)) Test preemptive Command: $test_preemptive TestTools: test_preemptive Run$: flag(tests) && ((flag(preemptive) && flag(unix)) || flag(all)) # +-------------------------------------------------------------------+ # | Misc | # +-------------------------------------------------------------------+ SourceRepository head Type: darcs Location: http://ocsigen.org/darcs/lwt Browser: http://ocsigen.org/darcsweb/?r=lwt;a=summary lwt-2.4.3/README0000644000000000000000000000452612067037505011410 0ustar0000000000000000Lwt: 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. -------------------------------------------------------------------------- lwt-2.4.3/LICENSE0000644000000000000000000000041212067037505011523 0ustar0000000000000000The 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. lwt-2.4.3/COPYING0000644000000000000000000007062412067037505011565 0ustar0000000000000000This 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. lwt-2.4.3/CHANGES0000644000000000000000000002417212067037505011522 0ustar0000000000000000===== 2.4.3 (2012-12-27) ===== * fix Lwt_ssl.{in,out}_channel_of_descr: shutdown and close the socket when the channel is closed ===== 2.4.2 (2012-09-28) ===== * fix the stub for Lwt_unix.readdir * change the default method for Lwt_glib.install (use the glib main loop by default: more portable) * ignore invalid file descriptors returned by glib (like the emulation of select in glib does) * use environment variables in discover.ml - use LIBRARY_PATH and C_INCLUDE_PATH for searching headers - allow to pass flags for a library in _CLFAGS and _LIBS * add Lwt_unix.on_signal_full ===== 2.4.1 (2012-08-22) ===== * Add Lwt_stream.on_terminate * Fix Lwt_gc * Fix stubs for get_credentials on *BSD ===== 2.4.0 (2012-07-16) ===== * Reimplement Lwt_stream - much simpler and more efficient - do not use Weak - add bounded push streams * Add Lwt.async * Add Lwt_preemptive.run_in_main * Implement Lwt_unix.get_credentials on MacOS X/OpenBSD * Ensure that on_cancel functions are executed first * Better implementation of Lwt.cancel with more tests * Simplify the API for unix jobs * Better handling of the master lock in libev stubs * Windows fixes/updates: - pass -lws2_32 instead of ws2_32.lib if building with mingw - fix a bug causing Lwt_unix.read/write to block when a socket is not readable/writable - port Lwt_process and Lwt_unix.system to windows * Compatibility with ocaml 4.00: - add O_SHARE_DELETE to Lwt_unix.open_flag - add -package compiler-libs.toplevel for files using Toploop * Do not use module Sys for signal handling to avoid ocaml code to be called in a C thread * Fix Lwt_unix.wrap_syscall: try instead of Lwt.catch * Fix a dead-lock between lwt_unix_send_notification and lwt_unix_recv_notifications * Fix #277: add a function to return the Ssl.socket of a Lwt_ssl.socket * Fix problems with C libraries detection/linking ===== 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 lwt-2.4.3/utils/0000755000000000000000000000000012067037505011661 5ustar0000000000000000lwt-2.4.3/utils/tuareg-2.0.4.patch0000644000000000000000000005651512067037505014644 0ustar0000000000000000--- tuareg-2.0.4/tuareg.el 2010-11-14 15:22:06.000000000 +0100 +++ tuareg-2.0.4-lwt/tuareg.el 2012-05-09 18:02:04.811798035 +0200 @@ -1046,7 +1046,7 @@ '("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" "lwt" "in" "then" "with")) (setq abbrevs-changed nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1174,39 +1174,39 @@ (setq tuareg-font-lock-keywords `(,@(and (tuareg-editing-ls3) - '(("\\<\\(let[ \t\n]+\\(clock\\|node\\|static\\)\\|present\\|automaton\\|where\\|match\\|with\\|do\\|done\\|unless\\|until\\|reset\\|every\\)\\>" + '(("\\<\\(let[ \t\n]+\\(clock\\|node\\|static\\)\\|present\\|automaton\\|where\\|match\\|match_lwt\\|with\\|do\\|done\\|unless\\|until\\|reset\\|every\\)\\>" 0 tuareg-font-lock-governing-face nil nil))) - ("\\<\\(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\\|object\\|and\\|begin\\|end\\)\\>" + ("\\<\\(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\\|object\\|and\\|begin\\|end\\)\\>" 0 tuareg-font-lock-governing-face nil nil) ,@(and tuareg-support-metaocaml '(("\\.<\\|>\\.\\|\\.~\\|\\.!" 0 tuareg-font-lock-multistage-face nil nil))) ("\\<\\(false\\|true\\)\\>" 0 font-lock-constant-face nil nil) - ("\\<\\(as\\|do\\(ne\\|wnto\\)?\\|else\\|for\\|if\\|mutable\\|new\\|p\\(arser\\|rivate\\)\\|t\\(hen\\|o\\|ry\\)\\|wh\\(en\\|ile\\)\\|match\\|with\\|lazy\\|exception\\|raise\\|failwith[f]?\\|exit\\|assert\\|fun\\(ction\\)?\\)\\>" + ("\\<\\(as\\|do\\(ne\\|wnto\\)?\\|else\\|for\\|for_lwt\\|if\\|mutable\\|new\\|p\\(arser\\|rivate\\)\\|t\\(hen\\|o\\|ry\\)\\|try_lwt\\|finally\\|raise_lwt\\|assert_lwt\\|wh\\(en\\|ile\\)\\|match\\|match_lwt\\|with\\|lazy\\|exception\\|raise\\|failwith[f]?\\|exit\\|assert\\|fun\\(ction\\)?\\)\\>" 0 font-lock-keyword-face nil nil) ,@(if (tuareg-editing-ls3) '(("\\<\\(merge\\|when\\|emit\\|period\\)\\>" 0 font-lock-keyword-face nil nil) ("[][;,()|{}]\\|[@^!:*=<>&/%+~?#---]\\.?\\|\\.\\.\\.*\\|\\<\\(asr\\|asl\\|lsr\\|lsl\\|l?or\\|l?and\\|lxor\\|l?not\\|mod\\|of\\|ref\\|fby\\|pre\\|last\\|at\\)\\>" 0 tuareg-font-lock-operator-face nil nil) - ("\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+\\(rec\\|clock\\|node\\|static\\)\\)?\\)\\>[ \t\n]*\\(['_[:lower:]]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)" + ("\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\|lwt\\([ \t\n]+\\(rec\\|clock\\|node\\|static\\)\\)?\\)\\>[ \t\n]*\\(['_[:lower:]]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)" 9 font-lock-function-name-face keep nil)) '(("[][;,()|{}]\\|[@^!:*=<>&/%+~?#---]\\.?\\|\\.\\.\\.*\\|\\<\\(asr\\|asl\\|lsr\\|lsl\\|l?or\\|l?and\\|lxor\\|l?not\\|mod\\|of\\|ref\\)\\>" 0 tuareg-font-lock-operator-face nil nil) - ("\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(['_[:lower:]]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)" + ("\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\|lwt\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(['_[:lower:]]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)" 8 font-lock-function-name-face keep nil))) ("\\[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" 3 font-lock-function-name-face keep nil) ("\\<\\(fun\\(ction\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_ \t()*,]\\)+\\)" 3 font-lock-variable-name-face keep nil) ,@(if (tuareg-editing-ls3) - '(("\\<\\(reset\\|do\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" + '(("\\<\\(reset\\|do\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\|lwt\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" 4 font-lock-variable-name-face keep nil) - ("\\<\\(reset\\|do\\|val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\([ \t\n]+\\(rec\\|clock\\|node\\|static\\)\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" + ("\\<\\(reset\\|do\\|val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\|lwt\\([ \t\n]+\\(rec\\|clock\\|node\\|static\\)\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" 7 font-lock-variable-name-face keep nil)) - '(("\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" + '(("\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\|lwt\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" 4 font-lock-variable-name-face keep nil) - ("\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" + ("\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\|lwt\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" 6 font-lock-variable-name-face keep nil))) ( "\\<\\(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) @@ -1347,7 +1347,8 @@ "else" "exception" "external" "to" "then" "try" "type" "virtual" "val" "while" "when" "with" "if" "in" "inherit" "for" "fun" "functor" "function" "let" "do" "downto" - "parse" "parser" "rule" "of") + "parse" "parser" "rule" "of" + "lwt" "match_lwt" "try_lwt" "for_lwt" "while_lwt" "finally") "\\|->\\|[;,|]") "Regexp for all recognized keywords.") @@ -1405,7 +1406,7 @@ (defconst tuareg-matching-kwop-regexp (concat tuareg-matching-keyword-regexp - "\\|\\\\|[|>]?\\]\\|>?}\\|[|)]\\|;;") + "\\|\\<\\(with\\|finally\\)\\>\\|[|>]?\\]\\|>?}\\|[|)]\\|;;") "Regexp matching Caml keywords or operators which act as end block delimiters.") (defconst tuareg-matching-kwop-regexp-ls3 @@ -1419,7 +1420,7 @@ tuareg-matching-kwop-regexp)) (defconst tuareg-block-regexp - (concat (tuareg-ro "for" "while" "do" "if" "begin" "sig" "struct" "object") + (concat (tuareg-ro "for" "for_lwt" "while" "while_lwt" "do" "if" "begin" "sig" "struct" "object") "\\|[][(){}]\\|\\*)")) (defconst tuareg-find-kwop-regexp @@ -1427,7 +1428,7 @@ (defconst tuareg-find-kwop-regexp-ls3 (concat tuareg-find-kwop-regexp "\\|" - (tuareg-ro "where" "automaton" "present" "match"))) + (tuareg-ro "where" "automaton" "present" "match" "match_lwt"))) (defun tuareg-give-find-kwop-regexp () (if (tuareg-editing-ls3) @@ -1436,7 +1437,7 @@ (defconst tuareg-governing-phrase-regexp (tuareg-ro "val" "type" "method" "module" "constraint" "class" "inherit" - "initializer" "external" "exception" "open" "let" "object" + "initializer" "external" "exception" "open" "let" "lwt" "object" "include") "Regexp matching tuareg phrase delimitors.") @@ -1450,7 +1451,9 @@ ("begin" . tuareg-begin-indent) (".<" . tuareg-begin-indent) ("for" . tuareg-for-while-indent) + ("for_lwt" . tuareg-for-while-indent) ("while" . tuareg-for-while-indent) + ("while_lwt" . tuareg-for-while-indent) ("do" . tuareg-do-indent) ("val" . tuareg-val-indent) ("fun" . tuareg-fun-indent) @@ -1458,8 +1461,12 @@ ("then" . tuareg-if-then-else-indent) ("else" . tuareg-if-then-else-indent) ("let" . tuareg-let-indent) + ("lwt" . tuareg-let-indent) ("match" . tuareg-match-indent) + ("match_lwt" . tuareg-match-indent) ("try" . tuareg-try-indent) + ("try_lwt" . tuareg-try-indent) + ("finally" . tuareg-try-indent) ("rule" . tuareg-rule-indent) ;; Case match keywords @@ -1492,6 +1499,7 @@ ("in" . tuareg-find-in-match) ("where" . tuareg-find-in-match) ("with" . tuareg-find-with-match) + ("finally" . tuareg-find-with-match) ("else" . tuareg-find-else-match) ("then" . tuareg-find-then-match) ("do" . tuareg-find-do-match) @@ -1503,7 +1511,7 @@ (defun tuareg-find-leading-kwop-match (kwop) (funcall (cdr (assoc kwop tuareg-leading-kwop-alist)))) -(defconst tuareg-binding-regexp "\\(\\\\|(*\\\\)") +(defconst tuareg-binding-regexp "\\(\\\\|(*\\\\|(*\\\\)") (defun tuareg-assoc-indent (kwop &optional look-for-let-or-and) "Return relative indentation of the keyword given in argument." @@ -1577,11 +1585,12 @@ (defconst tuareg-find-and-match-regexp (concat (tuareg-ro "do" "done" "else" "end" "in" "then" "down" "downto" "for" "while" "do" "if" "begin" "sig" "struct" "class" - "rule" "exception" "let" "in" "type" "val" "module") + "rule" "exception" "let" "in" "type" "val" "module" + "lwt" "try_lwt" "for_lwt" "while_lwt" "finally") "\\|[][(){}]\\|\\*)")) (defconst tuareg-find-phrase-beginning-regexp (concat (tuareg-ro "end" "type" "module" "sig" "struct" "class" - "exception" "open" "let") + "exception" "open" "let" "lwt") "\\|^#[ \t]*[a-z][_a-z]*\\>\\|;;")) (defconst tuareg-find-phrase-beginning-and-regexp (concat "\\<\\(and\\)\\>\\|" tuareg-find-phrase-beginning-regexp)) @@ -1604,35 +1613,35 @@ (setq tuareg-find-comma-match-regexp (tuareg-make-find-kwop-regexp - (concat (tuareg-ro "and" "match" "begin" "else" "exception" "then" "try" - "with" "or" "fun" "function" "let" "do") + (concat (tuareg-ro "and" "match" "match_lwt" "begin" "else" "exception" "then" "try" "try_lwt" + "with" "or" "fun" "function" "let" "lwt" "do" "finally") "\\|->\\|[[{(]")) tuareg-find-with-match-regexp (tuareg-make-find-kwop-regexp - (concat (tuareg-ro "match" "try" "module" "begin" "with" "type") + (concat (tuareg-ro "match" "match_lwt" "try" "try_lwt" "module" "begin" "with" "type" "finally") "\\|[[{(]")) tuareg-find-in-match-regexp - (tuareg-make-find-kwop-regexp (tuareg-ro "let" "open")) + (tuareg-make-find-kwop-regexp (tuareg-ro "let" "lwt" "open")) tuareg-find-else-match-regexp (tuareg-make-find-kwop-regexp ";") tuareg-find-do-match-regexp (tuareg-make-find-kwop-regexp "->") tuareg-find-=-match-regexp (tuareg-make-find-kwop-regexp - (concat (tuareg-ro "val" "let" "method" "module" "type" "class" "when" + (concat (tuareg-ro "val" "let" "lwt" "method" "module" "type" "class" "when" "if" "in" "do") "\\|=")) tuareg-find-pipe-match-regexp (tuareg-make-find-kwop-regexp (tuareg-give-match-pipe-kwop-regexp)) tuareg-find-arrow-match-regexp (tuareg-make-find-kwop-regexp - (concat (tuareg-ro "external" "type" "val" "method" "let" "with" "fun" + (concat (tuareg-ro "external" "type" "val" "method" "let" "lwt" "with" "fun" "function" "functor" "class" "parser") "\\|[|;]")) tuareg-find-semicolon-match-regexp (tuareg-make-find-kwop-regexp (concat ";" tuareg-no-more-code-this-line-regexp "\\|->\\|" - (tuareg-ro "let" "method" "with" "try" "initializer"))) + (tuareg-ro "let" "lwt" "method" "with" "try" "try_lwt" "initializer" "finally"))) tuareg-find-phrase-indentation-regexp (tuareg-make-find-kwop-regexp (concat tuareg-governing-phrase-regexp "\\|" (tuareg-ro "and" "every"))) @@ -1651,7 +1660,7 @@ (concat tuareg-find-comma-match-regexp "\\|=") tuareg-find-monadic-match-regexp (concat tuareg-block-regexp "\\|\\([;=]\\)\\|\\(->\\)\\|" - (tuareg-ro "val" "let" "method" "module" "type" "class" "when" + (tuareg-ro "val" "let" "lwt" "method" "module" "type" "class" "when" "if" "in" "do" "done" "end")))) (defun tuareg-strip-trailing-whitespace (string) @@ -1838,7 +1847,8 @@ ((string= kwop2 "and") (tuareg-find-and-match)) ((and (string= kwop "module") - (string= kwop2 "let")) + (or (string= kwop2 "let") + (string= kwop2 "lwt"))) kwop2) (t (goto-char old-point) kwop)))) (t kwop)))) @@ -1873,7 +1883,7 @@ (looking-at tuareg-if-when-regexp))) (defconst tuareg-captive-regexp - (tuareg-ro "let" "if" "when" "module" "type" "class")) + (tuareg-ro "let" "lwt" "if" "when" "module" "type" "class")) (defun tuareg-captive-= () (save-excursion (tuareg-find-=-match) @@ -1955,7 +1965,7 @@ kwop))))))) (defconst tuareg-semicolon-match-stop-regexp - (tuareg-ro "and" "do" "end" "in" "with")) + (tuareg-ro "and" "do" "end" "in" "with" "finally")) (defconst tuareg-no-code-after-paren-regexp (tuareg-no-code-after "[[{(][|<]?")) (defun tuareg-semicolon-indent-kwop-point (&optional leading-semi-colon) @@ -2004,11 +2014,14 @@ ((string= kwop "where") (tuareg-find-in-match) (+ (tuareg-paren-or-indentation-column) tuareg-in-indent)) - ((string= kwop "let") + ((or (string= kwop "let") (string= kwop "lwt")) (+ (current-column) tuareg-let-indent)) ((string= kwop "try") (forward-char 3) (skip-syntax-forward " ") (current-column)) + ((string= kwop "try_lwt") + (forward-char 7) (skip-syntax-forward " ") + (current-column)) (t (tuareg-paren-or-indentation-indent))) kwop point))) @@ -2020,7 +2033,7 @@ (setq ,kwop (tuareg-find-and-match)))) (defconst tuareg-phrase-regexp-1 (tuareg-ro "module" "type")) -(defconst tuareg-phrase-regexp-2 (tuareg-ro "and" "let" "module" "with")) +(defconst tuareg-phrase-regexp-2 (tuareg-ro "and" "let" "lwt" "module" "with")) (defconst tuareg-phrase-regexp-3 (tuareg-ro "and" "end" "every" "in" "with")) (defun tuareg-find-phrase-indentation (&optional phrase-break) @@ -2069,7 +2082,8 @@ (setq tmpkwop (tuareg-find-in-match)) (tuareg-reset-and-kwop tmpkwop) (setq curr (point)) - (and (string= tmpkwop "let") + (and (or (string= tmpkwop "let") + (string= tmpkwop "lwt")) (not (tuareg-looking-at-internal-let)))))) (goto-char curr) (tuareg-find-phrase-indentation phrase-break)) @@ -2077,7 +2091,7 @@ (end-of-line) (tuareg-skip-blank-and-comments) (current-column)) - ((string= kwop "let") + ((or (string= kwop "let") (string= kwop "lwt")) (if (tuareg-looking-at-internal-let) (tuareg-find-phrase-indentation phrase-break) (current-column))) @@ -2122,16 +2136,18 @@ tuareg-back-to-paren-or-indentation-regexp tuareg-paren-or-indentation-stop-regexp)) (retval)) - (when (string= kwop "with") + (when (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 "match_lwt") + (string= kwop "try") (string= kwop "try_lwt")) (tuareg-find-kwop tuareg-back-to-paren-or-indentation-regexp "\\") (setq kwop "with") (goto-char with-point)))) (setq retval (cond ((string= kwop "with") nil) + ((string= kwop "finally") nil) ((or (string= kwop "in") (string= kwop "do")) (tuareg-in-indentation-p)) ; ((looking-at "[[{(]") (tuareg-search-forward-paren) nil) @@ -2166,8 +2182,8 @@ (defconst tuareg-internal-let-regexp (concat "[[({;=]\\|" - (tuareg-ro "begin" "open" "if" "in" "do" "try" "then" "else" - "match" "while" "when"))) + (tuareg-ro "begin" "open" "if" "in" "do" "try" "try_lwt" "then" "else" + "match" "match_lwt" "while" "while_lwt" "when"))) (defun tuareg-looking-at-internal-let () (save-excursion (tuareg-find-meaningful-word) @@ -2178,7 +2194,7 @@ (or (looking-at tuareg-internal-let-regexp) (looking-at tuareg-operator-regexp))))) -(defconst tuareg-false-module-regexp (tuareg-ro "and" "let" "with")) +(defconst tuareg-false-module-regexp (tuareg-ro "and" "let" "lwt" "with")) (defun tuareg-looking-at-false-module () (save-excursion (tuareg-find-meaningful-word) @@ -2302,7 +2318,9 @@ (goto-char matching-pos) (tuareg-find-arrow-match) ; matching `val' or `let' (+ (current-column) tuareg-val-indent)) - ((or (string= matching-kwop "val") (string= matching-kwop "let")) + ((or (string= matching-kwop "val") + (string= matching-kwop "let") + (string= matching-kwop "lwt")) (+ (current-column) tuareg-val-indent)) ((string= matching-kwop "|") (goto-char matching-pos) @@ -2338,7 +2356,8 @@ (tuareg-find-arrow-match) (+ (current-column) tuareg-default-indent)) ((or (string= kwop "val") - (string= kwop "let")) + (string= kwop "let") + (string= kwop "lwt")) (goto-char pos) (+ (current-column) tuareg-val-indent)) ((string= kwop "type") @@ -2409,7 +2428,8 @@ (char-equal ?\{ (preceding-char)))) (tuareg-backward-char) (tuareg-indent-from-paren t start-pos)) - ((and (looking-at "\\") (string= mkwop "in")) + ((and (or (looking-at "\\") + (looking-at "\\")) (string= mkwop "in")) (+ (current-column) tuareg-in-indent)) (t (+ (tuareg-paren-or-indentation-column) (tuareg-assoc-indent mkwop))))) @@ -2419,7 +2439,7 @@ (tuareg-indent-from-paren leading-operator start-pos) (+ tuareg-default-indent (tuareg-indent-from-paren leading-operator start-pos)))) - ((or (string= kwop "let") (string= kwop "and")) + ((or (string= kwop "let") (string= kwop "lwt") (string= kwop "and")) (tuareg-back-to-paren-or-indentation) (+ (tuareg-paren-or-indentation-indent) (tuareg-assoc-indent kwop t))) @@ -2458,13 +2478,19 @@ (+ (current-column) -3 tuareg-default-indent) (skip-syntax-forward " ") (+ (current-column) tuareg-default-indent))) + ((string= kwop "try_lwt") + (forward-char 7) + (if (looking-at tuareg-no-more-code-this-line-regexp) + (+ (current-column) -7 tuareg-default-indent) + (skip-syntax-forward " ") + (+ (current-column) tuareg-default-indent))) (t (+ (if (tuareg-in-indentation-p) (current-column) (tuareg-paren-or-indentation-indent)) (tuareg-assoc-indent kwop t))))) (defconst tuareg-=-indent-regexp-1 - (tuareg-ro "val" "let" "method" "module" "class" "when" "for" "if" "do")) + (tuareg-ro "val" "let" "lwt" "method" "module" "class" "when" "for" "for_lwt" "if" "do")) (defun tuareg-compute-=-indent (start-pos) (let ((current-column-module-type nil) (kwop1 (tuareg-find-=-match)) @@ -2510,7 +2536,7 @@ (current-column)) (defconst tuareg-definitions-regexp - (tuareg-ro "and" "val" "type" "module" "class" "exception" "let") + (tuareg-ro "and" "val" "type" "module" "class" "exception" "let" "lwt") "Regexp matching definition phrases.") (defun tuareg-compute-normal-indent () @@ -2649,7 +2675,9 @@ (string= matching-kwop "struct")) (tuareg-paren-or-indentation-indent)) ((or (string= matching-kwop "try") - (string= matching-kwop "match")) + (string= matching-kwop "try_lwt") + (string= matching-kwop "match") + (string= matching-kwop "match_lwt")) (tuareg-compute-kwop-indent-general kwop matching-kwop)) (t (goto-char old-point) (tuareg-compute-kwop-indent-general kwop matching-kwop)))) @@ -2668,6 +2696,7 @@ (and (string= kwop "end") (tuareg-editing-ls3) (or (string= matching-kwop "match") + (string= matching-kwop "match_lwt") (string= matching-kwop "automaton") (string= matching-kwop "present")))) (if (tuareg-in-indentation-p) @@ -2675,7 +2704,8 @@ (tuareg-paren-or-indentation-column))) ((string= kwop "in") (+ (current-column) - (tuareg-add-default-indent (string= matching-kwop "let")))) + (tuareg-add-default-indent (or (string= matching-kwop "let") + (string= matching-kwop "lwt"))))) ((not (string= kwop "and")) ; pretty general case (tuareg-compute-kwop-indent-general kwop matching-kwop)) ((string= matching-kwop "with") @@ -2737,7 +2767,7 @@ (t (current-column)))) ((tuareg-in-literal-p) (current-column)) - ((or (looking-at "\\") (looking-at "\\")) + ((or (looking-at "\\") (looking-at "\\") (looking-at "\\")) (if (tuareg-looking-at-internal-let) (if (tuareg-looking-at-in-let) (progn @@ -2932,7 +2962,7 @@ (tuareg-find-kwop tuareg-find-phrase-beginning-regexp)) (while (and (> (point) (point-min)) (< (point) old-point) (or (not (looking-at tuareg-find-phrase-beginning-and-regexp)) - (and (looking-at "\\") + (and (or (looking-at "\\") (looking-at "\\")) (tuareg-looking-at-internal-let)) (and (looking-at "\\") (save-excursion lwt-2.4.3/utils/tuareg-1.45.6.patch0000644000000000000000000005007112067037505014725 0ustar0000000000000000diff --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 lwt-2.4.3/utils/style.css0000644000000000000000000000503612067037505013537 0ustar0000000000000000/* 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% } lwt-2.4.3/utils/ocamlinit0000644000000000000000000000145212067037505013565 0ustar0000000000000000(* -*- 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;; lwt-2.4.3/tests/0000755000000000000000000000000012067037511011660 5ustar0000000000000000lwt-2.4.3/tests/test.mllib0000644000000000000000000000013112067037511013653 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 0cbc6611f5540bd0809a388dc95a615b) Test # OASIS_STOP lwt-2.4.3/tests/META0000644000000000000000000000053512067037511012334 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 7fc5c5045d3f68c12c448dc5f6922e55) version = "2.4.3" description = "Lightweight thread library for Objective Caml" requires = "lwt unix lwt.unix" archive(byte) = "test.cma" archive(byte, plugin) = "test.cma" archive(native) = "test.cmxa" archive(native, plugin) = "test.cmxs" exists_if = "test.cma" # OASIS_STOP lwt-2.4.3/tests/test.mli0000644000000000000000000000307112067037505013346 0ustar0000000000000000(* 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_direct : name : string -> run : (unit -> bool) -> t (** Defines a test. [run] must returns [true] if the test succeeded and [false] otherwise. *) val test : name : string -> run : (unit -> bool Lwt.t) -> t (** Defines a test which returns a thread. *) 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. *) lwt-2.4.3/tests/test.ml0000644000000000000000000000551112067037505013176 0ustar0000000000000000(* 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; } type suite = { suite_name : string; suite_tests : t list; } let test_direct ~name ~run = { name = name; run = run } let test ~name ~run = { name = name; run = (fun () -> Lwt_main.run (run ())) } let suite ~name ~tests = { suite_name = name; suite_tests = tests } let run ~name ~suites = (* Count the number of tests in [suites] *) let total = List.fold_left (fun n { suite_tests = l } -> n + List.length l) 0 suites in Printf.printf "Running %d tests for library %S.\n%!" total name; (* Iterate over suites: *) let rec loop_suites failures number suites = match suites with | [] -> if failures = 0 then Printf.printf "\r\027[JDone. All tests succeeded.\n%!" else begin Printf.printf "\r\027[JDone. %d of %d tests failed.\n%!" failures total; exit 1 end | suite :: suites -> loop_tests failures suite.suite_name number suites suite.suite_tests (* Iterate over tests: *) and loop_tests failures suite_name number suites tests = match tests with | [] -> loop_suites failures number suites | test :: tests -> Printf.printf "\r\027[J(%d/%d) Running test %S from suite %S%!" number total test.name suite_name; try if test.run () then loop_tests failures suite_name (number + 1) suites tests else begin Printf.printf "\r\027[J\027[31;1mTest %S from suite %S failed.\027[0m\n%!" test.name suite_name; loop_tests (failures + 1) suite_name (number + 1) suites tests end with exn -> Printf.printf "\r\027[J\027[31;1mTest %S from suite %S failed. It raised: %S.\027[0m\n%!" test.name suite_name (Printexc.to_string exn); loop_tests (failures + 1) suite_name (number + 1) suites tests in loop_suites 0 1 suites lwt-2.4.3/tests/unix/0000755000000000000000000000000012067037505012646 5ustar0000000000000000lwt-2.4.3/tests/unix/test_lwt_io_non_block.ml0000644000000000000000000000365012067037505017564 0ustar0000000000000000(* 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); ] lwt-2.4.3/tests/unix/test_lwt_io.ml0000644000000000000000000000440712067037505015541 0ustar0000000000000000(* 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); ] lwt-2.4.3/tests/unix/main.ml0000644000000000000000000000176312067037505014133 0ustar0000000000000000(* 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; ] lwt-2.4.3/tests/react/0000755000000000000000000000000012067037505012761 5ustar0000000000000000lwt-2.4.3/tests/react/test_lwt_signal.ml0000644000000000000000000000175512067037505016525 0ustar0000000000000000(* 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" [ ] lwt-2.4.3/tests/react/test_lwt_event.ml0000644000000000000000000000445712067037505016373 0ustar0000000000000000(* 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])); ] lwt-2.4.3/tests/react/main.ml0000644000000000000000000000176112067037505014244 0ustar0000000000000000(* 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; ] lwt-2.4.3/tests/preemptive/0000755000000000000000000000000012067037505014043 5ustar0000000000000000lwt-2.4.3/tests/preemptive/test_lwt_preemptive.ml0000644000000000000000000000241112067037505020500 0ustar0000000000000000(* Lightweight thread library for Objective Caml * http://www.ocsigen.org/lwt * Module Test_lwt_io * Copyright (C) 2012 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_preemptive" [ test "run_in_main" (fun () -> let f () = Lwt_preemptive.run_in_main (fun () -> lwt () = Lwt_unix.sleep 0.01 in return 42) in lwt x = Lwt_preemptive.detach f () in return (x = 42)); ] lwt-2.4.3/tests/preemptive/main.ml0000644000000000000000000000174212067037505015325 0ustar0000000000000000(* 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 "preemptive" [ Test_lwt_preemptive.suite; ] lwt-2.4.3/tests/core/0000755000000000000000000000000012067037505012613 5ustar0000000000000000lwt-2.4.3/tests/core/test_lwt_util.ml0000644000000000000000000001324312067037505016052 0ustar0000000000000000(* 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 *) lwt-2.4.3/tests/core/test_lwt_stream.ml0000644000000000000000000002332012067037505016365 0ustar0000000000000000(* 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 x1 = t1 and x2 = t2 and x3 = t3 in return ([x1; x2; x3] = [1; 1; 1])); test "of_list" (fun () -> let stream = Lwt_stream.of_list [1; 2; 3] in lwt x1 = Lwt_stream.next stream in lwt x2 = Lwt_stream.next stream in lwt x3 = Lwt_stream.next stream 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 "create_bounded" (fun () -> let stream, push = Lwt_stream.create_bounded 3 in let acc = true in let acc = acc && state (push#push 1) = Return () in let acc = acc && state (push#push 2) = Return () in let acc = acc && state (push#push 3) = Return () in let t = push#push 4 in let acc = acc && state t = Sleep in let acc = acc && state (push#push 5) = Fail Lwt_stream.Full in let acc = acc && state (push#push 6) = Fail Lwt_stream.Full in let acc = acc && state (Lwt_stream.get stream) = Return (Some 1) in (* Lwt_stream uses wakeup_later so we have to wait a bit. *) lwt () = Lwt_unix.yield () in let acc = acc && state t = Return () in let acc = acc && state (Lwt_stream.get stream) = Return (Some 2) in let acc = acc && state (push#push 7) = Return () in push#close; let acc = acc && state (push#push 8) = Fail Lwt_stream.Closed in let acc = acc && state (Lwt_stream.to_list stream) = Return [3; 4; 7] in return acc); 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)); test "cancel push stream 3" (fun () -> let stream, push = Lwt_stream.create () in let t1 = Lwt_stream.next stream in let t2 = Lwt_stream.next stream in cancel t1; push (Some 1); return (state t1 = Fail Canceled && state t2 = 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); test "map_exn" (fun () -> let open Lwt_stream in let l = [Value 1; Error Exit; Error (Failure "plop"); Value 42; Error End_of_file] in let q = ref l in let stream = Lwt_stream.from (fun () -> match !q with | [] -> return None | Value x :: l -> q := l; return (Some x) | Error e :: l -> q := l; raise_lwt e) in lwt l' = Lwt_stream.to_list (Lwt_stream.map_exn stream) in return (l = l')); test "on_terminate" (fun () -> let st = Lwt_stream.of_list [1; 2] in let b = ref false in Lwt_stream.on_terminate st (fun () -> b := true); ignore (Lwt_stream.peek st); let b1 = !b = false in ignore (Lwt_stream.junk st); ignore (Lwt_stream.peek st); let b2 = !b = false in ignore (Lwt_stream.junk st); ignore (Lwt_stream.peek st); let b3 = !b = true in Lwt.return (b1 && b2 && b3)); ] lwt-2.4.3/tests/core/test_lwt.ml0000644000000000000000000004204012067037505015012 0ustar0000000000000000(* 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; 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 with_async_exception_hook hook f = let save = !Lwt.async_exception_hook in Lwt.async_exception_hook := hook; try let x = f () in Lwt.async_exception_hook := save; x with exn -> Lwt.async_exception_hook := save; raise exn 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_direct "15.1" (fun () -> let exns = ref [] in with_async_exception_hook (fun e -> exns := e :: !exns) (fun () -> let t, w = wait () in ignore_result t; wakeup w (); assert (!exns = []); let t, w = wait () in ignore_result t; wakeup_exn w Exn; assert (!exns = [Exn]); 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 (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_result"); 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)); test "on_cancel race condition" (fun () -> (* Queue of cancel-able pending threads. *) let queue = Lwt_sequence.create () in (* Add two cancel-able pending threads to the queue. *) let waiter1, wakener1 = task () in let node1 = Lwt_sequence.add_r wakener1 queue in let waiter2, wakener2 = task () in let node2 = Lwt_sequence.add_r wakener2 queue in (* Remove nodes when a thread is canceled. *) on_cancel waiter1 (fun () -> Lwt_sequence.remove node1); on_cancel waiter2 (fun () -> Lwt_sequence.remove node2); (* Add another one to the left of the on_cancel one: *) let waiter', wakener' = wait () in let t = bind waiter' (fun _ -> waiter1) in (* Send a value to the first thread of the queue when [t] fails. *) ignore ( try_lwt t with _ -> (* Take the first thread from the queue and send it a value. *) wakeup (Lwt_sequence.take_l queue) 42; return 0 ); (* Terminate [waiter'] so [waiter1 <- Repr t] *) wakeup wakener' 0; (* now there are two thunk functions on [t]: - (fun _ -> wakeup (Lwt_sequence.take_l queue) 42; return 0); - (fun _ -> Lwt_sequence.remove node); *) (* Cancel [waiter1]. If on_cancel handlers are not executed before other thunk functions, [42] is lost. *) cancel waiter1; return (state waiter1 = Fail Canceled && state waiter2 = Return 42)); test "re-cancel" (fun () -> let waiter1, wakener1 = task () in let waiter2, wakener2 = task () in let waiter3, wakener3 = task () in let t1 = catch (fun () -> waiter1) (fun exn -> waiter2) in let t2 = bind t1 return in let t3 = bind waiter3 (fun () -> t1) in wakeup wakener3 (); cancel t3; cancel t2; return (List.for_all (fun t -> state t = Fail Canceled) [t1; t2; t3; waiter1; waiter2])); test "re-cancel choose" (fun () -> let waiter1, wakener1 = task () in let waiter2, wakener2 = task () in let t1 = catch (fun () -> waiter1) (fun exn -> waiter2) in let t2 = choose [t1] in cancel t2; cancel t2; return (state waiter1 = Fail Canceled && state waiter2 = Fail Canceled)); test "ignore_result 2" (fun () -> let exns = ref [] in with_async_exception_hook (fun e -> exns := e :: !exns) (fun () -> let waiter, wakener = wait () in let t1 = map (fun () -> 42) waiter in ignore_result ( lwt () = waiter in fail Exit ); let t2 = map (fun () -> "42") waiter in wakeup wakener (); return (!exns = [Exit] && state t1 = Return 42 && state t2 = Return "42"))); test "on_success exn 2" (fun () -> let exns = ref [] in with_async_exception_hook (fun e -> exns := e :: !exns) (fun () -> let waiter, wakener = wait () in let t1 = map (fun () -> 42) waiter in on_success waiter (fun () -> raise Exit); let t2 = map (fun () -> "42") waiter in wakeup wakener (); return (!exns = [Exit] && state t1 = Return 42 && state t2 = Return "42"))); ] lwt-2.4.3/tests/core/main.ml0000644000000000000000000000200112067037505014062 0ustar0000000000000000(* 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; ] lwt-2.4.3/syntax/0000755000000000000000000000000012067037511012044 5ustar0000000000000000lwt-2.4.3/syntax/optcomp.mllib0000644000000000000000000000013712067037511014547 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 6072e4752c8626fe698fdb6438b61195) Pa_optcomp # OASIS_STOP lwt-2.4.3/syntax/lwt-syntax.mllib0000644000000000000000000000013312067037511015214 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 03396b0b9b2d52e4b95f591f2553b12d) Pa_lwt # OASIS_STOP lwt-2.4.3/syntax/lwt-syntax-options.mllib0000644000000000000000000000014312067037511016706 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: b07bedaca1c4ada7f18a2dee3e3cb6a0) Pa_lwt_options # OASIS_STOP lwt-2.4.3/syntax/lwt-syntax-log.mllib0000644000000000000000000000013712067037511015777 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 3dd8f18825465abee972eb9d78d04827) Pa_lwt_log # OASIS_STOP lwt-2.4.3/syntax/META0000644000000000000000000000056512067037511012523 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: ef0235a50e74a84fe2419ccc2189165a) version = "2.4.3" description = "Lightweight thread library for Objective Caml" requires = "camlp4 camlp4.quotations.o" archive(byte) = "optcomp.cma" archive(byte, plugin) = "optcomp.cma" archive(native) = "optcomp.cmxa" archive(native, plugin) = "optcomp.cmxs" exists_if = "optcomp.cma" # OASIS_STOP lwt-2.4.3/syntax/pa_optcomp.ml0000644000000000000000000005037612067037505014555 0ustar0000000000000000(* * 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 lwt-2.4.3/syntax/pa_lwt_options.ml0000644000000000000000000000230312067037505015440 0ustar0000000000000000(* 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 " lwt-2.4.3/syntax/pa_lwt_log.mli0000644000000000000000000000267512067037505014713 0ustar0000000000000000(* 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. *) lwt-2.4.3/syntax/pa_lwt_log.ml0000644000000000000000000001073212067037505014533 0ustar0000000000000000(* 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 len = String.length func in let fmt = len >= 2 && func.[len - 2] = '_' && func.[len - 1] = 'f' and ign = len >= 4 && func.[0] = 'i' && func.[1] = 'g' && func.[2] = 'n' && func.[3] = '_' in let level = match fmt, ign with | false, false -> func | true, false -> String.sub func 0 (len - 2) | false, true -> String.sub func 4 (len - 4) | true, true -> String.sub func 4 (len - 6) in let level = String.capitalize level in if level = "Debug" && (not !Pa_lwt_options.debug) then `Delete ign else if List.mem level levels then `Log(ign, 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 false -> <:expr< Lwt.return () >> | `Delete true -> <:expr< () >> | `Log(ign, 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 $if ign then <:expr< () >> else <:expr< Lwt.return () >>$ >> | `Log(ign, 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 $if ign then <:expr< () >> else <:expr< Lwt.return () >>$ >> | `Log(ign, 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 $if ign then <:expr< () >> else <:expr< 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; lwt-2.4.3/syntax/pa_lwt.mli0000644000000000000000000000673312067037505014051 0ustar0000000000000000(* 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 | -> ... | -> ]} *) lwt-2.4.3/syntax/pa_lwt.ml0000644000000000000000000002133112067037505013667 0ustar0000000000000000(* 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 lwt-2.4.3/src/0000755000000000000000000000000012067037505011310 5ustar0000000000000000lwt-2.4.3/src/unix/0000755000000000000000000000000012067037511012270 5ustar0000000000000000lwt-2.4.3/src/unix/lwt-unix.mllib0000644000000000000000000000037012067037511015100 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: a6ff6a3a8dd32ba523a899be91d5d145) 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 Lwt_unix_jobs_generated # OASIS_STOP lwt-2.4.3/src/unix/liblwt-unix_stubs.clib0000644000000000000000000000162112067037511016621 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 810db210723744b64cf412cd5a8ef063) lwt_unix_stubs.o lwt_libev_stubs.o lwt_process_stubs.o jobs-unix/lwt_unix_job_access.o jobs-unix/lwt_unix_job_chdir.o jobs-unix/lwt_unix_job_chmod.o jobs-unix/lwt_unix_job_chown.o jobs-unix/lwt_unix_job_chroot.o jobs-unix/lwt_unix_job_close.o jobs-unix/lwt_unix_job_fchmod.o jobs-unix/lwt_unix_job_fchown.o jobs-unix/lwt_unix_job_fdatasync.o jobs-unix/lwt_unix_job_fsync.o jobs-unix/lwt_unix_job_ftruncate.o jobs-unix/lwt_unix_job_link.o jobs-unix/lwt_unix_job_lseek.o jobs-unix/lwt_unix_job_mkdir.o jobs-unix/lwt_unix_job_mkfifo.o jobs-unix/lwt_unix_job_rename.o jobs-unix/lwt_unix_job_rmdir.o jobs-unix/lwt_unix_job_symlink.o jobs-unix/lwt_unix_job_tcdrain.o jobs-unix/lwt_unix_job_tcflow.o jobs-unix/lwt_unix_job_tcflush.o jobs-unix/lwt_unix_job_tcsendbreak.o jobs-unix/lwt_unix_job_truncate.o jobs-unix/lwt_unix_job_unlink.o # OASIS_STOP lwt-2.4.3/src/unix/lwt_unix_windows.c0000644000000000000000000003346412067037505016074 0ustar0000000000000000/* 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; DWORD length; DWORD result; DWORD error_code; value string; DWORD offset; char buffer[]; }; 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(); } } static value result_read(struct job_read *job) { value result; DWORD error = job->error_code; if (error) { caml_remove_generational_global_root(&job->string); lwt_unix_free_job(&job->job); win32_maperr(error); uerror("read", Nothing); } memcpy(String_val(job->string) + job->offset, job->buffer, job->result); result = Val_long(job->result); caml_remove_generational_global_root(&job->string); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_read_job(value val_fd, value val_string, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, read, length); job->kind = fd->kind; if (fd->kind == KIND_HANDLE) job->fd.handle = fd->fd.handle; else job->fd.socket = fd->fd.socket; job->length = length; job->error_code = 0; job->string = val_string; job->offset = Long_val(val_offset); caml_register_generational_global_root(&(job->string)); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | 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; }; 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(); } } static value result_bytes_read(struct job_bytes_read *job) { value result; DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("bytes_read", Nothing); } result = Val_long(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buffer, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); LWT_UNIX_INIT_JOB(job, bytes_read, 0); 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 = Long_val(val_length); job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: write | +-----------------------------------------------------------------+ */ struct job_write { struct lwt_unix_job job; union { HANDLE handle; SOCKET socket; } fd; int kind; DWORD length; DWORD result; DWORD error_code; char buffer[]; }; 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(); } } static value result_write(struct job_write *job) { value result; DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("write", Nothing); } result = Val_long(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, write, length); job->kind = fd->kind; if (fd->kind == KIND_HANDLE) job->fd.handle = fd->fd.handle; else job->fd.socket = fd->fd.socket; 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)); } /* +-----------------------------------------------------------------+ | 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; }; 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 result_bytes_write(struct job_bytes_write *job) { value result; DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("bytes_write", Nothing); } result = Val_long(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); LWT_UNIX_INIT_JOB(job, bytes_write, 0); 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 = Long_val(val_length); job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: fsync | +-----------------------------------------------------------------+ */ struct job_fsync { struct lwt_unix_job job; HANDLE handle; DWORD error_code; }; static void worker_fsync(struct job_fsync *job) { if (!FlushFileBuffers(job->handle)) job->error_code = GetLastError(); } static value result_fsync(struct job_fsync *job) { DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("fsync", Nothing); } lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_fsync_job(value val_fd) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); if (fd->kind != KIND_HANDLE) { caml_invalid_argument("Lwt_unix.fsync"); } else { LWT_UNIX_INIT_JOB(job, fsync, 0); job->handle = fd->fd.handle; job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } } /* +-----------------------------------------------------------------+ | JOB: system | +-----------------------------------------------------------------+ */ struct job_system { struct lwt_unix_job job; HANDLE handle; }; static void worker_system(struct job_system *job) { WaitForSingleObject(job->handle, INFINITE); } static value result_system(struct job_system *job) { HANDLE handle = job->handle; DWORD code; DWORD err; lwt_unix_free_job(&job->job); if (!GetExitCodeProcess(handle, &code)) { err = GetLastError(); CloseHandle(handle); win32_maperr(err); uerror("GetExitCodeProcess", Nothing); } CloseHandle(handle); return Val_int(code); } CAMLprim value lwt_unix_system_job(value cmdline) { STARTUPINFO si; PROCESS_INFORMATION pi; ZeroMemory(&si, sizeof(si)); ZeroMemory(&pi, sizeof(pi)); si.cb = sizeof(si); if (!CreateProcess(NULL, String_val(cmdline), NULL, NULL, TRUE, 0, NULL, NULL, &si, &pi)) { win32_maperr(GetLastError()); uerror("CreateProcess", Nothing); } else { LWT_UNIX_INIT_JOB(job, system, 0); CloseHandle(pi.hThread); job->handle = pi.hProcess; return lwt_unix_alloc_job(&(job->job)); } } lwt-2.4.3/src/unix/lwt_unix_unix.c0000644000000000000000000021644012067037505015362 0ustar0000000000000000/* 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. */ #define ARGS(args...) args #include #include #include #include #include #include /* +-----------------------------------------------------------------+ | Test for readability/writability | +-----------------------------------------------------------------+ */ 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) { long 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_long(ret); } CAMLprim value lwt_unix_bytes_read(value val_fd, value val_buf, value val_ofs, value val_len) { long 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_long(ret); } CAMLprim value lwt_unix_write(value val_fd, value val_buf, value val_ofs, value val_len) { long 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_long(ret); } CAMLprim value lwt_unix_bytes_write(value val_fd, value val_buf, value val_ofs, value val_len) { long 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_long(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_LINUX) # define CREDENTIALS_TYPE struct ucred # define CREDENTIALS_FIELD(id) id #elif defined(HAVE_GET_CREDENTIALS_NETBSD) # define CREDENTIALS_TYPE struct sockcred # define CREDENTIALS_FIELD(id) sc_ ## id #elif defined(HAVE_GET_CREDENTIALS_OPENBSD) # define CREDENTIALS_TYPE struct sockpeercred # define CREDENTIALS_FIELD(id) id #elif defined(HAVE_GET_CREDENTIALS_FREEBSD) # define CREDENTIALS_TYPE struct cmsgcred # define CREDENTIALS_FIELD(id) cmsgcred_ ## id #endif #if defined(CREDENTIALS_TYPE) CAMLprim value lwt_unix_get_credentials(value fd) { CAMLparam1(fd); CAMLlocal1(res); CREDENTIALS_TYPE 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.CREDENTIALS_FIELD(pid))); Store_field(res, 1, Val_int(cred.CREDENTIALS_FIELD(uid))); Store_field(res, 2, Val_int(cred.CREDENTIALS_FIELD(gid))); CAMLreturn(res); } #elif defined(HAVE_GETPEEREID) CAMLprim value lwt_unix_get_credentials(value fd) { CAMLparam1(fd); CAMLlocal1(res); uid_t euid; gid_t egid; if (getpeereid(Int_val(fd), &euid, &egid) == -1) uerror("get_credentials", Nothing); res = caml_alloc_tuple(3); Store_field(res, 0, Val_int(-1)); Store_field(res, 1, Val_int(euid)); Store_field(res, 2, Val_int(egid)); CAMLreturn(res); } #endif /* +-----------------------------------------------------------------+ | wait4 | +-----------------------------------------------------------------+ */ /* Some code duplicated from OCaml's otherlibs/unix/wait.c */ 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; }; 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; } static value result_guess_blocking(struct job_guess_blocking *job) { value result = Val_bool(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_guess_blocking_job(value val_fd) { LWT_UNIX_INIT_JOB(job, guess_blocking, 0); job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: wait_mincore | +-----------------------------------------------------------------+ */ struct job_wait_mincore { struct lwt_unix_job job; char *ptr; }; 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); } static value result_wait_mincore(struct job_wait_mincore *job) { lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_wait_mincore_job(value val_buffer, value val_offset) { LWT_UNIX_INIT_JOB(job, wait_mincore, 0); job->ptr = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | 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, 0 }; struct job_open { struct lwt_unix_job job; int flags; int perms; int fd; int blocking; int error_code; char *name; char data[]; }; static void worker_open(struct job_open *job) { int fd; fd = open(job->name, 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)); } } static value result_open(struct job_open *job) { int fd = job->fd; LWT_UNIX_CHECK_JOB_ARG(job, fd < 0, "open", job->name); value result = caml_alloc_tuple(2); Field(result, 0) = Val_int(fd); Field(result, 1) = Val_bool(job->blocking); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_open_job(value name, value flags, value perms) { LWT_UNIX_INIT_JOB_STRING(job, open, 0, name); job->flags = convert_flag_list(flags, open_flag_table); job->perms = Int_val(perms); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: read | +-----------------------------------------------------------------+ */ struct job_read { struct lwt_unix_job job; /* The file descriptor. */ int fd; /* The amount of data to read. */ long length; /* The OCaml string. */ value string; /* The offset in the string. */ long offset; /* The result of the read syscall. */ long result; /* The value of errno. */ int error_code; /* The temporary buffer. */ char buffer[]; }; static void worker_read(struct job_read *job) { job->result = read(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_read(struct job_read *job) { long result = job->result; if (result < 0) { int error_code = job->error_code; caml_remove_generational_global_root(&(job->string)); lwt_unix_free_job(&job->job); unix_error(error_code, "read", Nothing); } else { memcpy(String_val(job->string) + job->offset, job->buffer, result); caml_remove_generational_global_root(&(job->string)); lwt_unix_free_job(&job->job); return Val_long(result); } } CAMLprim value lwt_unix_read_job(value val_fd, value val_buffer, value val_offset, value val_length) { long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, read, length); job->fd = Int_val(val_fd); job->length = length; job->string = val_buffer; job->offset = Long_val(val_offset); caml_register_generational_global_root(&(job->string)); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: bytes_read | +-----------------------------------------------------------------+ */ struct job_bytes_read { struct lwt_unix_job job; /* The file descriptor. */ int fd; /* The destination buffer. */ char *buffer; /* The offset in the string. */ long offset; /* The amount of data to read. */ long length; /* The result of the read syscall. */ long result; /* The value of errno. */ int error_code; }; static void worker_bytes_read(struct job_bytes_read *job) { job->result = read(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_bytes_read(struct job_bytes_read *job) { long result = job->result; LWT_UNIX_CHECK_JOB(job, result < 0, "read"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buf, value val_ofs, value val_len) { LWT_UNIX_INIT_JOB(job, bytes_read, 0); 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)); } /* +-----------------------------------------------------------------+ | JOB: write | +-----------------------------------------------------------------+ */ struct job_write { struct lwt_unix_job job; int fd; long length; long result; int error_code; char buffer[]; }; static void worker_write(struct job_write *job) { job->result = write(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_write(struct job_write *job) { long result = job->result; LWT_UNIX_CHECK_JOB(job, result < 0, "write"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length) { long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, write, length); job->fd = Int_val(val_fd); job->length = length; memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: bytes_write | +-----------------------------------------------------------------+ */ struct job_bytes_write { struct lwt_unix_job job; int fd; char *buffer; long length; long result; int error_code; }; static void worker_bytes_write(struct job_bytes_write *job) { job->result = write(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_bytes_write(struct job_bytes_write *job) { long result = job->result; LWT_UNIX_CHECK_JOB(job, result < 0, "write"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length) { LWT_UNIX_INIT_JOB(job, bytes_write, 0); 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)); } /* +-----------------------------------------------------------------+ | JOB: stat | +-----------------------------------------------------------------+ */ struct job_stat { struct lwt_unix_job job; struct stat stat; int result; int error_code; char *name; char data[]; }; 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; } static value result_stat(struct job_stat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "stat", job->name); value result = copy_stat(0, &job->stat); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_stat_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, stat, 0, name); return lwt_unix_alloc_job(&(job->job)); } static value result_stat_64(struct job_stat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "stat", job->name); value result = copy_stat(1, &job->stat); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_stat_64_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, stat, 0, name); job->job.result = (lwt_unix_job_result)result_stat_64; return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: lstat | +-----------------------------------------------------------------+ */ struct job_lstat { struct lwt_unix_job job; struct stat lstat; int result; int error_code; char *name; char data[]; }; static void worker_lstat(struct job_lstat *job) { job->result = lstat(job->name, &job->lstat); job->error_code = errno; } static value result_lstat(struct job_lstat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "lstat", job->name); value result = copy_stat(0, &(job->lstat)); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_lstat_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, lstat, 0, name); return lwt_unix_alloc_job(&(job->job)); } static value result_lstat_64(struct job_lstat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "lstat", job->name); value result = copy_stat(1, &(job->lstat)); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_lstat_64_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, lstat, 0, name); job->job.result = (lwt_unix_job_result)result_lstat_64; return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: fstat | +-----------------------------------------------------------------+ */ struct job_fstat { struct lwt_unix_job job; int fd; struct stat fstat; int result; int error_code; }; static void worker_fstat(struct job_fstat *job) { job->result = fstat(job->fd, &(job->fstat)); job->error_code = errno; } static value result_fstat(struct job_fstat *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "fstat"); value result = copy_stat(0, &(job->fstat)); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_fstat_job(value val_fd) { LWT_UNIX_INIT_JOB(job, fstat, 0); job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } static value result_fstat_64(struct job_fstat *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "fstat"); value result = copy_stat(1, &(job->fstat)); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_fstat_64_job(value val_fd) { LWT_UNIX_INIT_JOB(job, fstat, 0); job->job.result = (lwt_unix_job_result)result_fstat_64; job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: isatty | +-----------------------------------------------------------------+ */ struct job_isatty { struct lwt_unix_job job; int fd; int result; }; static void worker_isatty(struct job_isatty *job) { job->result = isatty(job->fd); } static value result_isatty(struct job_isatty *job) { value result = Val_bool(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_isatty_job(value val_fd) { LWT_UNIX_INIT_JOB(job, isatty, 0); job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: opendir | +-----------------------------------------------------------------+ */ struct job_opendir { struct lwt_unix_job job; DIR* result; int error_code; char* path; char data[]; }; static void worker_opendir(struct job_opendir* job) { job->result = opendir(job->path); job->error_code = errno; } static value result_opendir(struct job_opendir* job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result == NULL, "opendir", job->path); value result = caml_alloc_small(1, Abstract_tag); DIR_Val(result) = job->result; lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_opendir_job(value path) { LWT_UNIX_INIT_JOB_STRING(job, opendir, 0, path); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: closedir | +-----------------------------------------------------------------+ */ struct job_closedir { struct lwt_unix_job job; int result; int error_code; DIR* dir; }; static void worker_closedir(struct job_closedir* job) { job->result = closedir(job->dir); job->error_code = errno; } static value result_closedir(struct job_closedir* job) { LWT_UNIX_CHECK_JOB(job, job->dir < 0, "closedir"); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_closedir_job(value dir) { LWT_UNIX_INIT_JOB(job, closedir, 0); job->dir = DIR_Val(dir); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: rewinddir | +-----------------------------------------------------------------+ */ struct job_rewinddir { struct lwt_unix_job job; DIR* dir; }; static void worker_rewinddir(struct job_rewinddir *job) { rewinddir(job->dir); } static value result_rewinddir(struct job_rewinddir *job) { lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_rewinddir_job(value dir) { LWT_UNIX_INIT_JOB(job, rewinddir, 0); job->dir = DIR_Val(dir); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: readdir | +-----------------------------------------------------------------+ */ struct job_readdir { struct lwt_unix_job job; DIR *dir; struct dirent *entry; struct dirent *ptr; int result; }; 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); } static value result_readdir(struct job_readdir *job) { int result = job->result; if (result) { free(job->entry); lwt_unix_free_job(&job->job); unix_error(result, "readdir", Nothing); } else if (job->ptr == NULL) { free(job->entry); lwt_unix_free_job(&job->job); caml_raise_end_of_file(); } else { value name = caml_copy_string(job->entry->d_name); free(job->entry); lwt_unix_free_job(&job->job); return name; } } CAMLprim value lwt_unix_readdir_job(value val_dir) { LWT_UNIX_INIT_JOB(job, readdir, 0); job->dir = DIR_Val(val_dir); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: readdir_n | +-----------------------------------------------------------------+ */ struct job_readdir_n { struct lwt_unix_job job; DIR *dir; long count; int error_code; struct dirent *entries[]; }; 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; long 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); long 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; } static value result_readdir_n(struct job_readdir_n *job) { CAMLparam0(); CAMLlocal1(result); int error_code = job->error_code; if (error_code) { lwt_unix_free_job(&job->job); unix_error(error_code, "readdir", Nothing); } else { result = caml_alloc(job->count, 0); long i; for(i = 0; i < job->count; i++) { Store_field(result, i, caml_copy_string(job->entries[i]->d_name)); free(job->entries[i]); } CAMLreturn(result); } } CAMLprim value lwt_unix_readdir_n_job(value val_dir, value val_count) { long count = Long_val(val_count); LWT_UNIX_INIT_JOB(job, readdir_n, sizeof(struct dirent*) * count); job->dir = DIR_Val(val_dir); job->count = count; return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: readlink | +-----------------------------------------------------------------+ */ struct job_readlink { struct lwt_unix_job job; char *buffer; ssize_t result; int error_code; char *name; char data[]; }; 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 + 1); link_length = readlink(job->name, job->buffer, buffer_size); if (link_length < 0) { free(job->buffer); job->result = -1; job->error_code = errno; return; } if (link_length < buffer_size) { job->buffer[link_length] = 0; job->result = link_length; return; } else { free(job->buffer); buffer_size *= 2; } } } static value result_readlink(struct job_readlink *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "readlink", job->name); value result = caml_copy_string(job->buffer); free(&job->buffer); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_readlink_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, readlink, 0, name); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: lockf | +-----------------------------------------------------------------+ */ struct job_lockf { struct lwt_unix_job job; int fd; int command; long length; int result; int error_code; }; #if defined(F_GETLK) && defined(F_SETLK) && defined(F_SETLKW) static void worker_lockf(struct job_lockf *job) { struct flock l; l.l_whence = 1; if (job->length < 0) { l.l_start = job->length; l.l_len = -job->length; } else { l.l_start = 0L; l.l_len = job->length; } switch (job->command) { case 0: /* F_ULOCK */ l.l_type = F_UNLCK; job->result = fcntl(job->fd, F_SETLK, &l); job->error_code = errno; break; case 1: /* F_LOCK */ l.l_type = F_WRLCK; job->result = fcntl(job->fd, F_SETLKW, &l); job->error_code = errno; break; case 2: /* F_TLOCK */ l.l_type = F_WRLCK; job->result = fcntl(job->fd, F_SETLK, &l); job->error_code = errno; break; case 3: /* F_TEST */ l.l_type = F_WRLCK; job->result = fcntl(job->fd, F_GETLK, &l); if (job->result != -1) { if (l.l_type == F_UNLCK) { job->result = 0; } else { job->result = -1; job->error_code = EACCES; } } break; case 4: /* F_RLOCK */ l.l_type = F_RDLCK; job->result = fcntl(job->fd, F_SETLKW, &l); job->error_code = errno; break; case 5: /* F_TRLOCK */ l.l_type = F_RDLCK; job->result = fcntl(job->fd, F_SETLK, &l); job->error_code = errno; break; default: job->result = -1; job->error_code = EINVAL; } } #else 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, lock_command_table[job->command], job->length); job->error_code = errno; } #endif static value result_lockf(struct job_lockf *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "lockf"); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_lockf_job(value val_fd, value val_command, value val_length) { LWT_UNIX_INIT_JOB(job, lockf, 0); job->fd = Int_val(val_fd); job->command = Int_val(val_command); job->length = Long_val(val_length); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: getlogin | +-----------------------------------------------------------------+ */ struct job_getlogin { struct lwt_unix_job job; char buffer[1024]; int result; }; static void worker_getlogin(struct job_getlogin *job) { job->result = getlogin_r(job->buffer, 1024); } static value result_getlogin(struct job_getlogin *job) { int result = job->result; if (result) { lwt_unix_free_job(&job->job); unix_error(result, "getlogin", Nothing); } else { value v = caml_copy_string(job->buffer); lwt_unix_free_job(&job->job); return v; } } CAMLprim value lwt_unix_getlogin_job() { LWT_UNIX_INIT_JOB(job, getlogin, 0); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOBs: get{pw,gr}{nam,uid} | +-----------------------------------------------------------------+ */ 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 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; } #define JOB_GET_ENTRY(INIT, FUNC, CONF, TYPE, ARG, ARG_DECL, FAIL_ARG) \ struct job_##FUNC { \ struct lwt_unix_job job; \ struct TYPE entry; \ struct TYPE *ptr; \ char *buffer; \ int result; \ ARG_DECL; \ }; \ \ static void worker_##FUNC(struct job_##FUNC *job) \ { \ size_t buffer_size = sysconf(_SC_##CONF##_R_SIZE_MAX); \ if (buffer_size == (size_t) -1) buffer_size = 16384; \ job->buffer = (char*)lwt_unix_malloc(buffer_size); \ job->result = FUNC##_r(job->ARG, &job->entry, job->buffer, buffer_size, &job->ptr); \ } \ \ static value result_##FUNC(struct job_##FUNC *job) \ { \ int result = job->result; \ if (result) { \ value arg = FAIL_ARG; \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ unix_error(result, #FUNC, arg); \ } else if (job->ptr == NULL) { \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ caml_raise_not_found(); \ } else { \ value entry = alloc_##TYPE##_entry(&job->entry); \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ return entry; \ } \ } \ \ CAMLprim value lwt_unix_##FUNC##_job(value ARG) \ { \ INIT; \ return lwt_unix_alloc_job(&job->job); \ } JOB_GET_ENTRY(LWT_UNIX_INIT_JOB_STRING(job, getpwnam, 0, name), getpwnam, GETPW, passwd, name, char *name; char data[], caml_copy_string(job->name)) JOB_GET_ENTRY(LWT_UNIX_INIT_JOB_STRING(job, getgrnam, 0, name), getgrnam, GETGR, group, name, char *name; char data[], caml_copy_string(job->name)) JOB_GET_ENTRY(LWT_UNIX_INIT_JOB(job, getpwuid, 0); job->uid = Int_val(uid), getpwuid, GETPW, passwd, uid, int uid, Nothing) JOB_GET_ENTRY(LWT_UNIX_INIT_JOB(job, getgrgid, 0); job->gid = Int_val(gid), getgrgid, GETGR, group, gid, int gid, Nothing) /* +-----------------------------------------------------------------+ | JOB: gethostname | +-----------------------------------------------------------------+ */ struct job_gethostname { struct lwt_unix_job job; char *buffer; int result; int error_code; }; 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 if (err == -1) { free(job->buffer); job->result = -1; job->error_code = errno; return; } else { job->buffer[buffer_size] = 0; job->result = 0; return; } } } static value result_gethostname(struct job_gethostname *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "gethostname"); value result = caml_copy_string(job->buffer); free(job->buffer); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_gethostname_job() { LWT_UNIX_INIT_JOB(job, gethostname, 0); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: gethostbyname | +-----------------------------------------------------------------+ */ #define NETDB_BUFFER_SIZE 10000 struct job_gethostbyname { struct lwt_unix_job job; struct hostent entry; struct hostent *ptr; char buffer[NETDB_BUFFER_SIZE]; char *name; char data[]; }; 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 } static value result_gethostbyname(struct job_gethostbyname *job) { if (job->ptr == NULL) { lwt_unix_free_job(&job->job); caml_raise_not_found(); } else { value entry = alloc_host_entry(&job->entry); lwt_unix_free_job(&job->job); return entry; } } CAMLprim value lwt_unix_gethostbyname_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, gethostbyname, 0, name); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | 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]; }; 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 } static value result_gethostbyaddr(struct job_gethostbyaddr *job) { if (job->ptr == NULL) { lwt_unix_free_job(&job->job); caml_raise_not_found(); } else { value entry = alloc_host_entry(&job->entry); lwt_unix_free_job(&job->job); return entry; } } CAMLprim value lwt_unix_gethostbyaddr_job(value val_addr) { LWT_UNIX_INIT_JOB(job, gethostbyaddr, 0); job->addr = GET_INET_ADDR(val_addr); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOBs: getprotoby{name,number}, getservby{name,port} | +-----------------------------------------------------------------+ */ static value alloc_protoent(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 value alloc_servent(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; } #if defined(HAVE_NETDB_REENTRANT) #define JOB_GET_ENTRY2(INIT, FUNC, TYPE, ARGS_VAL, ARGS_DECL, ARGS_CALL) \ struct job_##FUNC { \ struct lwt_unix_job job; \ struct TYPE entry; \ struct TYPE *ptr; \ char *buffer; \ ARGS_DECL; \ }; \ \ static void worker_##FUNC(struct job_##FUNC *job) \ { \ size_t size = 1024; \ for (;;) { \ job->buffer = (char*)lwt_unix_malloc(size); \ \ int result = FUNC##_r(ARGS_CALL, &job->entry, job->buffer, size, &job->ptr); \ \ switch (result) { \ case 0: \ return; \ case ERANGE: \ free(job->buffer); \ size += 1024; \ break; \ case ENOENT: \ default: \ free(job->buffer); \ job->ptr = NULL; \ return; \ } \ } \ } \ \ static value result_##FUNC(struct job_##FUNC *job) \ { \ if (job->ptr == NULL) { \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ caml_raise_not_found(); \ } else { \ value res = alloc_##TYPE(&job->entry); \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ return res; \ } \ } \ \ CAMLprim value lwt_unix_##FUNC##_job(ARGS_VAL) \ { \ INIT; \ return lwt_unix_alloc_job(&(job->job)); \ } #else /* defined(HAVE_NETDB_REENTRANT) */ #define JOB_GET_ENTRY2(INIT, FUNC, TYPE, ARGS_VAL, ARGS_DECL, ARGS_CALL) \ struct job_##FUNC { \ struct lwt_unix_job job; \ struct TYPE *entry; \ ARGS_DECL; \ }; \ \ static void worker_##FUNC(struct job_##FUNC *job) \ { \ job->entry = FUNC(ARGS_CALL); \ } \ \ static value result_##FUNC(struct job_##FUNC *job) \ { \ if (job->entry == NULL) { \ lwt_unix_free_job(&job->job); \ caml_raise_not_found(); \ } else { \ value res = alloc_##TYPE(job->entry); \ lwt_unix_free_job(&job->job); \ return res; \ } \ } \ \ CAMLprim value lwt_unix_##FUNC##_job(ARGS_VAL) \ { \ INIT; \ return lwt_unix_alloc_job(&(job->job)); \ } #endif /* defined(HAVE_NETDB_REENTRANT) */ JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB_STRING(job, getprotobyname, 0, name), getprotobyname, protoent, value name, char *name; char data[], job->name) JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB(job, getprotobynumber, 0); job->num = Int_val(num), getprotobynumber, protoent, value num, int num, job->num) JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB_STRING2(job, getservbyname, 0, name, proto), getservbyname, servent, ARGS(value name, value proto), char *name; char *proto; char data[], ARGS(job->name, job->proto)) JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB_STRING(job, getservbyport, 0, proto); job->port = Int_val(port), getservbyport, servent, ARGS(value port, value proto), int port; char *proto; char data[], ARGS(job->port, job->proto)) /* +-----------------------------------------------------------------+ | JOB: getaddrinfo | +-----------------------------------------------------------------+ */ struct job_getaddrinfo { struct lwt_unix_job job; char *node; char *service; struct addrinfo hints; struct addrinfo *info; int result; char data[]; }; 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[0]?job->node:NULL, job->service[0]?job->service:NULL, &job->hints, &job->info); } static value result_getaddrinfo(struct job_getaddrinfo *job) { CAMLparam0(); CAMLlocal3(vres, e, v); vres = Val_int(0); if (job->result == 0) { struct addrinfo *r; for (r = job->info; r; r = r->ai_next) { e = convert_addrinfo(r); v = caml_alloc_small(2, 0); Field(v, 0) = e; Field(v, 1) = vres; vres = v; } } freeaddrinfo(job->info); lwt_unix_free_job(&job->job); CAMLreturn(vres); } CAMLprim value lwt_unix_getaddrinfo_job(value node, value service, value hints) { LWT_UNIX_INIT_JOB_STRING2(job, getaddrinfo, 0, node, service); job->info = NULL; memset(&job->hints, 0, sizeof(struct addrinfo)); job->hints.ai_family = PF_UNSPEC; for (/*nothing*/; Is_block(hints); hints = Field(hints, 1)) { value v = Field(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); } /* +-----------------------------------------------------------------+ | 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]; int result; }; 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); } static value result_getnameinfo(struct job_getnameinfo *job) { CAMLparam0(); CAMLlocal3(vres, vhost, vserv); if (job->result) { lwt_unix_free_job(&job->job); caml_raise_not_found(); } else { vhost = caml_copy_string(job->host); vserv = caml_copy_string(job->serv); vres = caml_alloc_small(2, 0); Field(vres, 0) = vhost; Field(vres, 1) = vserv; CAMLreturn(vres); } } CAMLprim value lwt_unix_getnameinfo_job(value sockaddr, value opts) { LWT_UNIX_INIT_JOB(job, getnameinfo, 0); get_sockaddr(sockaddr, &job->addr, &job->addr_len); job->opts = convert_flag_list(opts, getnameinfo_flag_table); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | Termios conversion | +-----------------------------------------------------------------+ */ /* TODO: make it reentrant. */ enum { Bool, Enum, Speed, Char, End }; enum { Input, Output }; enum { Iflags, Oflags, Cflags, Lflags }; /* 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 }; 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 tcflag_t* choose_field(struct termios *terminal_status, long field) { switch (field) { case Iflags: return &terminal_status->c_iflag; case Oflags: return &terminal_status->c_oflag; case Cflags: return &terminal_status->c_cflag; case Lflags: return &terminal_status->c_lflag; default: return 0; } } static void encode_terminal_status(struct termios* terminal_status, value *dst) { long * pc; int i; for(pc = terminal_io_descr; *pc != End; dst++) { switch(*pc++) { case Bool: { tcflag_t * src = choose_field(terminal_status, *pc++); tcflag_t msk = *pc++; *dst = Val_bool(*src & msk); break; } case Enum: { tcflag_t * src = choose_field(terminal_status, *pc++); int ofs = *pc++; int num = *pc++; tcflag_t 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(struct termios* terminal_status, value* src) { long * pc; int i; for (pc = terminal_io_descr; *pc != End; src++) { switch(*pc++) { case Bool: { tcflag_t * dst = choose_field(terminal_status, *pc++); tcflag_t msk = *pc++; if (Bool_val(*src)) *dst |= msk; else *dst &= ~msk; break; } case Enum: { tcflag_t * dst = choose_field(terminal_status, *pc++); int ofs = *pc++; int num = *pc++; tcflag_t 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; }; static void worker_tcgetattr(struct job_tcgetattr *job) { job->result = tcgetattr(job->fd, &job->termios); job->error_code = errno; } static value result_tcgetattr(struct job_tcgetattr *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "tcgetattr"); value res = caml_alloc_tuple(NFIELDS); encode_terminal_status(&job->termios, &Field(res, 0)); lwt_unix_free_job(&job->job); return res; } CAMLprim value lwt_unix_tcgetattr_job(value fd) { LWT_UNIX_INIT_JOB(job, tcgetattr, 0); job->fd = Int_val(fd); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: tcsetattr | +-----------------------------------------------------------------+ */ struct job_tcsetattr { struct lwt_unix_job job; int fd; int when; /* This array contains only non-allocated values. */ value termios[NFIELDS]; int result; int error_code; }; static int when_flag_table[] = { TCSANOW, TCSADRAIN, TCSAFLUSH }; static void worker_tcsetattr(struct job_tcsetattr *job) { struct termios termios; int result = tcgetattr(job->fd, &termios); if (result < 0) { job->result = result; job->error_code = errno; } else { decode_terminal_status(&termios, &(job->termios[0])); job->result = tcsetattr(job->fd, job->when, &termios); job->error_code = errno; } } static value result_tcsetattr(struct job_tcsetattr *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "tcsetattr"); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_tcsetattr_job(value fd, value when, value termios) { LWT_UNIX_INIT_JOB(job, tcsetattr, 0); job->fd = Int_val(fd); job->when = when_flag_table[Int_val(when)]; memcpy(&job->termios, &Field(termios, 0), NFIELDS * sizeof(value)); return lwt_unix_alloc_job(&job->job); } lwt-2.4.3/src/unix/lwt_unix_stubs.c0000644000000000000000000011777512067037505015552 0ustar0000000000000000/* 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. */ #include "lwt_config.h" #if defined(LWT_ON_WINDOWS) # include # include #endif #define _GNU_SOURCE #define _POSIX_PTHREAD_SEMANTICS #include #include #include #include #include #include #include #include #include #include #include #include #include #if !defined(LWT_ON_WINDOWS) && defined(SIGRTMIN) && defined(SIGRTMAX) #define LWT_UNIX_SIGNAL_ASYNC_SWITCH SIGRTMIN #define LWT_UNIX_HAVE_ASYNC_SWITCH #include #else #endif #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 #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; } void *lwt_unix_realloc(void *ptr, size_t size) { void *new_ptr = realloc(ptr, size); if (new_ptr == NULL) { perror("cannot allocate memory"); abort(); } return new_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(HAVE_PTHREAD) 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); } #elif 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) { 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); /* The event is no more used. */ CloseHandle(node.event); /* Re-acquire the mutex. */ EnterCriticalSection(mutex); } #else # error "no threading library available!" #endif /* +-----------------------------------------------------------------+ | Socketpair on windows | +-----------------------------------------------------------------+ */ #if defined(LWT_ON_WINDOWS) static void lwt_unix_socketpair(int domain, int type, int protocol, SOCKET sockets[2]) { union { struct sockaddr_in inaddr; struct sockaddr addr; } a; SOCKET listener; int addrlen = sizeof(a.inaddr); int reuse = 1; DWORD err; sockets[0] = INVALID_SOCKET; sockets[1] = INVALID_SOCKET; listener = socket(domain, type, protocol); if (listener == INVALID_SOCKET) goto failure; memset(&a, 0, sizeof(a)); a.inaddr.sin_family = domain; 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; sockets[0] = socket(domain, type, protocol); if (sockets[0] == INVALID_SOCKET) goto failure; if (connect(sockets[0], &a.addr, sizeof(a.inaddr)) == SOCKET_ERROR) goto failure; sockets[1] = accept(listener, NULL, NULL); if (sockets[1] == INVALID_SOCKET) goto failure; closesocket(listener); return; failure: err = WSAGetLastError(); closesocket(listener); closesocket(sockets[0]); closesocket(sockets[1]); win32_maperr(err); uerror("socketpair", Nothing); } static int socket_domain_table[] = { PF_UNIX, PF_INET }; static int socket_type_table[] = { SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET }; CAMLprim value lwt_unix_socketpair_stub(value domain, value type, value protocol) { CAMLparam3(domain, type, protocol); CAMLlocal1(result); SOCKET sockets[2]; lwt_unix_socketpair(socket_domain_table[Int_val(domain)], socket_type_table[Int_val(type)], Int_val(protocol), sockets); result = caml_alloc_tuple(2); Store_field(result, 0, win_alloc_socket(sockets[0])); Store_field(result, 1, win_alloc_socket(sockets[1])); CAMLreturn(result); } #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; #if !defined(LWT_ON_WINDOWS) sigset_t new_mask; sigset_t old_mask; int error; sigfillset(&new_mask); pthread_sigmask(SIG_SETMASK, &new_mask, &old_mask); #else DWORD error; #endif 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; ret = notification_send(); #if defined(LWT_ON_WINDOWS) if (ret == SOCKET_ERROR) { error = WSAGetLastError(); lwt_unix_mutex_unlock(¬ification_mutex); win32_maperr(error); uerror("send_notification", Nothing); } #else if (ret < 0) { error = errno; lwt_unix_mutex_unlock(¬ification_mutex); pthread_sigmask(SIG_SETMASK, &old_mask, NULL); unix_error(error, "send_notification", Nothing); } #endif } lwt_unix_mutex_unlock(¬ification_mutex); #if !defined(LWT_ON_WINDOWS) pthread_sigmask(SIG_SETMASK, &old_mask, NULL); #endif } 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; #if !defined(LWT_ON_WINDOWS) sigset_t new_mask; sigset_t old_mask; int error; sigfillset(&new_mask); pthread_sigmask(SIG_SETMASK, &new_mask, &old_mask); #else DWORD error; #endif lwt_unix_mutex_lock(¬ification_mutex); /* Receive the signal. */ ret = notification_recv(); #if defined(LWT_ON_WINDOWS) if (ret == SOCKET_ERROR) { error = WSAGetLastError(); lwt_unix_mutex_unlock(¬ification_mutex); win32_maperr(error); uerror("recv_notifications", Nothing); } #else if (ret < 0) { error = errno; lwt_unix_mutex_unlock(¬ification_mutex); pthread_sigmask(SIG_SETMASK, &old_mask, NULL); unix_error(error, "recv_notifications", Nothing); } #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); #if !defined(LWT_ON_WINDOWS) pthread_sigmask(SIG_SETMASK, &old_mask, NULL); #endif 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() { SOCKET sockets[2]; 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. */ lwt_unix_socketpair(AF_INET, SOCK_STREAM, IPPROTO_TCP, sockets); socket_r = set_close_on_exec(sockets[0]); socket_w = set_close_on_exec(sockets[1]); notification_mode = NOTIFICATION_MODE_WINDOWS; notification_send = windows_notification_send; notification_recv = windows_notification_recv; return win_alloc_socket(socket_r); } #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) */ /* +-----------------------------------------------------------------+ | Signals | +-----------------------------------------------------------------+ */ #ifndef NSIG #define NSIG 64 #endif /* Notifications id for each monitored signal. */ static int signal_notifications[NSIG]; CAMLextern int caml_convert_signal_number (int); /* Send a notification when a signal is received. */ static void handle_signal(int signum) { if (signum >= 0 && signum < NSIG) { int id = signal_notifications[signum]; if (id != -1) { #if defined(LWT_ON_WINDOWS) /* The signal handler must be reinstalled if we use the signal function. */ signal(signum, handle_signal); #endif lwt_unix_send_notification(id); } } } #if defined(LWT_ON_WINDOWS) /* Handle Ctrl+C on windows. */ static BOOL WINAPI handle_break(DWORD event) { int id = signal_notifications[SIGINT]; if (id == -1 || (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT)) return FALSE; lwt_unix_send_notification(id); return TRUE; } #endif /* Install a signal handler. */ CAMLprim value lwt_unix_set_signal(value val_signum, value val_notification) { #if !defined(LWT_ON_WINDOWS) struct sigaction sa; #endif int signum = caml_convert_signal_number(Int_val(val_signum)); int notification = Int_val(val_notification); if (signum < 0 || signum >= NSIG) caml_invalid_argument("Lwt_unix.on_signal: unavailable signal"); signal_notifications[signum] = notification; #if defined(LWT_ON_WINDOWS) if (signum == SIGINT) { if (!SetConsoleCtrlHandler(handle_break, TRUE)) { signal_notifications[signum] = -1; win32_maperr(GetLastError()); uerror("SetConsoleCtrlHandler", Nothing); } } else { if (signal(signum, handle_signal) == SIG_ERR) { signal_notifications[signum] = -1; uerror("signal", Nothing); } } #else sa.sa_handler = handle_signal; sa.sa_flags = 0; sigemptyset(&sa.sa_mask); if (sigaction(signum, &sa, NULL) == -1) { signal_notifications[signum] = -1; uerror("sigaction", Nothing); } #endif return Val_unit; } /* Remove a signal handler. */ CAMLprim value lwt_unix_remove_signal(value val_signum) { #if !defined(LWT_ON_WINDOWS) struct sigaction sa; #endif /* The signal number is valid here since it was when we did the set_signal. */ int signum = caml_convert_signal_number(Int_val(val_signum)); signal_notifications[signum] = -1; #if defined(LWT_ON_WINDOWS) if (signum == SIGINT) SetConsoleCtrlHandler(NULL, FALSE); else signal(signum, SIG_DFL); #else sa.sa_handler = SIG_DFL; sa.sa_flags = 0; sigemptyset(&sa.sa_mask); sigaction(signum, &sa, NULL); #endif return Val_unit; } /* Mark all signals as non-monitored. */ CAMLprim value lwt_unix_init_signals() { int i; for (i = 0; i < NSIG; i++) signal_notifications[i] = -1; return Val_unit; } /* +-----------------------------------------------------------------+ | Job execution | +-----------------------------------------------------------------+ */ /* Execute the given job. */ static void execute_job(lwt_unix_job job) { DEBUG("executing the job"); lwt_unix_mutex_lock(&job->mutex); /* 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"); } } /* +-----------------------------------------------------------------+ | 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 | +-----------------------------------------------------------------+ */ #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) #define STACK_SIZE (256 * 1024) /* 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. */ sigjmp_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 sigjmp_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; sigjmp_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 (sigsetjmp(node->checkpoint, 1) == 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. */ siglongjmp(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(sigjmp_buf)); free(node); siglongjmp(buf, 1); } } } /* Allocate a new stack for doing blocking calls. */ void alloc_new_stack() { 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(LWT_UNIX_SIGNAL_ASYNC_SWITCH, &new_sa, &old_sa); /* Save the stack frame. */ raise(LWT_UNIX_SIGNAL_ASYNC_SWITCH); /* Restore the old signal handler. */ sigaction(LWT_UNIX_SIGNAL_ASYNC_SWITCH, &old_sa, NULL); /* Restore the old alternative stack. */ sigaltstack(&old_stack, NULL); } #endif /* defined(LWT_UNIX_HAVE_ASYNC_SWITCH) */ /* +-----------------------------------------------------------------+ | Threading stuff initialization | +-----------------------------------------------------------------+ */ /* Whether threading has been initialized. */ static int threading_initialized = 0; /* Initialize the pool of thread. */ void initialize_threading() { if (threading_initialized == 0) { lwt_unix_mutex_init(&pool_mutex); lwt_unix_condition_init(&pool_condition); #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) lwt_unix_mutex_init(&blocking_call_enter_mutex); main_thread = lwt_unix_thread_self(); #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; #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) struct stack_frame *node; #endif #if defined(HAVE_PTHREAD) /* Block all signals, otherwise ocaml handlers defined with the module Sys may be executed in this thread, oops... */ sigset_t mask; sigfillset(&mask); pthread_sigmask(SIG_SETMASK, &mask, NULL); #endif /* 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. */ #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) while (pool_queue == NULL && main_state == STATE_RUNNING) lwt_unix_condition_wait(&pool_condition, &pool_mutex); #else while (pool_queue == NULL) lwt_unix_condition_wait(&pool_condition, &pool_mutex); #endif DEBUG("received something to do"); /* This thread is busy. */ thread_waiting_count--; #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) 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 (sigsetjmp(node->checkpoint, 1) == 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. */ siglongjmp(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 { #endif /* defined(LWT_UNIX_HAVE_ASYNC_SWITCH) */ 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); #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) } #endif } 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); #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) struct stack_frame *node; #endif 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_UNIX_SIGNAL_ASYNC_SWITCH) if (SIGRTMIN > SIGRTMAX) caml_invalid_argument("the switch method is not supported"); 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 (sigsetjmp(blocking_call_leave, 1)) { 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. */ siglongjmp(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); } #else /* defined(LWT_UNIX_SIGNAL_ASYNC_SWITCH) */ caml_invalid_argument("the switch method is not supported"); #endif } 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_self_result(value val_job) { lwt_unix_job job = Job_val(val_job); return job->result(job); } CAMLprim value lwt_unix_run_job_sync(value val_job) { lwt_unix_job job = Job_val(val_job); /* So lwt_unix_free_job won't try to destroy the mutex. */ job->async_method = LWT_UNIX_ASYNC_METHOD_NONE; caml_enter_blocking_section(); job->worker(job); caml_leave_blocking_section(); return job->result(job); } CAMLprim value lwt_unix_reset_after_fork() { if (threading_initialized) { #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) /* Reset the main thread. */ main_thread = lwt_unix_thread_self (); #endif /* 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); } lwt-2.4.3/src/unix/lwt_unix.mli0000644000000000000000000010512312067037505014651 0ustar0000000000000000(* 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. Most operations on sockets and pipes (on Windows it is only sockets) 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 sockets [sock1] and [sock2] and you want to read something from [sock1] or exclusively from [sock2], and fail with an exception if a timeout of 1 second expires, without reading anything from [sock1] and [sock2], even if they become readable in the future. Then you can do: {[ Lwt.pick [Lwt_unix.timeout 1.0; read sock1 buf1 ofs1 len1; read sock2 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 thread which remains suspended for [d] seconds then fails 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 succeeds, 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, and describes 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 descriptor} 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 (** Executes the given command, waits until it terminates, and return its termination status. The string is interpreted by the shell [/bin/sh] on Unix and [cmd.exe] on Windows. The result [WEXITED 127] indicates that the shell couldn't be executed. *) (** {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 #if ocaml_version >= (3, 13) | O_SHARE_DELETE #endif 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 than calling [readdir] [count] times. 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 on_signal_full : int -> (signal_handler_id -> int -> unit) -> signal_handler_id (** [on_signal_full f] is the same as [on_signal f] except that [f] also receive the signal handler identifier as argument so it can disable it. *) 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. On some platforms, obtaining the peer pid is not possible and it will be set to [-1]. If obtaining credentials is not possible on the current system, it raises [Lwt_sys.Not_available "get_credentials"]. This call is not available on windows. *) (** {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 job descriptions. A job description describe how to call a C function and how to get its result. The C function may be executed in another system thread. *) val execute_job : ?async_method : async_method -> job : 'a job -> result : ('a job -> 'b) -> free : ('a job -> unit) -> 'b Lwt.t (** This is the old and deprecated way of running a job. Use {!run_job} in new code. *) val run_job : ?async_method : async_method -> 'a job -> 'a Lwt.t (** [run_job ?async_method job] starts [job] and wait for its termination. The async method is choosen follow: - if the optional parameter [async_method] is specified, it is used, - otherwise if the local key {!async_method_key} is set in the current thread, it is used, - otherwise the default method (returned by {!default_async_method}) is used. If the method is {!Async_none} then the job is run synchronously and may block the current system thread, thus blocking all Lwt threads. If the method is {!Async_detach} then the job is run in another system thread, unless the the maximum number of worker threads has been reached (as given by {!pool_size}). If the method is {!Async_switch} then the job is run synchronously and if it blocks, execution will continue in another system thread (unless the limit is reached). *) val abort_jobs : exn -> unit (** [abort_jobs exn] make all pending jobs to fail with exn. Note that this does not abort the real job (i.e. the C function executing it), just the lwt thread for it. *) val cancel_jobs : unit -> unit (** [cancel_jobs ()] is the same as [abort_jobs 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 call_notification : int -> unit (** Call the handler associated to the given notification. Note that if the notification was defined with [once = true] it is removed. *) 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]. *) lwt-2.4.3/src/unix/lwt_unix.ml0000644000000000000000000017424512067037505014513 0ustar0000000000000000(* 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 } let call_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 -> () (* +-----------------------------------------------------------------+ | 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. *) (* For all running job, a waiter and a function to abort it. *) let jobs = Lwt_sequence.create () let rec abort_jobs exn = match Lwt_sequence.take_opt_l jobs with | Some (w, f) -> f exn; abort_jobs exn | None -> () let cancel_jobs () = abort_jobs Lwt.Canceled let wait_for_jobs () = join (Lwt_sequence.fold_l (fun (w, f) l -> w :: l) jobs []) let wrap_result f x = try Lwt.make_value (f x) with exn -> Lwt.make_error exn let run_job_aux async_method job result = (* Starts the job. *) if start_job job async_method then (* The job has already terminated, read and return the result immediatly. *) Lwt.of_result (result job) else begin (* Thread for the job. *) let waiter, wakener = wait () in (* Add the job to the sequence of all jobs. *) let node = Lwt_sequence.add_l (waiter >> return (), fun exn -> if state waiter = Sleep then wakeup_exn wakener exn) jobs in ignore begin (* Create the notification for asynchronous wakeup. *) let id = make_notification ~once:true (fun () -> Lwt_sequence.remove node; let result = result job in if state waiter = Sleep then Lwt.wakeup_result wakener result) in (* Give the job some time before we fallback to asynchronous notification. *) lwt () = pause () in (* The job has terminated, send the result immediatly. *) if check_job job id then call_notification id; return () end; waiter end let choose_async_method = function | Some async_method -> async_method | None -> match Lwt.get async_method_key with | Some am -> am | None -> !default_async_method_var let execute_job ?async_method ~job ~result ~free = let async_method = choose_async_method async_method in run_job_aux async_method job (fun job -> let x = wrap_result result job in free job; x) external self_result : 'a job -> 'a = "lwt_unix_self_result" (* Returns the result of a job using the [result] field of the C job structure. *) external run_job_sync : 'a job -> 'a = "lwt_unix_run_job_sync" (* Exeuctes a job synchronously and returns its result. *) let self_result job = try Lwt.make_value (self_result job) with exn -> Lwt.make_error exn let run_job ?async_method job = let async_method = choose_async_method async_method in if async_method = Async_none then try return (run_job_sync job) with exn -> fail exn else run_job_aux async_method job self_result (* +-----------------------------------------------------------------+ | 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 -> bool job = "lwt_unix_guess_blocking_job" let guess_blocking fd = run_job (guess_blocking_job fd) 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 unix_stub_readable fd = Unix.select [fd] [] [] 0.0 <> ([], [], []) let unix_stub_writable fd = Unix.select [] [fd] [] 0.0 <> ([], [], []) #else external unix_stub_readable : Unix.file_descr -> bool = "lwt_unix_readable" external unix_stub_writable : Unix.file_descr -> bool = "lwt_unix_writable" #endif let rec unix_readable fd = try unix_stub_readable fd with Unix.Unix_error (Unix.EINTR, _, _) -> unix_readable fd let rec unix_writable fd = try unix_stub_writable fd with Unix.Unix_error (Unix.EINTR, _, _) -> unix_writable fd let readable ch = check_descriptor ch; unix_readable ch.fd let writable ch = check_descriptor ch; unix_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 = check_descriptor ch; lwt blocking = Lazy.force ch.blocking in try if not blocking || (event = Read && unix_readable ch.fd) || (event = Write && unix_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 (* +-----------------------------------------------------------------+ | Generated jobs | +-----------------------------------------------------------------+ *) module Jobs = Lwt_unix_jobs_generated.Make(struct type 'a t = 'a job end) (* +-----------------------------------------------------------------+ | 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 ocaml_version >= (3, 13) | O_SHARE_DELETE #endif #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.file_descr * bool) job = "lwt_unix_open_job" let openfile name flags perms = lwt fd, blocking = run_job (open_job name flags perms) 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 let close ch = if ch.state = Closed then check_descriptor ch; set_state ch Closed; clear_events ch; run_job (Jobs.close_job ch.fd) #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 -> string -> int -> int -> int job = "lwt_unix_read_job" 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 run_job (read_job ch.fd buf pos len) | 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 -> int job = "lwt_unix_write_job" 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 run_job (write_job ch.fd buf pos len) | 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 let lseek ch offset whence = check_descriptor ch; run_job (Jobs.lseek_job ch.fd offset whence) #endif #if windows let truncate name offset = return (Unix.truncate name offset) #else let truncate name offset = run_job (Jobs.truncate_job name offset) #endif #if windows let ftruncate ch offset = check_descriptor ch; return (Unix.ftruncate ch.fd offset) #else let ftruncate ch offset = check_descriptor ch; run_job (Jobs.ftruncate_job ch.fd offset) #endif (* +-----------------------------------------------------------------+ | File system synchronisation | +-----------------------------------------------------------------+ *) let fdatasync ch = check_descriptor ch; run_job (Jobs.fdatasync_job ch.fd) let fsync ch = check_descriptor ch; run_job (Jobs.fsync_job ch.fd) (* +-----------------------------------------------------------------+ | 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.stats job = "lwt_unix_stat_job" let stat name = run_job (stat_job name) #endif #if windows let lstat name = return (Unix.lstat name) #else external lstat_job : string -> Unix.stats job = "lwt_unix_lstat_job" let lstat name = run_job (lstat_job name) #endif #if windows let fstat ch = check_descriptor ch; return (Unix.fstat ch.fd) #else external fstat_job : Unix.file_descr -> Unix.stats job = "lwt_unix_fstat_job" let fstat ch = check_descriptor ch; run_job (fstat_job ch.fd) #endif #if windows let isatty ch = check_descriptor ch; return (Unix.isatty ch.fd) #else external isatty_job : Unix.file_descr -> bool job = "lwt_unix_isatty_job" let isatty ch = check_descriptor ch; run_job (isatty_job ch.fd) #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 let lseek ch offset whence = check_descriptor ch; run_job (Jobs.lseek_64_job ch.fd offset whence) #endif #if windows let truncate name offset = return (Unix.LargeFile.truncate name offset) #else let truncate name offset = run_job (Jobs.truncate_64_job name offset) #endif #if windows let ftruncate ch offset = check_descriptor ch; return (Unix.LargeFile.ftruncate ch.fd offset) #else let ftruncate ch offset = check_descriptor ch; run_job (Jobs.ftruncate_64_job ch.fd offset) #endif #if windows let stat name = return (Unix.LargeFile.stat name) #else external stat_job : string -> Unix.LargeFile.stats job = "lwt_unix_stat_64_job" let stat name = run_job (stat_job name) #endif #if windows let lstat name = return (Unix.LargeFile.lstat name) #else external lstat_job : string -> Unix.LargeFile.stats job = "lwt_unix_lstat_64_job" let lstat name = run_job (lstat_job name) #endif #if windows let fstat ch = check_descriptor ch; return (Unix.LargeFile.fstat ch.fd) #else external fstat_job : Unix.file_descr -> Unix.LargeFile.stats job = "lwt_unix_fstat_64_job" let fstat ch = check_descriptor ch; run_job (fstat_job ch.fd) #endif end (* +-----------------------------------------------------------------+ | Operations on file names | +-----------------------------------------------------------------+ *) #if windows let unlink name = return (Unix.unlink name) #else let unlink name = run_job (Jobs.unlink_job name) #endif #if windows let rename name1 name2 = return (Unix.rename name1 name2) #else let rename name1 name2 = run_job (Jobs.rename_job name1 name2) #endif #if windows let link name1 name2 = return (Unix.link name1 name2) #else let link oldpath newpath = run_job (Jobs.link_job oldpath newpath) #endif (* +-----------------------------------------------------------------+ | File permissions and ownership | +-----------------------------------------------------------------+ *) #if windows let chmod name perms = return (Unix.chmod name perms) #else let chmod path mode = run_job (Jobs.chmod_job path mode) #endif #if windows let fchmod ch perms = check_descriptor ch; return (Unix.fchmod ch.fd perms) #else let fchmod ch mode = check_descriptor ch; run_job (Jobs.fchmod_job ch.fd mode) #endif #if windows let chown name uid gid = return (Unix.chown name uid gid) #else let chown path ower group = run_job (Jobs.chown_job path ower group) #endif #if windows let fchown ch uid gid = check_descriptor ch; return (Unix.fchown ch.fd uid gid) #else let fchown ch ower group = check_descriptor ch; run_job (Jobs.fchown_job ch.fd ower group) #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 let access path mode = run_job (Jobs.access_job path mode) #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 let mkdir name perms = run_job (Jobs.mkdir_job name perms) #endif #if windows let rmdir name = return (Unix.rmdir name) #else let rmdir name = run_job (Jobs.rmdir_job name) #endif #if windows let chdir name = return (Unix.chdir name) #else let chdir path = run_job (Jobs.chdir_job path) #endif #if windows let chroot name = return (Unix.chroot name) #else let chroot path = run_job (Jobs.chroot_job path) #endif type dir_handle = Unix.dir_handle #if windows let opendir name = return (Unix.opendir name) #else external opendir_job : string -> Unix.dir_handle job = "lwt_unix_opendir_job" let opendir name = run_job (opendir_job name) #endif #if windows let readdir handle = return (Unix.readdir handle) #else external readdir_job : Unix.dir_handle -> string job = "lwt_unix_readdir_job" let readdir handle = run_job (readdir_job handle) #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 -> string array job = "lwt_unix_readdir_n_job" let readdir_n handle count = if count < 0 then fail (Invalid_argument "Lwt_uinx.readdir_n") else run_job (readdir_n_job handle count) #endif #if windows let rewinddir handle = return (Unix.rewinddir handle) #else external rewinddir_job : Unix.dir_handle -> unit job = "lwt_unix_rewinddir_job" let rewinddir handle = run_job (rewinddir_job handle) #endif #if windows let closedir handle = return (Unix.closedir handle) #else external closedir_job : Unix.dir_handle -> unit job = "lwt_unix_closedir_job" let closedir handle = run_job (closedir_job handle) #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 let mkfifo name perms = run_job (Jobs.mkfifo_job name perms) #endif (* +-----------------------------------------------------------------+ | Symbolic links | +-----------------------------------------------------------------+ *) #if windows let symlink name1 name2 = return (Unix.symlink name1 name2) #else let symlink name1 name2 = run_job (Jobs.symlink_job name1 name2) #endif #if windows let readlink name = return (Unix.readlink name) #else external readlink_job : string -> string job = "lwt_unix_readlink_job" let readlink name = run_job (readlink_job name) #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 -> unit job = "lwt_unix_lockf_job" let lockf ch cmd size = check_descriptor ch; run_job (lockf_job ch.fd cmd size) #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 -> string job = "lwt_unix_getlogin_job" let getlogin () = run_job (getlogin_job ()) #endif #if windows let getpwnam name = return (Unix.getpwnam name) #else external getpwnam_job : string -> Unix.passwd_entry job = "lwt_unix_getpwnam_job" let getpwnam name = run_job (getpwnam_job name) #endif #if windows let getgrnam name = return (Unix.getgrnam name) #else external getgrnam_job : string -> Unix.group_entry job = "lwt_unix_getgrnam_job" let getgrnam name = run_job (getgrnam_job name) #endif #if windows let getpwuid uid = return (Unix.getpwuid uid) #else external getpwuid_job : int -> Unix.passwd_entry job = "lwt_unix_getpwuid_job" let getpwuid uid = run_job (getpwuid_job uid) #endif #if windows let getgrgid gid = return (Unix.getgrgid gid) #else external getgrgid_job : int -> Unix.group_entry job = "lwt_unix_getgrgid_job" let getgrgid gid = run_job (getgrgid_job gid) #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 #if windows external socketpair_stub : socket_domain -> socket_type -> int -> Unix.file_descr * Unix.file_descr = "lwt_unix_socketpair_stub" #else let socketpair_stub = Unix.socketpair #endif let socketpair dom typ proto = let (s1, s2) = socketpair_stub 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 (unix_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 -> string job = "lwt_unix_gethostname_job" let gethostname () = run_job (gethostname_job ()) #endif #if windows let gethostbyname name = return (Unix.gethostbyname name) #else external gethostbyname_job : string -> Unix.host_entry job = "lwt_unix_gethostbyname_job" let gethostbyname name = run_job (gethostbyname_job name) #endif #if windows let gethostbyaddr addr = return (Unix.gethostbyaddr addr) #else external gethostbyaddr_job : Unix.inet_addr -> Unix.host_entry job = "lwt_unix_gethostbyaddr_job" let gethostbyaddr addr = run_job (gethostbyaddr_job addr) #endif #if windows let getprotobyname name = return (Unix.getprotobyname name) #else external getprotobyname_job : string -> Unix.protocol_entry job = "lwt_unix_getprotobyname_job" let getprotobyname name = run_job (getprotobyname_job name) #endif #if windows let getprotobynumber number = return (Unix.getprotobynumber number) #else external getprotobynumber_job : int -> Unix.protocol_entry job = "lwt_unix_getprotobynumber_job" let getprotobynumber number = run_job (getprotobynumber_job number) #endif #if windows let getservbyname name x = return (Unix.getservbyname name x) #else external getservbyname_job : string -> string -> Unix.service_entry job = "lwt_unix_getservbyname_job" let getservbyname name x = run_job (getservbyname_job name x) #endif #if windows let getservbyport port x = return (Unix.getservbyport port x) #else external getservbyport_job : int -> string -> Unix.service_entry job = "lwt_unix_getservbyport_job" let getservbyport port x = run_job (getservbyport_job port x) #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.addr_info list job = "lwt_unix_getaddrinfo_job" let getaddrinfo host service opts = run_job (getaddrinfo_job host service opts) >>= fun l -> return (List.rev l) #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.name_info job = "lwt_unix_getnameinfo_job" let getnameinfo addr opts = run_job (getnameinfo_job addr opts) #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.terminal_io job = "lwt_unix_tcgetattr_job" let tcgetattr ch = check_descriptor ch; run_job (tcgetattr_job ch.fd) #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 -> unit job = "lwt_unix_tcsetattr_job" let tcsetattr ch when_ attrs = check_descriptor ch; run_job (tcsetattr_job ch.fd when_ attrs) #endif #if windows let tcsendbreak ch delay = check_descriptor ch; return (Unix.tcsendbreak ch.fd delay) #else let tcsendbreak ch delay = check_descriptor ch; run_job (Jobs.tcsendbreak_job ch.fd delay) #endif #if windows let tcdrain ch = check_descriptor ch; return (Unix.tcdrain ch.fd) #else let tcdrain ch = check_descriptor ch; run_job (Jobs.tcdrain_job ch.fd) #endif #if windows let tcflush ch q = check_descriptor ch; return (Unix.tcflush ch.fd q) #else let tcflush ch q = check_descriptor ch; run_job (Jobs.tcflush_job ch.fd q) #endif #if windows let tcflow ch act = check_descriptor ch; return (Unix.tcflow ch.fd act) #else let tcflow ch act = check_descriptor ch; run_job (Jobs.tcflow_job ch.fd act) #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 rec handle_notifications ev = (* Process available notifications. *) Array.iter call_notification (recv_notifications ()) let event_notifications = ref (Lwt_engine.on_readable (init_notification ()) handle_notifications) (* +-----------------------------------------------------------------+ | Signals | +-----------------------------------------------------------------+ *) external set_signal : int -> int -> unit = "lwt_unix_set_signal" external remove_signal : int -> unit = "lwt_unix_remove_signal" external init_signals : unit -> unit = "lwt_unix_init_signals" let () = init_signals () module Signal_map = Map.Make(struct type t = int let compare a b = a - b end) type signal_handler = { sh_num : int; sh_node : (signal_handler_id -> int -> unit) Lwt_sequence.node; } and signal_handler_id = signal_handler option ref let signals = ref Signal_map.empty let signal_count () = Signal_map.fold (fun signum (id, actions) len -> len + Lwt_sequence.length actions) !signals 0 let on_signal_full signum handler = let id = ref None in 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 id signum) actions) in (try set_signal signum 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 id := Some { sh_num = signum; sh_node = node }; id let on_signal signum f = on_signal_full signum (fun id num -> f num) let disable_signal_handler id = match !id with | None -> () | Some sh -> id := None; Lwt_sequence.remove sh.sh_node; let notification, actions = Signal_map.find sh.sh_num !signals in if Lwt_sequence.is_empty actions then begin remove_signal sh.sh_num; signals := Signal_map.remove sh.sh_num !signals; stop_notification notification end let reinstall_signal_handler signum = match try Some (Signal_map.find signum !signals) with Not_found -> None with | Some (notification, actions) -> set_signal signum 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, f) l -> f :: 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 (fun f -> f Lwt.Canceled) 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) #if windows external system_job : string -> int job = "lwt_unix_system_job" let system cmd = lwt code = run_job (system_job ("cmd.exe /c " ^ cmd)) in return (Unix.WEXITED code) #else let system cmd = match fork () with | 0 -> begin try Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] with _ -> (* Prevent exit hooks from running, they are not supposed to be executed here. *) Lwt_sequence.iter_node_l Lwt_sequence.remove Lwt_main.exit_hooks; exit 127 end | id -> waitpid [] id >|= snd #endif (* +-----------------------------------------------------------------+ | 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) lwt-2.4.3/src/unix/lwt_unix.h0000644000000000000000000002545312067037505014326 0ustar0000000000000000/* 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 #include /* 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); void *lwt_unix_realloc(void *ptr, size_t size); /* Same as [strdup] and abort hte program if there is not memory left. */ char *lwt_unix_strdup(char *string); /* Helpers for allocating structures. */ #define lwt_unix_new(type) (type*)lwt_unix_malloc(sizeof(type)) #define lwt_unix_new_plus(type, size) (type*)lwt_unix_malloc(sizeof(type) + size) /* 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(HAVE_PTHREAD) #include typedef pthread_t lwt_unix_thread; typedef pthread_mutex_t lwt_unix_mutex; typedef pthread_cond_t lwt_unix_condition; #else typedef DWORD lwt_unix_thread; typedef CRITICAL_SECTION lwt_unix_mutex; typedef struct lwt_unix_condition 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 }; /* 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. This function must not: - access or allocate OCaml block values (tuples, strings, ...), - call OCaml code. */ void (*worker)(struct lwt_unix_job *job); /* The function to call to extract the result and free memory allocated by the job. Note: if you want to raise an excpetion, be sure to free resources before raising it! It has been introduced in Lwt 2.3.3. */ value (*result)(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); /* Type of result functions. */ typedef value (*lwt_unix_job_result)(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); /* +-----------------------------------------------------------------+ | Helpers for writing jobs | +-----------------------------------------------------------------+ */ /* Allocate a job structure and set its worker and result fields. - VAR is the name of the job variable. It is usually "job". - FUNC is the suffix of the structure name and functions of this job. It is usually the name of the function that is wrapped. - SIZE is the dynamic size to allocate at the end of the structure, in case it ends ends with something of the form: char data[]); */ #define LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE) \ struct job_##FUNC *VAR = lwt_unix_new_plus(struct job_##FUNC, SIZE); \ VAR->job.worker = (lwt_unix_job_worker)worker_##FUNC; \ VAR->job.result = (lwt_unix_job_result)result_##FUNC /* Same as LWT_UNIX_INIT_JOB, but also stores a string argument named ARG at the end of the job structure. The offset of the copied string is assigned to the field VAR->ARG. The structure must ends with: char data[]; */ #define LWT_UNIX_INIT_JOB_STRING(VAR, FUNC, SIZE, ARG) \ mlsize_t __len = caml_string_length(ARG); \ LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE + __len + 1); \ VAR->ARG = VAR->data + SIZE; \ memcpy(VAR->ARG, String_val(ARG), __len + 1) /* Same as LWT_UNIX_INIT_JOB, but also stores two string arguments named ARG1 and ARG2 at the end of the job structure. The offsets of the copied strings are assigned to the fields VAR->ARG1 and VAR->ARG2. The structure definition must ends with: char data[]; */ #define LWT_UNIX_INIT_JOB_STRING2(VAR, FUNC, SIZE, ARG1, ARG2) \ mlsize_t __len1 = caml_string_length(ARG1); \ mlsize_t __len2 = caml_string_length(ARG2); \ LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE + __len1 + __len2 + 2); \ VAR->ARG1 = VAR->data + SIZE; \ VAR->ARG2 = VAR->data + SIZE + __len1 + 1; \ memcpy(VAR->ARG1, String_val(ARG1), __len1 + 1); \ memcpy(VAR->ARG2, String_val(ARG2), __len2 + 1) /* If TEST is true, it frees the job and raises Unix.Unix_error using the value of errno stored in the field error_code. */ #define LWT_UNIX_CHECK_JOB(VAR, TEST, NAME) \ if (TEST) { \ int error_code = VAR->error_code; \ lwt_unix_free_job(&VAR->job); \ unix_error(error_code, NAME, Nothing); \ } /* If TEST is true, it frees the job and raises Unix.Unix_error using the value of errno stored in the field error_code and uses the C string ARG for the third field of Unix.Unix_error. */ #define LWT_UNIX_CHECK_JOB_ARG(VAR, TEST, NAME, ARG) \ if (TEST) { \ int error_code = VAR->error_code; \ value arg = caml_copy_string(ARG); \ lwt_unix_free_job(&VAR->job); \ unix_error(error_code, NAME, arg); \ } /* +-----------------------------------------------------------------+ | Deprecated | +-----------------------------------------------------------------+ */ /* Define not implement methods. Deprecated: it is for the old mechanism with three externals. */ #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 */ lwt-2.4.3/src/unix/lwt_timeout.mli0000644000000000000000000000317112067037505015354 0ustar0000000000000000(* 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. *) lwt-2.4.3/src/unix/lwt_timeout.ml0000644000000000000000000000622412067037505015205 0ustar0000000000000000(* 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 lwt-2.4.3/src/unix/lwt_throttle.mli0000644000000000000000000000334712067037505015540 0ustar0000000000000000(* 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 lwt-2.4.3/src/unix/lwt_throttle.ml0000644000000000000000000000716712067037505015373 0ustar0000000000000000(* 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 lwt-2.4.3/src/unix/lwt_sys.mli0000644000000000000000000000330612067037505014504 0ustar0000000000000000(* 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. *) lwt-2.4.3/src/unix/lwt_sys.ml0000644000000000000000000000356312067037505014340 0ustar0000000000000000(* 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 = "Win32" 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 () lwt-2.4.3/src/unix/lwt_process_stubs.c0000644000000000000000000000643112067037505016227 0ustar0000000000000000/* Lightweight thread library for Objective Caml * http://www.ocsigen.org/lwt * Module Lwt_process_stubs * Copyright (C) 2012 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 #if defined(LWT_ON_WINDOWS) #include #include #include #include #include static HANDLE get_handle(value opt) { value fd; if (Is_block(opt)) { fd = Field(opt, 0); if (Descr_kind_val(fd) == KIND_SOCKET) { win32_maperr(ERROR_INVALID_HANDLE); uerror("CreateProcess", Nothing); return NULL; } else return Handle_val(fd); } else return INVALID_HANDLE_VALUE; } #define string_option(opt) (Is_block(opt) ? String_val(Field(opt, 0)) : NULL) CAMLprim value lwt_process_create_process(value prog, value cmdline, value env, value fds) { CAMLparam4(prog, cmdline, env, fds); CAMLlocal1(result); STARTUPINFO si; PROCESS_INFORMATION pi; ZeroMemory(&si, sizeof(si)); ZeroMemory(&pi, sizeof(pi)); si.cb = sizeof(si); si.dwFlags = STARTF_USESTDHANDLES; si.hStdInput = get_handle(Field(fds, 0)); si.hStdOutput = get_handle(Field(fds, 1)); si.hStdError = get_handle(Field(fds, 2)); if (!CreateProcess(string_option(prog), String_val(cmdline), NULL, NULL, TRUE, 0, string_option(env), NULL, &si, &pi)) { win32_maperr(GetLastError()); uerror("CreateProcess", Nothing); } CloseHandle(pi.hThread); result = caml_alloc_tuple(2); Store_field(result, 0, Val_int(pi.dwProcessId)); Store_field(result, 1, win_alloc_handle(pi.hProcess)); CAMLreturn(result); } struct job_wait { struct lwt_unix_job job; HANDLE handle; }; static void worker_wait(struct job_wait *job) { WaitForSingleObject(job->handle, INFINITE); } static value result_wait(struct job_wait *job) { DWORD code, error; if (!GetExitCodeProcess(job->handle, &code)) { error = GetLastError(); CloseHandle(job->handle); lwt_unix_free_job(&job->job); win32_maperr(error); uerror("GetExitCodeProcess", Nothing); } CloseHandle(job->handle); lwt_unix_free_job(&job->job); return Val_int(code); } CAMLprim value lwt_process_wait_job(value handle) { LWT_UNIX_INIT_JOB(job, wait, 0); job->handle = Handle_val(handle); return lwt_unix_alloc_job(&(job->job)); } CAMLprim value lwt_process_terminate_process(value handle, value code) { if (!TerminateProcess(Handle_val(handle), Int_val(code))) { win32_maperr(GetLastError()); uerror("TerminateProcess", Nothing); } return Val_unit; } #endif /* defined(LWT_ON_WINDOWS) */ lwt-2.4.3/src/unix/lwt_process.mli0000644000000000000000000002103612067037505015344 0ustar0000000000000000(* 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. The first field is the name of the executable and the second is the list of arguments. For example: {[ ("ls", [|"ls"; "-l"|]) ]}. Notes: - if the name is the empty string, then the first argument will be used. You should specify a name only if you do not want the executable to be searched in the PATH. On Windows the only way to enable automatic seach in PATH is to pass an empty name. - it is possible to ``inline'' an argument, i.e. split it into multiple arguments. To do that prefix it with ["\000"]. For example: {[ ("", [|"echo"; "\000foo bar"|]) ]} is the same as: {[ ("", [|"echo"; "foo"; "bar"|]) ]}. *) val shell : string -> command (** A command executed with the shell. (with ["/bin/sh -c "] on Unix and ["cmd.exe /c "] on Windows). *) (** 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 terminate : unit (** Terminates the process. It is equivalent to [kill Sys.sigkill] on Unix but also works on windows (unlike {!kill}). *) 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 lwt-2.4.3/src/unix/lwt_process.ml0000644000000000000000000004056412067037505015202 0ustar0000000000000000(* 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. *) #include "src/unix/lwt_config.ml" open Lwt type command = string * string array #if windows let shell cmd = ("", [|"cmd.exe"; "/c"; "\000" ^ cmd|]) #else let shell cmd = ("", [|"/bin/sh"; "-c"; cmd|]) #endif type redirection = [ `Keep | `Dev_null | `Close | `FD_copy of Unix.file_descr | `FD_move of Unix.file_descr ] (* +-----------------------------------------------------------------+ | OS-depentent command spawning | +-----------------------------------------------------------------+ *) type proc = { id : int; (* The process id. *) fd : Unix.file_descr; (* A handle on windows, and a dummy value of Unix. *) } #if windows let get_fd fd redirection = match redirection with | `Keep -> Some fd | `Dev_null -> Some (Unix.openfile "nul" [Unix.O_RDWR] 0o666) | `Close -> None | `FD_copy fd' -> Some fd' | `FD_move fd' -> Some fd' external create_process : string option -> string -> string option -> (Unix.file_descr option * Unix.file_descr option * Unix.file_descr option) -> proc = "lwt_process_create_process" let quote arg = if String.length arg > 0 && arg.[0] = '\000' then String.sub arg 1 (String.length arg - 1) else Filename.quote arg let spawn (prog, args) env ?(stdin:redirection=`Keep) ?(stdout:redirection=`Keep) ?(stderr:redirection=`Keep) toclose = let cmdline = String.concat " " (List.map quote (Array.to_list args)) in let env = match env with | None -> None | Some env -> let len = Array.fold_left (fun len str -> String.length str + len + 1) 1 env in let res = String.create len in let ofs = Array.fold_left (fun ofs str -> let len = String.length str in String.blit str 0 res ofs len; res.[ofs + len] <- '\000'; ofs + len + 1) 0 env in res.[ofs] <- '\000'; Some res in List.iter Unix.set_close_on_exec toclose; let proc = create_process (if prog = "" then None else Some prog) cmdline env (get_fd Unix.stdin stdin, get_fd Unix.stdout stdout, get_fd Unix.stderr stderr) in let close = function | `FD_move fd -> Unix.close fd | _ -> () in close stdin; close stdout; close stderr; proc external wait_job : Unix.file_descr -> int Lwt_unix.job = "lwt_process_wait_job" let waitproc proc = lwt code = Lwt_unix.run_job (wait_job proc.fd) in return (proc.id, Lwt_unix.WEXITED code, { Lwt_unix.ru_utime = 0.; Lwt_unix.ru_stime = 0. }) external terminate_process : Unix.file_descr -> int -> unit = "lwt_process_terminate_process" let terminate proc = terminate_process proc.fd 1 #else 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 rec need_inline args idx = if idx = Array.length args then false else let arg = args.(idx) in (String.length arg > 0 && arg.[0] = '\000') || need_inline args (idx + 1) let split arg = let rec search_start i = if i = String.length arg then [] else match arg.[i] with | ' ' | '\t' -> search_start (i + 1) | _ -> loop_word i (i + 1) and loop_word i j = if j = String.length arg then [String.sub arg i (j - i)] else match arg.[i] with | ' ' | '\t' -> String.sub arg i (j - i) :: search_start (j + 1) | _ -> loop_word i (j + 1) in search_start 0 let inline arg = if String.length arg > 0 && arg.[0] = '\000' then split arg else [arg] let map_args args = if need_inline args 0 then begin Array.of_list (List.flatten (List.map inline (Array.to_list args))) end else args let spawn (prog, args) env ?(stdin:redirection=`Keep) ?(stdout:redirection=`Keep) ?(stderr:redirection=`Keep) toclose = let prog = if prog = "" && Array.length args > 0 then args.(0) else prog in 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 exit hooks from running, they are not supposed to be executed here. *) 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; fd = Unix.stdin } let waitproc proc = Lwt_unix.wait4 [] proc.id let terminate proc = Unix.kill proc.id Sys.sigkill #endif (* +-----------------------------------------------------------------+ | Objects | +-----------------------------------------------------------------+ *) type state = | Running | Exited of Unix.process_status let status (pid, status, rusage) = status let rusage (pid, status, rusage) = rusage external cast_chan : 'a Lwt_io.channel -> unit Lwt_io.channel = "%identity" (* Transform a channel into a channel that only support closing. *) let ignore_close chan = ignore (Lwt_io.close chan) class virtual common timeout proc channels = let wait = waitproc proc in let close = lazy(join (List.map Lwt_io.close channels) >> wait) in object(self) method pid = proc.id method state = match Lwt.poll wait with | None -> Running | Some (pid, status, rusage) -> Exited status method kill signum = if Lwt.state wait = Lwt.Sleep then Unix.kill proc.id signum method terminate = if Lwt.state wait = Lwt.Sleep then terminate proc method close = Lwt.protected (Lazy.force close) >|= status method status = Lwt.protected wait >|= status method rusage = Lwt.protected wait >|= rusage initializer (* Ensure channels are closed when no longer used. *) List.iter (Gc.finalise ignore_close) channels; (* Handle timeout. *) match timeout with | None -> () | Some dt -> ignore ( (* Ignore errors since they can be obtained by self#close. *) Lwt.try_bind (fun () -> Lwt.choose [Lwt_unix.sleep dt >> return false; wait >> return true]) (function | true -> return_unit | false -> self#terminate; Lazy.force close >> Lwt.return_unit) (fun exn -> (* The exception is dropped because it can be obtained with self#close. *) Lwt.return_unit) ) end class process_none ?timeout ?env ?stdin ?stdout ?stderr cmd = let proc = spawn cmd env ?stdin ?stdout ?stderr [] in object inherit common timeout proc [] end class process_in ?timeout ?env ?stdin ?stderr cmd = let stdout_r, stdout_w = Unix.pipe () in let proc = 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 in object inherit common timeout proc [cast_chan stdout] method stdout = stdout end class process_out ?timeout ?env ?stdout ?stderr cmd = let stdin_r, stdin_w = Unix.pipe () in let proc = 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 in object inherit common timeout proc [cast_chan stdin] 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 proc = 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 in object inherit common timeout proc [cast_chan stdin; cast_chan stdout] 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 proc = 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 in object inherit common timeout proc [cast_chan stdin; cast_chan stdout; cast_chan stderr] 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 read_opt read ic = try_lwt read ic >|= fun x -> Some x with Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file -> return None let recv_chars pr = let ic = pr#stdout in Gc.finalise ingore_close ic; Lwt_stream.from (fun _ -> lwt x = read_opt Lwt_io.read_char 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 = read_opt Lwt_io.read_line 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 let recv_line pr = let ic = pr#stdout in try_lwt Lwt_io.read_line ic finally Lwt_io.close ic let send f pr data = let oc = pr#stdin in try_lwt f oc data finally Lwt_io.close oc (* 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 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 *) type 'a map_state = | Init | Save of 'a option Lwt.t | Done (* Monitor the thread [sender] in the stream [st] so write errors are reported. *) let monitor sender st = let sender = sender >|= fun () -> None in let state = ref Init in Lwt_stream.from (fun () -> match !state with | Init -> let getter = Lwt.apply Lwt_stream.get st in let result _ = match Lwt.state sender with | Lwt.Sleep -> (* The sender is still sleeping, behave as the getter. *) getter | Lwt.Return _ -> (* The sender terminated successfully, we are done monitoring it. *) state := Done; getter | Lwt.Fail _ -> (* The sender failed, behave as the sender for this element and save current getter. *) state := Save getter; sender in Lwt.try_bind (fun () -> Lwt.choose [sender; getter]) result result | Save t -> state := Done; t | Done -> Lwt_stream.get st) let pmap ?timeout ?env ?stderr cmd text = let pr = open_process ?timeout ?env ?stderr cmd in (* Start the sender and getter at the same time. *) let sender = send Lwt_io.write pr text in let getter = recv pr in try_lwt (* Wait for both to terminate, returning the result of the getter. *) sender >> getter with Lwt.Canceled as exn -> (* Cancel the getter if the sender was canceled. *) Lwt.cancel getter; raise_lwt exn let pmap_chars ?timeout ?env ?stderr cmd chars = let pr = open_process ?timeout ?env ?stderr cmd in let sender = send Lwt_io.write_chars pr chars in monitor sender (recv_chars pr) let pmap_line ?timeout ?env ?stderr cmd line = let pr = open_process ?timeout ?env ?stderr cmd in (* Start the sender and getter at the same time. *) let sender = send Lwt_io.write_line pr line in let getter = recv_line pr in try_lwt (* Wait for both to terminate, returning the result of the getter. *) sender >> getter with Lwt.Canceled as exn -> (* Cancel the getter if the sender was canceled. *) Lwt.cancel getter; raise_lwt exn let pmap_lines ?timeout ?env ?stderr cmd lines = let pr = open_process ?timeout ?env ?stderr cmd in let sender = send Lwt_io.write_lines pr lines in monitor sender (recv_lines pr) lwt-2.4.3/src/unix/lwt_main.mli0000644000000000000000000000457612067037505014624 0ustar0000000000000000(* 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]*) lwt-2.4.3/src/unix/lwt_main.ml0000644000000000000000000000443312067037505014443 0ustar0000000000000000(* 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 () = add_task_r yielded 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) lwt-2.4.3/src/unix/lwt_log_rules.mll0000644000000000000000000000310312067037505015657 0ustar0000000000000000(* 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 (); [] } lwt-2.4.3/src/unix/lwt_log_rules.mli0000644000000000000000000000215412067037505015661 0ustar0000000000000000(* 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] *) lwt-2.4.3/src/unix/lwt_log.mli0000644000000000000000000003467612067037505014465 0ustar0000000000000000(* 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 *) val ign_log : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> level : level -> string -> unit (** Same as {!log} but ignore the resulting thread. *) val ign_log_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> level : level -> ('a, unit, string, unit) format4 -> 'a (** Same as {!log_f} but ignore the resulting thread. *) (** 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 ign_debug : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_debug_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) 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 ign_info : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_info_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) 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 ign_notice : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_notice_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) 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 ign_warning : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_warning_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) 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 ign_error : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_error_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) 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 val ign_fatal : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_fatal_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) 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)"] *) lwt-2.4.3/src/unix/lwt_log.ml0000644000000000000000000005071512067037505014304 0ustar0000000000000000(* 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.eprintf ("%s: Lwt_log: " ^^ fmt ^^ "\n%!") program_name (* +-----------------------------------------------------------------+ | 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 ign_log ?exn ?section ?location ?logger ~level message = try ignore (log ?exn ?section ?location ?logger ~level message) with _ -> () let ign_log_f ?exn ?section ?location ?logger ~level format = Printf.ksprintf (ign_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 let ign_debug ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Debug msg let ign_debug_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_debug ?exn ?section ?location ?logger) fmt let ign_info ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Info msg let ign_info_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_info ?exn ?section ?location ?logger) fmt let ign_notice ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Notice msg let ign_notice_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_notice ?exn ?section ?location ?logger) fmt let ign_warning ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Warning msg let ign_warning_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_warning ?exn ?section ?location ?logger) fmt let ign_error ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Error msg let ign_error_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_error ?exn ?section ?location ?logger) fmt let ign_fatal ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Fatal msg let ign_fatal_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_fatal ?exn ?section ?location ?logger) fmt lwt-2.4.3/src/unix/lwt_libev_stubs.c0000644000000000000000000001542012067037505015650 0ustar0000000000000000/* 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 }; /* Do nothing. We replace the invoke_pending callback of the event loop, so when events are ready, they can be executed after ev_loop has returned: it is executed in a blocking section and callbacks must be executed outside. */ static void nop(struct ev_loop *loop) { } CAMLprim value lwt_libev_init() { struct ev_loop *loop = ev_loop_new(EVFLAG_FORKCHECK); if (!loop) caml_failwith("lwt_libev_init"); /* Remove the invoke_pending callback. */ ev_set_invoke_pending_cb(loop, nop); 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; } CAMLprim value lwt_libev_loop(value val_loop, value val_block) { struct ev_loop *loop = Ev_loop_val(val_loop); /* Call the event loop inside a blocking section. */ caml_enter_blocking_section(); ev_loop(loop, Bool_val(val_block) ? EVLOOP_ONESHOT : EVLOOP_ONESHOT | EVLOOP_NONBLOCK); caml_leave_blocking_section(); /* Invoke callbacks now, i.e. outside the blocking section. */ ev_invoke_pending(loop); 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) { 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) { CAMLparam2(loop, 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); CAMLreturn(Val_unit); } /* +-----------------------------------------------------------------+ | Timer watchers | +-----------------------------------------------------------------+ */ static void handle_timer(struct ev_loop *loop, ev_timer *watcher, int revents) { caml_callback((value)watcher->data, Val_unit); } CAMLprim value lwt_libev_timer_init(value loop, value delay, value repeat, value callback) { CAMLparam4(loop, delay, repeat, 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) { CAMLparam2(loop, 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); CAMLreturn(Val_unit); } #endif lwt-2.4.3/src/unix/lwt_io.mli0000644000000000000000000004376212067037505014307 0ustar0000000000000000(* 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 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 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 *) lwt-2.4.3/src/unix/lwt_io.ml0000644000000000000000000013702212067037505014127 0ustar0000000000000000(* 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 -> lwt () = add_task_r wrapper.queued 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 -> lwt () = add_task_r wrapper.queued 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 lwt-2.4.3/src/unix/lwt_gc.mli0000644000000000000000000000316512067037505014262 0ustar0000000000000000(* 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] ensures [f x] is evaluated after [x] has been garbage collected. If [f x] yields, then Lwt will waits for its termination at the end of the program. Note that [f x] is not called at garbage collection time, but latter in the main loop. *) 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. *) lwt-2.4.3/src/unix/lwt_gc.ml0000644000000000000000000000566212067037505014115 0ustar0000000000000000(* 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_unit) end let finaliser f = (* In order not to create a reference to the value in the notification callback, we use an initially unset option cell which will be filled when the finaliser is called. *) let opt = ref None in let id = Lwt_unix.make_notification ~once:true (fun () -> match !opt with | None -> assert false | Some x -> opt := None; ensure_termination (f x)) in (* The real finaliser: fill the cell and send a notification. *) (fun x -> opt := Some x; Lwt_unix.send_notification id) let finalise f x = Gc.finalise (finaliser f) x (* Exit hook for a finalise_or_exit *) let foe_exit f called weak () = match Weak.get weak 0 with | None -> (* The value has been garbage collected, normally this point is never reached *) Lwt.return_unit | Some x -> (* Just to avoid double finalisation *) Weak.set weak 0 None; if !called then Lwt.return_unit else begin called := true; f x end (* Finaliser for a finalise_or_exit *) let foe_finaliser f called hook = finaliser (fun x -> (* Remove the exit hook, it is not needed anymore. *) Lwt_sequence.remove hook; (* Call the real finaliser. *) if !called then Lwt.return_unit else begin called := true; f x end) let finalise_or_exit f x = (* Create a weak pointer, so the exit-hook does not keep a reference to [x]. *) let weak = Weak.create 1 in Weak.set weak 0 (Some x); let called = ref false in let hook = Lwt_sequence.add_l (foe_exit f called weak) Lwt_main.exit_hooks in Gc.finalise (foe_finaliser f called hook) x lwt-2.4.3/src/unix/lwt_engine.mli0000644000000000000000000001521712067037505015137 0ustar0000000000000000(* 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. *) lwt-2.4.3/src/unix/lwt_engine.ml0000644000000000000000000003444012067037505014765 0ustar0000000000000000(* 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 lwt-2.4.3/src/unix/lwt_daemon.mli0000644000000000000000000000623312067037505015133 0ustar0000000000000000(* 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]. *) lwt-2.4.3/src/unix/lwt_daemon.ml0000644000000000000000000000522312067037505014760 0ustar0000000000000000(* 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 lwt-2.4.3/src/unix/lwt_chan.mli0000644000000000000000000000643412067037505014604 0ustar0000000000000000(* 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 lwt-2.4.3/src/unix/lwt_chan.ml0000644000000000000000000000550012067037505014424 0ustar0000000000000000(* 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 lwt-2.4.3/src/unix/lwt_bytes.mli0000644000000000000000000001471212067037505015017 0ustar0000000000000000(* 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. *) lwt-2.4.3/src/unix/lwt_bytes.ml0000644000000000000000000002367012067037505014651 0ustar0000000000000000(* 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 -> int job = "lwt_unix_bytes_read_job" 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 run_job (read_job (unix_file_descr fd) buf pos len) | 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 -> int job = "lwt_unix_bytes_write_job" 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 run_job (write_job (unix_file_descr fd) buf pos len) | 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 -> unit job = "lwt_unix_wait_mincore_job" 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 run_job (wait_mincore_job buffer offset) end #endif lwt-2.4.3/src/unix/gen_stubs.ml0000644000000000000000000006461212067037505014627 0ustar0000000000000000(* Lightweight thread library for Objective Caml * http://www.ocsigen.org/lwt * * Copyright (C) 2012 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. *) (* Script for generating C stubs for jobs. *) open Printf module StringMap = Map.Make(String) module StringSet = Set.Make(String) (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) (* Kind of caml values. *) type value_repr = | Val_int | Val_string | Val_block | Val_custom of string type caml_type = | Caml_void | Caml_int | Caml_int32 | Caml_int64 | Caml_bool | Caml_char | Caml_string | Caml_bytes | Caml_tuple of caml_type list | Caml_record of string * (string * caml_type) list | Caml_variant of string * (string * caml_type list) list | Caml_alias of string * caml_type | Caml_list of caml_type type c_type = | C_void | C_char | C_int | C_long | C_int_alias of string | C_long_alias of string | C_ptr of c_type | C_array of c_type * int | C_dyn_array of c_type type hint = | Hint_none | Hint_flag_list of (constructor_map * string option) list | Hint_table of (constructor_map * string option) list and constructor_map = | S of string | D of string * string type direction = | In | Out | In_out type abstract_type = { caml_type : caml_type; c_type : c_type; hint : hint; } type unix_error = | Uerror_errno | Uerror_result | Uerror_none type job = { includes : string list; name : string; params : (string * direction * abstract_type) list; result : abstract_type; uerror : unix_error; check : string option; exists_if : (bool * string) list; map64 : string list; } (* +-----------------------------------------------------------------+ | Configuration | +-----------------------------------------------------------------+ *) let ocaml_version = Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> (major, minor)) let prog_name = Filename.basename Sys.argv.(0) let log fmt = ksprintf (fun msg -> prerr_endline (prog_name ^ ": " ^ msg)) fmt (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) let unit = { c_type = C_int; caml_type = Caml_void; hint = Hint_none } let int = { c_type = C_int; caml_type = Caml_int; hint = Hint_none } let int32 = { c_type = C_int; caml_type = Caml_int32; hint = Hint_none } let int64 c_type = { c_type = c_type; caml_type = Caml_int64; hint = Hint_none } let long = { c_type = C_long; caml_type = Caml_int; hint = Hint_none } let char = { c_type = C_int; caml_type = Caml_char; hint = Hint_none } let string = { c_type = C_ptr C_char; caml_type = Caml_string; hint = Hint_none } let bool = { c_type = C_int; caml_type = Caml_bool; hint = Hint_none } let file_descr = { int with caml_type = Caml_alias ("Unix.file_descr", Caml_int) } let off_t = { long with c_type = C_long_alias "off_t" } let flag_list name c_type l = { c_type = c_type; caml_type = Caml_list (Caml_variant (name, List.map (function (S name, _) -> (name, []) | (D (name, _), _) -> (name, [])) l)); hint = Hint_flag_list l; } let table name c_type l = { c_type = c_type; caml_type = Caml_variant (name, List.map (function (S name, _) -> (name, []) | (D (name, _), _) -> (name, [])) l); hint = Hint_table l; } let filter_fst l = List.map snd (List.filter fst l) let open_flag = flag_list "Unix.open_flag" C_int (filter_fst [ true, (S "O_RDONLY", None); true, (S "O_WRONLY", None); true, (S "O_RDWR", None); true, (S "O_NONBLOCK", Some "O_NDELAY"); true, (S "O_APPEND", None); true, (S "O_CREAT", None); true, (S "O_TRUNC", None); true, (S "O_EXCL", None); true, (S "O_NOCTTY", None); true, (S "O_DSYNC", Some "0"); true, (S "O_SYNC", Some "0"); true, (S "O_RSYNC", Some "0"); ocaml_version >= (3, 13) , (S "O_SHARE_DELETE", None); ]) let access_permission = flag_list "Unix.access_permission" C_int [ S "R_OK", None; S "W_OK", None; S "X_OK", None; S "F_OK", None; ] let seek_command = table "Unix.seek_command" C_int [ S "SEEK_SET", None; S "SEEK_CUR", None; S "SEEK_END", None; ] let flush_queue = table "Unix.flush_queue" C_int [ S "TCIFLUSH", None; S "TCOFLUSH", None; S "TCIOFLUSH", None; ] let flow_action = table "Unix.flow_action" C_int [ S "TCOOFF", None; S "TCOON", None; S "TCIOFF", None; S "TCION", None; ] (* +-----------------------------------------------------------------+ | Jobs | +-----------------------------------------------------------------+ *) let simple_unit includes name args = { includes = includes; name = name; params = List.map (fun (name, a_type) -> (name, In, a_type)) args; result = { int with caml_type = Caml_void }; uerror = Uerror_errno; check = Some "$(result) < 0"; exists_if = []; map64 = []; } type item = | Job of job | Seq of item list let rec map_jobs f item = match item with | Job job -> f job | Seq l -> Seq (List.map (map_jobs f) l) let path_and_fd = map_jobs (fun job -> if List.exists (fun (name, _, _) -> name = "path") job.params then Seq [ Job job; Job { job with name = "f" ^ job.name; params = List.map (fun ((name, _, _) as param) -> if name = "path" then ("fd", In, file_descr) else param) job.params; }; ] else Job job) let jobs = Seq [ Job (simple_unit ["unistd"] "close" [("fd", file_descr)]); Job (simple_unit ["unistd"] "unlink" [("path", string)]); Job (simple_unit ["unistd"] "chroot" [("path", string)]); Job (simple_unit ["unistd"] "rmdir" [("path", string)]); Job (simple_unit ["unistd"] "chdir" [("path", string)]); path_and_fd (Job (simple_unit ["sys/stat"] "chmod" [("path", string); ("mode", int)])); path_and_fd (Job { (simple_unit ["unistd"; "sys/types"] "truncate" [("path", string); ("offset", off_t)]) with map64 = ["offset"] }); path_and_fd (Job (simple_unit ["unistd"] "chown" [("path", string); ("ower", int); ("group", int)])); Job (simple_unit ["stdio"] "rename" [("oldpath", string); ("newpath", string)]); Job (simple_unit ["unistd"] "link" [("oldpath", string); ("newpath", string)]); Job (simple_unit ["unistd"] "symlink" [("oldpath", string); ("newpath", string)]); Job (simple_unit ["sys/stat"; "sys/types"] "mkdir" [("path", string); ("mode", int)]); Job (simple_unit ["sys/stat"; "sys/types"] "mkfifo" [("path", string); ("mode", int)]); Job (simple_unit ["unistd"] "access" [("path", string); ("mode", access_permission)]); Job (simple_unit ["unistd"] "fsync" [("fd", file_descr)]); Job { (simple_unit ["unistd"] "fdatasync" [("fd", file_descr)]) with exists_if = [(true, "HAVE_FDATASYNC")] }; Job { (simple_unit ["sys/types"; "unistd"] "lseek" [("fd", file_descr); ("offset", off_t); ("whence", seek_command)]) with result = off_t; check = Some "$(result) == (off_t)-1"; map64 = ["offset"; "result"]; }; Job (simple_unit ["termios"; "unistd"] "tcdrain" [("fd", file_descr)]); Job (simple_unit ["termios"; "unistd"] "tcflush" [("fd", file_descr); ("queue", flush_queue)]); Job (simple_unit ["termios"; "unistd"] "tcflow" [("fd", file_descr); ("action", flow_action)]); Job (simple_unit ["termios"; "unistd"] "tcsendbreak" [("fd", file_descr); ("duration", int)]); ] (* +-----------------------------------------------------------------+ | Code generation | +-----------------------------------------------------------------+ *) let rec c_type_name = function | C_void -> "void" | C_int -> "int" | C_long -> "long" | C_int_alias name -> name | C_long_alias name -> name | C_char -> "char" | C_ptr t -> c_type_name t ^ "*" | C_array (t, n) -> c_type_name t ^ "[" ^ string_of_int n ^ "]" | C_dyn_array t -> c_type_name t ^ "[]" let rec caml_type_name = function | Caml_void -> "" | Caml_int -> "int" | Caml_int32 -> "int32" | Caml_int64 -> "int64" | Caml_bool -> "bool" | Caml_char -> "char" | Caml_string -> "string" | Caml_bytes -> "Lwt_bytes.t" | Caml_tuple l -> String.concat " * " (List.map caml_type_name l) | Caml_record (name, _) -> name | Caml_variant (name, _) -> name | Caml_alias (name, _) -> name | Caml_list (Caml_tuple _ as ty) -> sprintf "(%s) list" (caml_type_name ty) | Caml_list ty -> sprintf "%s list" (caml_type_name ty) let rec real_caml_type = function | Caml_alias (_, t) -> real_caml_type t | t -> t let string_of_direction = function | In -> "in" | Out -> "out" | In_out -> "in & out" let subst job patt = let buf = Buffer.create 128 in Buffer.add_substitute buf (fun var -> if job then "job->" ^ var else var) patt; Buffer.contents buf let rec find_map f l = match l with | [] -> raise Not_found | x :: l -> match f x with | Some x -> x | None -> find_map f l let split_name name = try let idx = String.rindex name '.' in (String.sub name 0 idx, String.sub name (idx + 1) (String.length name - idx - 1)) with Not_found -> ("", name) let ml_oc = ref stdout module type Params = sig val fname : string val oc : out_channel val job : job end module type Generator = sig val gen_worker : string -> unit val gen_result : string -> unit val gen_job_stub : string -> string -> string -> unit val gen_caml : string -> unit val gen_file : unit -> unit end module MakeGen(Gen64 : Generator)(Params : Params) = struct open Params let map_in_64 = List.exists (fun name -> List.exists (fun (name', dir, _) -> name = name' && dir = In) job.params) job.map64 let map_out_64 = List.exists (fun name -> List.exists (fun (name', dir, _) -> name = name' && dir = Out) job.params) job.map64 let map_result_64 = List.mem "result" job.map64 let pr fmt = fprintf oc fmt let ins = List.filter (fun (_, dir, { caml_type }) -> (dir = In || dir = In_out) && caml_type <> Caml_void) job.params let strings = List.map (fun (name, _, _) -> name) (List.filter (fun (_, dir, { caml_type }) -> dir = In && caml_type = Caml_string) job.params) let caml_return_type, is_tuple = match job.result.caml_type with | Caml_void -> ("unit", false) | Caml_tuple _ as t -> (caml_type_name t, true) | t -> (caml_type_name t, false) let caml_arg_types = String.concat " -> " (match List.map (fun (_, _, { caml_type }) -> caml_type_name caml_type) (List.filter (fun (_, dir, { caml_type }) -> dir = In && caml_type <> Caml_void) job.params) with | [] -> ["unit"] | l -> l) let gen_worker suffix = pr "\n"; pr "/* The function calling [%s]. */\n" job.name; pr "static void worker_%s%s(struct job_%s* job)\n" job.name suffix job.name; pr "{\n"; pr " /* Perform the blocking call. */\n"; pr " "; if job.result.c_type <> C_void then pr "job->result = "; pr "%s(%s);\n" job.name (String.concat ", " (List.map (fun (name, dir, _) -> match dir with | In -> "job->" ^ name | Out | In_out -> "&job->" ^ name) job.params)); if job.uerror = Uerror_errno then begin pr " /* Save the value of errno. */\n"; pr " job->errno_copy = errno;\n" end; pr "}\n" let gen_result suffix = pr "\n"; pr "/* The function building the caml result. */\n"; pr "static value result_%s%s(struct job_%s* job)\n" job.name suffix job.name; pr "{\n"; if job.result.caml_type <> Caml_void then pr " value result;\n"; (match job.check with | None -> () | Some test -> pr " /* Check for errors. */\n"; pr " if (%s) {\n" (subst true test); pr " /* Save the value of errno so we can use it once the job has been freed. */\n"; pr " int error = job->errno_copy;\n"; (match strings with | [] -> () | name :: _ -> pr " /* Copy the contents of job->%s into a caml string. */\n" name; pr " value string_argument = caml_copy_string(job->%s);\n" name); pr " /* Free the job structure. */\n"; pr " lwt_unix_free_job(&job->job);\n"; pr " /* Raise the error. */\n"; (match strings with | [] -> pr " unix_error(error, %S, Nothing);\n" job.name | name :: _ -> pr " unix_error(error, %S, string_argument);\n" job.name); pr " }\n"); if job.result.caml_type <> Caml_void then begin pr " /* Build the caml result. */\n"; match job.result.caml_type, job.result.c_type with | Caml_int, (C_int | C_int_alias _) -> pr " result = Val_int(job->result);\n" | Caml_int, (C_long | C_long_alias _) -> pr " result = Val_long(job->result);\n" | Caml_int64, (C_long | C_long_alias _) -> pr " result = caml_copy_int64(job->result);\n" | _ -> assert false end; pr " /* Free the job structure. */\n"; pr " lwt_unix_free_job(&job->job);\n"; pr " /* Return the result. */\n"; if job.result.caml_type = Caml_void then pr " return Val_unit;\n" else pr " return result;\n"; pr "}\n" let gen_job_stub suffix worker_suffix result_suffix = pr "\n"; pr "/* The stub creating the job structure. */\n"; pr "CAMLprim value lwt_unix_%s%s_job(%s)\n" job.name suffix (String.concat ", " (List.map (fun (name, _, _) -> "value " ^ name) ins)); pr "{\n"; List.iter (fun name -> pr " /* Get the length of the %s parameter. */\n" name; pr " mlsize_t len_%s = caml_string_length(%s) + 1;\n" name name) strings; pr " /* Allocate a new job. */\n"; if strings = [] then pr " struct job_%s* job = lwt_unix_new(struct job_%s);\n" job.name job.name else pr " struct job_%s* job = lwt_unix_new_plus(struct job_%s, %s);\n" job.name job.name (String.concat " + " (List.map (fun name -> "len_" ^ name) strings)); let rec loop = function | [] -> () | name :: names -> loop names; pr " /* Set the offset of the %s parameter inside the job structure. */\n" name; pr " job->%s = %s;\n" name (String.concat " + " ("job->data" :: List.map (fun n -> "len_" ^ n) names)) in loop (List.rev strings); List.iter (fun name -> pr " /* Copy the %s parameter inside the job structure. */\n" name; pr " memcpy(job->%s, String_val(%s), len_%s);\n" name name name) strings; pr " /* Initializes function fields. */\n"; pr " job->job.worker = (lwt_unix_job_worker)worker_%s%s;\n" job.name worker_suffix; pr " job->job.result = (lwt_unix_job_result)result_%s%s;\n" job.name result_suffix; List.iter (fun (name, dir, { caml_type; c_type; hint }) -> if caml_type <> Caml_string then begin pr " /* Copy the %s parameter. */\n" name; pr " job->%s = " name; (match real_caml_type caml_type, c_type, hint with | Caml_int, (C_int | C_int_alias _), _ -> pr "Int_val(%s)" name | Caml_int, (C_long | C_long_alias _), _ -> pr "Long_val(%s)" name | Caml_int64, (C_long | C_long_alias _), _ -> pr "Int64_val(%s)" name | Caml_list (Caml_variant (type_name, _)), _, Hint_flag_list _ -> pr "%s_of_%ss(%s)" (c_type_name c_type) (snd (split_name type_name)) name | Caml_variant (type_name, _), _, Hint_table _ -> pr "%s_table[Int_val(%s)]" (snd (split_name type_name)) name | _ -> assert false); pr ";\n" end) ins; pr " /* Wrap the structure into a caml value. */\n"; pr " return lwt_unix_alloc_job(&job->job);\n"; pr "}\n" let gen_caml suffix = let pr fmt = fprintf !ml_oc fmt in pr " external %s%s_job : %s -> %s Job.t = \"lwt_unix_%s%s_job\"\n" job.name suffix caml_arg_types (if is_tuple then "(" ^ caml_return_type ^ ")" else caml_return_type) job.name suffix let gen_file () = pr "\ /* * %s * %s * * File generated with %s */ /* Note: this file was generated at configure time. If it does not work and you want to fix it, you can modify it and send the result to the ocsigen mailing list. If you are courageous you can also look at the ocaml script that generated this file (%s). */ /* Informations: - this is the expected prototype of the C function [%s]: %s %s(%s) - these are the expected ocaml externals for this job: external %s_job : %s -> %s Lwt_unix.job = \"lwt_unix_%s_job\" external %s_sync : %s -> %s = \"lwt_unix_%s_sync\" */ " fname (String.make (String.length fname) '-') prog_name Sys.argv.(0) job.name (c_type_name job.result.c_type) job.name (String.concat ", " (List.map (fun (name, dir, { c_type }) -> match dir with | In -> c_type_name c_type ^ " " ^ name | In_out | Out -> c_type_name (C_ptr c_type) ^ " " ^ name) job.params)) job.name caml_arg_types (if is_tuple then "(" ^ caml_return_type ^ ")" else caml_return_type) job.name job.name caml_arg_types caml_return_type job.name; pr "\n"; pr "/* Caml headers. */\n"; pr "#include \n"; List.iter (pr "#include \n") ["memory"; "alloc"; "fail"; "signals"]; let exists_if = String.concat " && " (List.map (fun (yes, var) -> if yes then sprintf "defined(%s)" var else sprintf "!defined(%s)" var) job.exists_if) in if job.exists_if <> [] then pr "\n#if %s\n" exists_if; pr "\n"; pr "/* Specific headers. */\n"; pr "#include \n"; pr "#include \n"; List.iter (pr "#include <%s.h>\n") job.includes; let converters = List.filter (fun (name, _, { hint }) -> hint <> Hint_none) job.params in if converters <> [] then begin pr " /* +-----------------------------------------------------------------+ | Converters | +-----------------------------------------------------------------+ */ "; List.iter (fun (name, _, atype) -> match atype.hint with | Hint_none -> () | Hint_flag_list mapping | Hint_table mapping -> let name, cstrs = match atype.caml_type with | Caml_list (Caml_variant (name, cstrs)) | Caml_variant (name, cstrs) -> (name, cstrs) | _ -> assert false in let path, item = split_name name in pr "\n"; pr "/* Table mapping constructors of ocaml type %s to C values. */\n" name; pr "static %s %s_table[] = {\n" (c_type_name atype.c_type) item; let rec loop l = match l with | [] -> () | (cstr, typ) :: l -> assert (typ = []); pr " /* Constructor %s. */\n" cstr; pr " %s" (find_map (function | (S name, _) when name = cstr -> Some name | (D (name, name'), _) when name = cstr -> Some name' | _ -> None) mapping); if l = [] then pr "\n" else begin pr ",\n"; loop l end in loop cstrs; pr "};\n"; if (match atype.hint with Hint_flag_list _ -> true | _ -> false) then begin pr "\n"; pr "/* Convert ocaml values of type %s to a C %s. */\n" name (c_type_name atype.c_type); pr "static %s %s_of_%ss(value list)\n" (c_type_name atype.c_type) (c_type_name atype.c_type) item; pr "{\n"; pr " %s result = 0;\n" (c_type_name atype.c_type); pr " while (Is_block(list)) {\n"; pr " result |= %s_table[Int_val(Field(list, 0))];\n" item; pr " list = Field(list, 1);\n"; pr " };\n"; pr " return result;\n"; pr "}\n"; end) converters end; pr " /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ "; pr "\n"; pr "/* Structure holding informations for calling [%s]. */\n" job.name; pr "struct job_%s {\n" job.name; pr " /* Informations used by lwt. It must be the first field of the structure. */\n"; pr " struct lwt_unix_job job;\n"; if job.result.c_type <> C_void then begin pr " /* This field store the result of the call. */\n"; pr " %s result;\n" (c_type_name job.result.c_type) end; if job.uerror = Uerror_errno then begin pr " /* This field store the value of [errno] after the call. */\n"; pr " int errno_copy;\n" end; List.iter (fun (name, dir, { c_type }) -> pr " /* %s parameter. */\n" (string_of_direction dir); pr " %s %s;\n" (c_type_name c_type) name) job.params; if strings <> [] then begin pr " /* Buffer for string parameters. */\n"; pr " char data[];\n" end; pr "};\n"; gen_worker ""; gen_result ""; if map_out_64 || map_result_64 then Gen64.gen_result "_64"; gen_job_stub "" "" ""; if map_in_64 || map_out_64 || map_result_64 then Gen64.gen_job_stub "_64" "" (if map_out_64 || map_result_64 then "_64" else ""); if job.exists_if <> [] then begin pr "\n"; (* XXX: hack for fsync *) if job.name <> "fsync" then begin pr "#else /* %s */\n" exists_if; pr "\n"; pr "CAMLprim value lwt_unix_%s_job()\n" job.name; pr "{\n"; pr " lwt_unix_not_available(%S);\n" job.name; pr " return Val_unit;\n"; pr "}\n"; pr "\n"; if map_in_64 || map_out_64 || map_result_64 then begin pr "CAMLprim value lwt_unix_%s_64_job()\n" job.name; pr "{\n"; pr " lwt_unix_not_available(%S);\n" job.name; pr " return Val_unit;\n"; pr "}\n"; pr "\n"; end; end; pr "#endif /* %s */\n" exists_if end; gen_caml ""; if map_in_64 || map_out_64 || map_result_64 then Gen64.gen_caml "_64" end module GenFake = struct let gen_worker _ = assert false let gen_result _ = assert false let gen_job_stub _ _ _ = assert false let gen_sync_stub _ = assert false let gen_file _ = assert false let gen_caml _ = assert false end let gen job = let fname = "lwt_unix_job_" ^ job.name ^ ".c" in let oc = open_out ("src/unix/jobs-unix/" ^ fname) in let job64 = { job with params = ( List.map (fun (name, dir, atype) -> if List.mem name job.map64 then (name, dir, { atype with caml_type = Caml_int64 }) else (name, dir, atype)) job.params ); result = if List.mem "result" job.map64 then { job.result with caml_type = Caml_int64 } else job.result; } in let module Gen64 = MakeGen(GenFake)(struct let fname = fname let oc = oc let job = job64 end) in let module Gen = MakeGen(Gen64)(struct let fname = fname let oc = oc let job = job end) in Gen.gen_file (); close_out oc let rec collect_jobs map = function | Job job -> if StringMap.mem job.name map then begin log "job '%s' is defined two times" job.name; exit 1 end; StringMap.add job.name { job with exists_if = (false, "LWT_ON_WINDOWS") :: job.exists_if } map | Seq l -> List.fold_left collect_jobs map l let jobs = collect_jobs StringMap.empty jobs let () = match Sys.argv with | [|_|] -> let fname = "lwt_unix_jobs_generated.ml" in ml_oc := open_out ("src/unix/" ^ fname); let pr_header oc fname = fprintf oc "\ (* * %s * %s * * File generated with %s *) module type Job = sig type 'a t end " fname (String.make (String.length fname) '-') prog_name; in pr_header !ml_oc fname; fprintf !ml_oc "\ module Make(Job : Job) = struct "; StringMap.iter (fun name job -> gen job) jobs; output_string !ml_oc "end\n"; close_out !ml_oc | [|_; "list-job-files"|] -> StringMap.iter (fun name job -> printf "src/unix/jobs-unix/lwt_unix_job_%s.c\n" name) jobs | [|_; "list-job-names"|] -> StringMap.iter (fun name job -> printf "%s\n" name) jobs | _ -> log "invalid arguments"; eprintf "usage: %s [list-job-files|list-job-names]\n" prog_name; exit 2 lwt-2.4.3/src/unix/jobs-unix/0000755000000000000000000000000012067037505014211 5ustar0000000000000000lwt-2.4.3/src/unix/jobs-unix/.keepme0000644000000000000000000000000012067037505015446 0ustar0000000000000000lwt-2.4.3/src/top/0000755000000000000000000000000012067037511012107 5ustar0000000000000000lwt-2.4.3/src/top/lwt-top.mllib0000644000000000000000000000016112067037511014534 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 6aba40695d6f4091d2063c4b620ae589) Lwt_top Lwt_ocaml_completion # OASIS_STOP lwt-2.4.3/src/top/toplevel_temp.mltop0000644000000000000000000000015312067037505016045 0ustar0000000000000000# This file is used to generate "toplevel_temp.top", which is then # expunged into "lwt-toplevel" Toplevel lwt-2.4.3/src/top/toplevel.ml0000644000000000000000000001305112067037505014276 0ustar0000000000000000(* 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 #if ocaml_version >= (4, 0) (* 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 | Mty_signature decls -> List.fold_left (fun acc decl -> match decl with | Sig_value(id, _) | Sig_type(id, _, _) | Sig_exception(id, _) | Sig_module(id, _, _) | Sig_modtype(id, _) | Sig_class(id, _, _) | Sig_class_type(id, _, _) -> TextSet.add (Ident.name id) acc) TextSet.empty decls | _ -> TextSet.empty with Not_found -> TextSet.empty #else (* 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 #endif 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 lwt-2.4.3/src/top/lwt_top.mli0000644000000000000000000000224612067037505014311 0ustar0000000000000000(* 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 *) lwt-2.4.3/src/top/lwt_top.ml0000644000000000000000000001222412067037505014135 0ustar0000000000000000(* 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; lwt-2.4.3/src/top/lwt_ocaml_completion.mll0000644000000000000000000001707412067037505017043 0ustar0000000000000000(* 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 } } lwt-2.4.3/src/text/0000755000000000000000000000000012067037511012271 5ustar0000000000000000lwt-2.4.3/src/text/lwt-text.mllib0000644000000000000000000000016412067037511015103 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 445f786e72bdc58b36891d69973effc4) Lwt_text Lwt_term Lwt_read_line # OASIS_STOP lwt-2.4.3/src/text/liblwt-text_stubs.clib0000644000000000000000000000014512067037511016623 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 49d58712acb378a903b0dfd06803031a) lwt_text_stubs.o # OASIS_STOP lwt-2.4.3/src/text/lwt_text_stubs.c0000644000000000000000000000436412067037505015541 0ustar0000000000000000/* 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. */ #include #if defined(LWT_ON_WINDOWS) # include # include #else # include # include # include # include #endif #include #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 lwt-2.4.3/src/text/lwt_text.mli0000644000000000000000000001143112067037505014651 0ustar0000000000000000(* 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 lwt-2.4.3/src/text/lwt_text.ml0000644000000000000000000002630212067037505014503 0ustar0000000000000000(* 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) lwt-2.4.3/src/text/lwt_term.mli0000644000000000000000000003256712067037505014651 0ustar0000000000000000(* 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 lwt-2.4.3/src/text/lwt_term.ml0000644000000000000000000005214212067037505014467 0ustar0000000000000000(* 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. *) #include "src/unix/lwt_config.ml" 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 lwt-2.4.3/src/text/lwt_read_line.mli0000644000000000000000000003351312067037505015614 0ustar0000000000000000(* 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 lwt-2.4.3/src/text/lwt_read_line.ml0000644000000000000000000016152312067037505015446 0ustar0000000000000000(* 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)))) lwt-2.4.3/src/ssl/0000755000000000000000000000000012067037511012106 5ustar0000000000000000lwt-2.4.3/src/ssl/lwt-ssl.mllib0000644000000000000000000000013412067037511014532 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: ab07ef30d9c1dd9dd2a1f2eef22e9d68) Lwt_ssl # OASIS_STOP lwt-2.4.3/src/ssl/lwt_ssl.mli0000644000000000000000000000446012067037505014307 0ustar0000000000000000(* 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 (** Wrapper for SSL sockets. It is either a plain socket, either a real SSL socket. *) val ssl_socket : socket -> Ssl.socket option (** Returns the underlying SSL socket used for this wrapper. If it is a plain socket it returns [None]. *) 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 lwt-2.4.3/src/ssl/lwt_ssl.ml0000644000000000000000000001200012067037505014123 0ustar0000000000000000(* 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. *) let (>>=) = Lwt.bind type t = Plain | SSL of Ssl.socket type socket = Lwt_unix.file_descr * t let ssl_socket (fd, kind) = match kind with | Plain -> None | SSL socket -> Some socket 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 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 shutdown_and_close s = ssl_shutdown s >>= fun () -> Lwt.wrap2 shutdown s Unix.SHUTDOWN_ALL >>= fun () -> close s let out_channel_of_descr s = Lwt_io.make ~mode:Lwt_io.output ~close:(fun () -> shutdown_and_close s) (fun buf pos len -> write_bytes s buf pos len) let in_channel_of_descr s = Lwt_io.make ~mode:Lwt_io.input ~close:(fun () -> shutdown_and_close s) (fun buf pos len -> read_bytes s buf pos len) 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) lwt-2.4.3/src/simple_top/0000755000000000000000000000000012067037511013460 5ustar0000000000000000lwt-2.4.3/src/simple_top/lwt-simple-top.mllib0000644000000000000000000000014312067037511017374 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: de6ce24e129acca71e8908d2344cd786) Lwt_simple_top # OASIS_STOP lwt-2.4.3/src/simple_top/lwt_simple_top.ml0000644000000000000000000000307412067037505017062 0ustar0000000000000000(* 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 lwt-2.4.3/src/react/0000755000000000000000000000000012067037511012403 5ustar0000000000000000lwt-2.4.3/src/react/lwt-react.mllib0000644000000000000000000000016312067037511015326 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 8916665f5b5252b5a633514708d91e4b) Lwt_event Lwt_signal Lwt_react # OASIS_STOP lwt-2.4.3/src/react/lwt_signal.mli0000644000000000000000000000656612067037505015271 0ustar0000000000000000(* 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 lwt-2.4.3/src/react/lwt_signal.ml0000644000000000000000000001471412067037505015112 0ustar0000000000000000(* 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. *) let (>>=) = Lwt.(>>=) include Lwt_react.S (* +-----------------------------------------------------------------+ | 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 (React.S.map f signal) notifiers let notify_p f signal = Lwt_sequence.add_l (React.S.map (fun x -> Lwt.async (fun () -> f x)) signal) notifiers let notify_s f signal = let mutex = Lwt_mutex.create () in Lwt_sequence.add_l (React.S.map (fun x -> Lwt.async (fun () -> 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 Lwt.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 () >>= fun () -> send1 (value signal); send2 (changes signal); React.E.stop event1; React.E.stop event2; Lwt.return_unit ); React.E.switch event1 event2 | None -> let event1, send1 = React.E.create () in let event2, send2 = React.E.create () in ignore ( thread >>= fun signal -> send1 (value signal); send2 (changes signal); React.E.stop event1; React.E.stop event2; Lwt.return_unit ); React.E.switch event1 event2 (* +-----------------------------------------------------------------+ | Signal transofrmations | +-----------------------------------------------------------------+ *) let run_s ?eq i s = let event, push = React.E.create () in let mutex = Lwt_mutex.create () in let iter = React.E.fmap (fun t -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> value s)) push; hold ?eq i (React.E.select [iter; event]) let map_s ?eq f i s = let event, push = React.E.create () in let mutex = Lwt_mutex.create () in let iter = React.E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f (value s))) push; hold ?eq i (React.E.select [iter; event]) let app_s ?eq sf i s = let event, push = React.E.create () in let mutex = Lwt_mutex.create () in let iter = React.E.fmap (fun (f, x) -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (React.E.app (React.E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s))) push; hold ?eq i (React.E.select [iter; event]) let filter_s ?eq f i s = let event, push = React.E.create () in let mutex = Lwt_mutex.create () in let iter = React.E.fmap (fun x -> Lwt.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.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function | true -> push x | false -> ()); hold ?eq i (React.E.select [iter; event]) let fmap_s ?eq f i s = let event, push = React.E.create () in let mutex = Lwt_mutex.create () in let iter = React.E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f (value s))) (function | Some x -> push x | None -> ()); hold ?eq i (React.E.select [iter; event]) let rec rev_fold f acc = function | [] -> Lwt.return acc | x :: l -> rev_fold f acc l >>= fun acc -> f acc x let merge_s ?eq f acc sl = let s = merge (fun acc x -> x :: acc) [] sl in let event, push = React.E.create () in let mutex = Lwt_mutex.create () in let iter = React.E.fmap (fun l -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s))) push; hold ?eq acc (React.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) lwt-2.4.3/src/react/lwt_react.mli0000644000000000000000000001437712067037505015111 0ustar0000000000000000(* * 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 time [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 lwt-2.4.3/src/react/lwt_react.ml0000644000000000000000000003136712067037505014736 0ustar0000000000000000(* * lwt_react.ml * ------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of lwt. *) let (>>=) = 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 Lwt.return_unit 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 Lwt.state !limiter = Lwt.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; Lwt.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 cancel_thread t () = Lwt.cancel t let from f = let event, push = create () in let rec loop () = f () >>= fun x -> push x; loop () in let t = Lwt.pause () >>= loop in with_finaliser (cancel_thread t) event let to_stream event = let stream, push, set_ref = Lwt_stream.create_with_reference () in set_ref (map (fun x -> push (Some x)) event); stream let of_stream stream = let event, push = create () in let t = Lwt.pause () >>= fun () -> Lwt_stream.iter push stream in with_finaliser (cancel_thread t) event let delay thread = match Lwt.poll thread with | Some e -> e | None -> let event, send = create () in Lwt.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 -> Lwt.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 -> Lwt.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 -> Lwt.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 -> Lwt.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) -> Lwt.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) -> Lwt.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 -> Lwt.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 -> Lwt.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 -> Lwt.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 -> Lwt.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; Lwt.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 -> Lwt.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 -> Lwt.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 | [] -> Lwt.return acc | x :: l -> rev_fold f acc l >>= fun acc -> 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 -> Lwt.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 Lwt.state !limiter = Lwt.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; Lwt.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 -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> value s) >>= fun x -> Lwt.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 -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x -> Lwt.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) -> Lwt.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_mutex.with_lock mutex (fun () -> (value sf) (value s)) >>= fun x -> Lwt.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 -> Lwt.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 -> Lwt.return (hold ?eq x (E.select [iter; event])) | false -> Lwt.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 -> Lwt.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 -> Lwt.return (hold ?eq x (E.select [iter; event])) | None -> Lwt.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; Lwt.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 | [] -> Lwt.return acc | x :: l -> rev_fold f acc l >>= fun acc -> 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 -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s)) >>= fun x -> Lwt.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 -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x -> Lwt.return (switch ?eq x (E.select [iter; event])) end lwt-2.4.3/src/react/lwt_event.mli0000644000000000000000000000477612067037505015136 0ustar0000000000000000(* 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 lwt-2.4.3/src/react/lwt_event.ml0000644000000000000000000000355212067037505014754 0ustar0000000000000000(* 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.async (fun () -> 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.async (fun () -> 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) lwt-2.4.3/src/preemptive/0000755000000000000000000000000012067037511013465 5ustar0000000000000000lwt-2.4.3/src/preemptive/lwt-preemptive.mllib0000644000000000000000000000014312067037511017470 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 7a98b43f4d640061bceed7638c0c7efd) Lwt_preemptive # OASIS_STOP lwt-2.4.3/src/preemptive/lwt_preemptive.mli0000644000000000000000000000561112067037505017244 0ustar0000000000000000(* 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 run_in_main : (unit -> 'a Lwt.t) -> 'a (** [run_in_main f] executes [f] in the main thread, i.e. the one executing {!Lwt_main.run} and returns its result. *) 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 lwt-2.4.3/src/preemptive/lwt_preemptive.ml0000644000000000000000000001612312067037505017073 0ustar0000000000000000(* 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 Lwt.add_task_r waiters (* +-----------------------------------------------------------------+ | 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 init_result = Lwt.make_error (Failure "Lwt_preemptive.detach") let detach f args = simple_init (); let result = ref init_result in (* The task for the worker thread: *) let task () = try result := Lwt.make_value (f args) with exn -> result := Lwt.make_error exn in lwt worker = get_worker () in let waiter, wakener = wait () in let id = Lwt_unix.make_notification ~once:true (fun () -> Lwt.wakeup_result wakener !result) 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 () (* +-----------------------------------------------------------------+ | Running Lwt threads in the main thread | +-----------------------------------------------------------------+ *) type 'a result = | Value of 'a | Error of exn (* Queue of [unit -> unit Lwt.t] functions. *) let jobs = Queue.create () (* Mutex to protect access to [jobs]. *) let jobs_mutex = Mutex.create () let job_notification = Lwt_unix.make_notification (fun () -> (* Take the first job. The queue is never empty at this point. *) Mutex.lock jobs_mutex; let thunk = Queue.take jobs in Mutex.unlock jobs_mutex; ignore (thunk ())) let run_in_main f = let channel = Event.new_channel () in (* Create the job. *) let job () = (* Execute [f] and wait for its result. *) lwt result = try_bind f (fun ret -> return (Value ret)) (fun exn -> return (Error exn)) in (* Send the result. *) Event.sync (Event.send channel result); return () in (* Add the job to the queue. *) Mutex.lock jobs_mutex; Queue.add job jobs; Mutex.unlock jobs_mutex; (* Notify the main thread. *) Lwt_unix.send_notification job_notification; (* Wait for the result. *) match Event.sync (Event.receive channel) with | Value ret -> ret | Error exn -> raise exn lwt-2.4.3/src/glib/0000755000000000000000000000000012067037511012222 5ustar0000000000000000lwt-2.4.3/src/glib/lwt-glib.mllib0000644000000000000000000000013512067037511014763 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: dfe8b7bfa132aa66ad19dbdbf3bcbaaa) Lwt_glib # OASIS_STOP lwt-2.4.3/src/glib/liblwt-glib_stubs.clib0000644000000000000000000000014512067037511016505 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 905c14a6abfdc3cc49bbc233df66ff99) lwt_glib_stubs.o # OASIS_STOP lwt-2.4.3/src/glib/lwt_glib_stubs.c0000644000000000000000000001746112067037505015425 0ustar0000000000000000/* 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; int events; GPollFD *gpollfd; CAMLparam0(); CAMLlocal3(fds, watches, 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); watches = caml_alloc_tuple(n_fds); for (i = 0; i < n_fds; i++) { gpollfd = gpollfds + i; gpollfd->revents = 0; events = 0; if (gpollfd->events & G_IO_IN) events |= 1; if (gpollfd->events & G_IO_OUT) events |= 2; #if defined(LWT_ON_WINDOWS) /* On windows, glib file descriptors are handles */ Field(fds, i) = alloc_fd((HANDLE)gpollfd->fd); #else Field(fds, i) = Val_int(gpollfd->fd); if (gpollfd->fd < 0) events = 0; #endif Field(watches, i) = Val_int(events); } result = caml_alloc_tuple(3); Store_field(result, 0, fds); Store_field(result, 1, watches); Store_field(result, 2, 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; } lwt-2.4.3/src/glib/lwt_glib.mli0000644000000000000000000000632112067037505014535 0ustar0000000000000000(* 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. [mode] defaults to [`lwt_into_glib] because it is more portable. [`glib_into_lwt] does not work under Windows and MacOS. 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. *) lwt-2.4.3/src/glib/lwt_glib.ml0000644000000000000000000001155512067037505014371 0ustar0000000000000000(* 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. *) 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 | +-----------------------------------------------------------------+ *) type watch = | Watch_none | Watch_in | Watch_out | Watch_in_out external glib_get_sources : unit -> Unix.file_descr array * watch 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 fds, watches, timeout = glib_get_sources () in for i = 0 to Array.length fds - 1 do let fd = fds.(i) in match watches.(i) with | Watch_none -> () | Watch_in -> events := engine#on_readable fd (fun _ -> glib_mark_readable i) :: !events | Watch_out -> events := engine#on_writable fd (fun _ -> glib_mark_writable i) :: !events | Watch_in_out -> events := engine#on_readable fd (fun _ -> glib_mark_readable i) :: engine#on_writable 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=`lwt_into_glib) () = match !state with | State_lwt_into_glib _ | State_glib_into_lwt _ -> () | State_none -> 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" lwt-2.4.3/src/extra/0000755000000000000000000000000012067037511012430 5ustar0000000000000000lwt-2.4.3/src/extra/lwt-extra.mllib0000644000000000000000000000013412067037511015376 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 73d5d5d814da6fce812bc449a2dcd20c) Lwt_lib # OASIS_STOP lwt-2.4.3/src/extra/lwt_lib.mli0000644000000000000000000000371512067037505014600 0ustar0000000000000000(* 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) *) lwt-2.4.3/src/extra/lwt_lib.ml0000644000000000000000000001044112067037505014421 0ustar0000000000000000(* 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 lwt-2.4.3/src/core/0000755000000000000000000000000012067037511012235 5ustar0000000000000000lwt-2.4.3/src/core/lwt.mllib0000644000000000000000000000030212067037511014057 0ustar0000000000000000# 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 lwt-2.4.3/src/core/META0000644000000000000000000000737612067037511012723 0ustar0000000000000000# OASIS_START # DO NOT EDIT (digest: 2158b7266b14d281eb95c3bf70a416bf) version = "2.4.3" description = "Lightweight thread library for OCaml (core library)" archive(byte) = "lwt.cma" archive(byte, plugin) = "lwt.cma" archive(native) = "lwt.cmxa" archive(native, plugin) = "lwt.cmxs" exists_if = "lwt.cma" package "unix" ( version = "2.4.3" description = "Unix support for lwt" requires = "lwt unix bigarray" archive(byte) = "lwt-unix.cma" archive(byte, plugin) = "lwt-unix.cma" archive(native) = "lwt-unix.cmxa" archive(native, plugin) = "lwt-unix.cmxs" exists_if = "lwt-unix.cma" ) package "top" ( version = "2.4.3" description = "Line-editing in the toplevel (deprecated)" requires = "lwt lwt.text findlib" archive(byte) = "lwt-top.cma" archive(byte, plugin) = "lwt-top.cma" archive(native) = "lwt-top.cmxa" archive(native, plugin) = "lwt-top.cmxs" exists_if = "lwt-top.cma" ) package "text" ( version = "2.4.3" description = "Text mode utilities (deprecated)" requires = "lwt lwt.unix lwt.react text text.bigarray" archive(byte) = "lwt-text.cma" archive(byte, plugin) = "lwt-text.cma" archive(native) = "lwt-text.cmxa" archive(native, plugin) = "lwt-text.cmxs" exists_if = "lwt-text.cma" ) package "syntax" ( version = "2.4.3" 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.4.3" 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.4.3" 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 "ssl" ( version = "2.4.3" description = "SSL support for Lwt" requires = "ssl lwt.unix" archive(byte) = "lwt-ssl.cma" archive(byte, plugin) = "lwt-ssl.cma" archive(native) = "lwt-ssl.cmxa" archive(native, plugin) = "lwt-ssl.cmxs" exists_if = "lwt-ssl.cma" ) package "simple-top" ( version = "2.4.3" description = "Unix support for lwt" requires = "lwt lwt.unix" archive(byte) = "lwt-simple-top.cma" archive(byte, plugin) = "lwt-simple-top.cma" archive(native) = "lwt-simple-top.cmxa" archive(native, plugin) = "lwt-simple-top.cmxs" exists_if = "lwt-simple-top.cma" ) package "react" ( version = "2.4.3" description = "Reactive programming helpers" requires = "lwt react" archive(byte) = "lwt-react.cma" archive(byte, plugin) = "lwt-react.cma" archive(native) = "lwt-react.cmxa" archive(native, plugin) = "lwt-react.cmxs" exists_if = "lwt-react.cma" ) package "preemptive" ( version = "2.4.3" description = "Preemptive threads support for Lwt" requires = "lwt lwt.unix threads" archive(byte) = "lwt-preemptive.cma" archive(byte, plugin) = "lwt-preemptive.cma" archive(native) = "lwt-preemptive.cmxa" archive(native, plugin) = "lwt-preemptive.cmxs" exists_if = "lwt-preemptive.cma" ) package "glib" ( version = "2.4.3" description = "Glib integration" requires = "lwt lwt.unix" archive(byte) = "lwt-glib.cma" archive(byte, plugin) = "lwt-glib.cma" archive(native) = "lwt-glib.cmxa" archive(native, plugin) = "lwt-glib.cmxs" exists_if = "lwt-glib.cma" ) package "extra" ( version = "2.4.3" description = "Unix functions for Lwt using Lwt_preemptive" requires = "lwt lwt.preemptive" archive(byte) = "lwt-extra.cma" archive(byte, plugin) = "lwt-extra.cma" archive(native) = "lwt-extra.cmxa" archive(native, plugin) = "lwt-extra.cmxs" exists_if = "lwt-extra.cma" ) # OASIS_STOP lwt-2.4.3/src/core/lwt_util.mli0000644000000000000000000000640012067037505014606 0ustar0000000000000000(* 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] *) lwt-2.4.3/src/core/lwt_util.ml0000644000000000000000000000622012067037505014435 0ustar0000000000000000(* 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. *) let (>>=) = Lwt.(>>=) let (>|=) = 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_unit l let rec iter_serial f l = match l with | [] -> Lwt.return_unit | a :: r -> f a >>= fun () -> iter_serial f r let rec map f l = match l with | [] -> Lwt.return_nil | v :: r -> let t = f v in let rt = map f r in t >>= fun v' -> rt >|= fun l' -> v' :: l' let map_with_waiting_action f wa l = let rec loop l = match l with | [] -> Lwt.return_nil | 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); rt >|= fun l' -> v' :: l' in if l <> [] then wa (List.hd l); loop l let rec map_serial f l = match l with | [] -> Lwt.return_nil | v :: r -> f v >>= fun v' -> map_serial f r >|= fun l' -> v' :: l' let rec fold_left f a = function | [] -> Lwt.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 = Lwt.finalize thr (fun () -> leave_region reg sz; Lwt.return_unit) let run_in_region reg sz thr = if reg.count >= reg.size then begin let (res, w) = Lwt.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 lwt-2.4.3/src/core/lwt_switch.mli0000644000000000000000000000705412067037505015140 0ustar0000000000000000(* 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. *) lwt-2.4.3/src/core/lwt_switch.ml0000644000000000000000000000367012067037505014767 0ustar0000000000000000(* 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. *) 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; Lwt.return_unit | Some { state = St_off } -> hook () | None -> Lwt.return_unit let turn_off switch = match switch.state with | St_on { hooks = hooks } -> switch.state <- St_off; Lwt_list.iter_p (fun hook -> Lwt.apply hook ()) hooks | St_off -> Lwt.return_unit lwt-2.4.3/src/core/lwt_stream.mli0000644000000000000000000002625112067037505015132 0ustar0000000000000000(* 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 from_direct : (unit -> 'a option) -> 'a t (** [from_direct f] does the same as {!from} but with a function that does not return a thread. It is better than wrapping [f] into a function which return a thread. *) exception Closed (** Exception raised by the push function of a push-stream when pushing an element after the end of stream ([= None]) have been pushed. *) val create : unit -> 'a t * ('a option -> unit) (** [create ()] returns a new stream and a push function. *) val create_with_reference : unit -> 'a t * ('a option -> unit) * ('b -> unit) (** [create_with_reference ()] returns a new stream and a push function. The last function allows to set a reference to an external source. This prevent the external source from being garbage collected. For example, to convert a reactive event to a stream: {[ let stream, push, set_ref = Lwt_stream.create_with_reference () in set_ref (map_event push event) ]} *) exception Full (** Exception raised by the push function of a bounded push-stream when the stream queue is full and a thread is already waiting to push an element. *) (** Type of sources for bounded push-streams. *) class type ['a] bounded_push = object method size : int (** Size of the stream. *) method resize : int -> unit (** Change the size of the stream queue. Note that the new size can smaller than the current stream queue size. It raises [Invalid_argument] if [size < 0]. *) method push : 'a -> unit Lwt.t (** Pushes a new element to the stream. If the stream is full then it will block until one element is consumed. If another thread is already blocked on {!push}, it raises {!Full}. *) method close : unit (** Closes the stream. Any thread currently blocked on {!push} will fail with {!Closed}. *) method count : int (** Number of elements in the stream queue. *) method blocked : bool (** Is a thread is blocked on {!push} ? *) method closed : bool (** Is the stream closed ? *) method set_reference : 'a. 'a -> unit (** Set the reference to an external source. *) end val create_bounded : int -> 'a t * 'a bounded_push (** [create_bounded size] returns a new stream and a bounded push source. The stream can hold a maximum of [size] elements. When this limit is reached, pushing a new element will block until one is consumed. Note that you cannot clone or parse (with {!parse}) a bounded stream. These functions will raise [Invalid_argument] if you try to do so. It raises [Invalid_argument] if [size < 0]. *) 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 ]} It raises [Invalid_argument] if [st] is a bounded push-stream. *) (** {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 (** [last_new st] returns the last element that can be obtained without sleepping, or wait for one if no one is already available. 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 st] returns all available elements of [l] without blocking *) val get_available_up_to : int -> 'a t -> 'a list (** [get_available_up_to n st] returns up to [n] elements of [l] without blocking *) val is_empty : 'a t -> bool Lwt.t (** [is_empty st] returns wether the given stream is empty *) val on_terminate : 'a t -> (unit -> unit) -> unit (** [on_terminate st f] executes [f] when the end of the stream [st] is reached. Note that the stream may still contains elements if {!peek} or similar was used. *) (** {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] *) (** A value or an error. *) type 'a result = | Value of 'a | Error of exn val map_exn : 'a t -> 'a result t (** [map_exn s] returns a stream that captures all exceptions raised by the source of the stream (the function passed to {!from}). Note that for push-streams (as returned by {!create}) all elements of the mapped streams are values. *) (** {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. It raises [Invalid_argument] if [st] is a bounded push-stream. *) (** {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]: {[ let () = Lwt_main.run (Lwt_io.write_lines Lwt_io.stdout (Lwt_stream.hexdump (Lwt_io.read_lines Lwt_io.stdin))) ]} *) lwt-2.4.3/src/core/lwt_stream.ml0000644000000000000000000006745612067037505014775 0ustar0000000000000000(* 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. *) let (>>=) = Lwt.(>>=) let (>|=) = Lwt.(>|=) exception Closed exception Full exception Empty type 'a result = | Value of 'a | Error of exn (* A node in a queue of pending data. *) type 'a node = { mutable next : 'a node; (* Next node in the queue. For the last node it points to itself. *) mutable data : 'a option; (* Data of this node. For the last node it is always [None]. *) } (* Note: a queue for an exhausted stream is represented by a node containing [None] followed by a node with itself as next and [None] as data. *) let new_node () = let rec node = { next = node; data = None } in node (* Type of a stream source using a function to create new elements. *) type 'a from = { from_create : unit -> 'a option Lwt.t; (* Function used to create new elements. *) mutable from_thread : unit Lwt.t; (* Thread which: - wait for the thread returned by the last call to [from_next], - add the next element to the end of the queue. If it is a sleeping thread, then it must be used instead of creating a new one with [from_create]. *) } (* Type of a stream source for push streams. *) type push = { mutable push_signal : unit Lwt.t; (* Thread signaled when a new element is added to the stream. *) mutable push_waiting : bool; (* Is a thread waiting on [push_signal] ? *) mutable push_external : Obj.t; (* Reference to an external source. *) } (* Type of a stream source for bounded-push streams. *) type 'a push_bounded = { mutable pushb_signal : unit Lwt.t; (* Thread signaled when a new element is added to the stream. *) mutable pushb_waiting : bool; (* Is a thread waiting on [pushb_signal] ? *) mutable pushb_size : int; (* Size of the queue. *) mutable pushb_count : int; (* Current length of the queue. *) mutable pushb_pending : 'a option; (* The next element to push if a thread blocked on push. We store it here to be sure it will be the first element to be added when space becomes available. *) mutable pushb_push_waiter : unit Lwt.t; mutable pushb_push_wakener : unit Lwt.u; (* Thread blocked on push. *) mutable pushb_external : Obj.t; (* Reference to an external source. *) } (* Source of a stream. *) type 'a source = | From of 'a from | From_direct of (unit -> 'a option) | Push of push | Push_bounded of 'a push_bounded type 'a t = { source : 'a source; (* The source of the stream. *) mutable node : 'a node; (* Pointer to first pending element, or to [last] if there is no pending element. *) last : 'a node ref; (* Node marking the end of the queue of pending elements. *) hooks : (unit -> unit) list ref; (* Functions called when the end of stream is reached. Hooks are shared between all clones. *) } class type ['a] bounded_push = object method size : int method resize : int -> unit method push : 'a -> unit Lwt.t method close : unit method count : int method blocked : bool method closed : bool method set_reference : 'a. 'a -> unit end (* The only difference between two clones is the pointer to the first pending element. *) let clone s = (match s.source with | Push_bounded _ -> invalid_arg "Lwt_stream.clone" | _ -> ()); { source = s.source; node = s.node; last = s.last; hooks = s.hooks; } let from f = let last = new_node () in { source = From { from_create = f; from_thread = Lwt.return_unit }; node = last; last = ref last; hooks = ref []; } let from_direct f = let last = new_node () in { source = From_direct f; node = last; last = ref last; hooks = ref []; } let on_terminate s f = s.hooks := f :: !(s.hooks) let of_list l = let l = ref l in from_direct (fun () -> match !l with | [] -> None | x :: l' -> l := l'; Some x) let of_array a = let len = Array.length a and i = ref 0 in from_direct (fun () -> if !i = len then None else begin let c = Array.unsafe_get a !i in incr i; Some c end) let of_string s = let len = String.length s and i = ref 0 in from_direct (fun () -> if !i = len then None else begin let c = String.unsafe_get s !i in incr i; Some c end) let create_with_reference () = (* Create the cell pointing to the end of the queue. *) let last = ref (new_node ()) in (* Create the source for notifications of new elements. *) let source, wakener_cell = let waiter, wakener = Lwt.wait () in ({ push_signal = waiter; push_waiting = false; push_external = Obj.repr () }, ref wakener) in (* Set to [true] when the end-of-stream is sent. *) let closed = ref false in let hooks = ref [] in (* The push function. It does not keep a reference to the stream. *) let push x = if !closed then raise Closed; if x = None then closed := true; (* Push the element at the end of the queue. *) let node = !last and new_last = new_node () in node.data <- x; node.next <- new_last; last := new_last; (* Send a signal if at least one thread is waiting for a new element. *) if source.push_waiting then begin source.push_waiting <- false; (* Update threads. *) let old_wakener = !wakener_cell in let new_waiter, new_wakener = Lwt.wait () in source.push_signal <- new_waiter; wakener_cell := new_wakener; (* Signal that a new value has been received. *) Lwt.wakeup_later old_wakener () end; (* Do this at the end in case one of the function raise an exception. *) if x = None then List.iter (fun f -> f ()) !hooks in ({ source = Push source; node = !last; last = last; hooks = hooks }, push, fun x -> source.push_external <- Obj.repr x) let create () = let source, push, _ = create_with_reference () in (source, push) (* Add the pending element to the queue and notify the blocked pushed. Precondition: info.pushb_pending = Some _ This does not modify info.pushb_count. *) let notify_pusher info last = (* Push the element at the end of the queue. *) let node = !last and new_last = new_node () in node.data <- info.pushb_pending; node.next <- new_last; last := new_last; (* Clear pending element. *) info.pushb_pending <- None; (* Wakeup the pusher. *) let old_wakener = info.pushb_push_wakener in let waiter, wakener = Lwt.task () in info.pushb_push_waiter <- waiter; info.pushb_push_wakener <- wakener; Lwt.wakeup_later old_wakener () class ['a] bounded_push_impl (info : 'a push_bounded) wakener_cell last hooks = object val mutable closed = false method size = info.pushb_size method resize size = if size < 0 then invalid_arg "Lwt_stream.bounded_push#resize"; info.pushb_size <- size; if info.pushb_count < info.pushb_size && info.pushb_pending <> None then begin info.pushb_count <- info.pushb_count + 1; notify_pusher info last end method push x = if closed then Lwt.fail Closed else if info.pushb_pending <> None then Lwt.fail Full else if info.pushb_count >= info.pushb_size then begin info.pushb_pending <- Some x; Lwt.catch (fun () -> info.pushb_push_waiter) (fun exn -> match exn with | Lwt.Canceled -> info.pushb_pending <- None; let waiter, wakener = Lwt.task () in info.pushb_push_waiter <- waiter; info.pushb_push_wakener <- wakener; Lwt.fail exn | _ -> Lwt.fail exn) end else begin (* Push the element at the end of the queue. *) let node = !last and new_last = new_node () in node.data <- Some x; node.next <- new_last; last := new_last; info.pushb_count <- info.pushb_count + 1; (* Send a signal if at least one thread is waiting for a new element. *) if info.pushb_waiting then begin info.pushb_waiting <- false; (* Update threads. *) let old_wakener = !wakener_cell in let new_waiter, new_wakener = Lwt.wait () in info.pushb_signal <- new_waiter; wakener_cell := new_wakener; (* Signal that a new value has been received. *) Lwt.wakeup_later old_wakener () end; Lwt.return_unit end method close = if not closed then begin closed <- true; let node = !last and new_last = new_node () in node.data <- None; node.next <- new_last; last := new_last; if info.pushb_pending <> None then begin info.pushb_pending <- None; Lwt.wakeup_later_exn info.pushb_push_wakener Closed end; List.iter (fun f -> f ()) !hooks end method count = info.pushb_count method blocked = info.pushb_pending <> None method closed = closed method set_reference : 'a. 'a -> unit = fun x -> info.pushb_external <- Obj.repr x end let create_bounded size = if size < 0 then invalid_arg "Lwt_stream.create_bounded"; (* Create the cell pointing to the end of the queue. *) let last = ref (new_node ()) in let hooks = ref [] in (* Create the source for notifications of new elements. *) let info, wakener_cell = let waiter, wakener = Lwt.wait () in let push_waiter, push_wakener = Lwt.task () in ({ pushb_signal = waiter; pushb_waiting = false; pushb_size = size; pushb_count = 0; pushb_pending = None; pushb_push_waiter = push_waiter; pushb_push_wakener = push_wakener; pushb_external = Obj.repr () }, ref wakener) in ({ source = Push_bounded info; node = !last; last = last; hooks = hooks }, new bounded_push_impl info wakener_cell last hooks) (* Wait for a new element to be added to the queue of pending element of the stream. *) let feed s = match s.source with | From from -> (* There is already a thread started to create a new element, wait for this one to terminate. *) if Lwt.is_sleeping from.from_thread then Lwt.protected from.from_thread else begin (* Otherwise request a new element. *) let thread = from.from_create () >>= fun x -> (* Push the element to the end of the queue. *) let node = !(s.last) and new_last = new_node () in node.data <- x; node.next <- new_last; s.last := new_last; if x = None then List.iter (fun f -> f ()) !(s.hooks); Lwt.return_unit in (* Allow other threads to access this thread. *) from.from_thread <- thread; Lwt.protected thread end | From_direct f -> let x = f () in (* Push the element to the end of the queue. *) let node = !(s.last) and new_last = new_node () in node.data <- x; node.next <- new_last; s.last := new_last; if x = None then List.iter (fun f -> f ()) !(s.hooks); Lwt.return_unit | Push push -> push.push_waiting <- true; Lwt.protected push.push_signal | Push_bounded push -> push.pushb_waiting <- true; Lwt.protected push.pushb_signal (* Remove [node] from the top of the queue, or do nothing if it was already consumed. Precondition: node.data <> None *) let consume s node = if node == s.node then begin s.node <- node.next; match s.source with | Push_bounded info -> if info.pushb_pending = None then info.pushb_count <- info.pushb_count - 1 else notify_pusher info s.last | _ -> () end let rec peek_rec s node = if node == !(s.last) then feed s >>= fun () -> peek_rec s node else Lwt.return node.data let peek s = peek_rec s s.node let rec npeek_rec node acc n s = if n <= 0 then Lwt.return (List.rev acc) else if node == !(s.last) then feed s >>= fun () -> npeek_rec node acc n s else match node.data with | Some x -> npeek_rec node.next (x :: acc) (n - 1) s | None -> Lwt.return (List.rev acc) let npeek n s = npeek_rec s.node [] n s let rec get_rec s node = if node == !(s.last) then feed s >>= fun () -> get_rec s node else begin if node.data <> None then consume s node; Lwt.return node.data end let get s = get_rec s s.node let rec get_exn_rec s node = if node == !(s.last) then Lwt.try_bind (fun () -> feed s) (fun () -> get_exn_rec s node) (fun exn -> Lwt.return (Some (Error exn))) else match node.data with | Some value -> consume s node; Lwt.return (Some (Value value)) | None -> Lwt.return_none let map_exn s = from (fun () -> get_exn_rec s s.node) let rec nget_rec node acc n s = if n <= 0 then Lwt.return (List.rev acc) else if node == !(s.last) then feed s >>= fun () -> nget_rec node acc n s else match s.node.data with | Some x -> consume s node; nget_rec node.next (x :: acc) (n - 1) s | None -> Lwt.return (List.rev acc) let nget n s = nget_rec s.node [] n s let rec get_while_rec node acc f s = if node == !(s.last) then feed s >>= fun () -> get_while_rec node acc f s else match node.data with | Some x -> let test = f x in if test then begin consume s node; get_while_rec node.next (x :: acc) f s end else Lwt.return (List.rev acc) | None -> Lwt.return (List.rev acc) let get_while f s = get_while_rec s.node [] f s let rec get_while_s_rec node acc f s = if node == !(s.last) then feed s >>= fun () -> get_while_s_rec node acc f s else match node.data with | Some x -> begin f x >>= function | true -> consume s node; get_while_s_rec node.next (x :: acc) f s | false -> Lwt.return (List.rev acc) end | None -> Lwt.return (List.rev acc) let get_while_s f s = get_while_s_rec s.node [] f s let rec next_rec s node = if node == !(s.last) then feed s >>= fun () -> next_rec s node else match node.data with | Some x -> consume s node; Lwt.return x | None -> Lwt.fail Empty let next s = next_rec s s.node let rec last_new_rec node x s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> last_new_rec node x s | Lwt.Fail exn -> Lwt.fail exn | Lwt.Sleep -> Lwt.return x else match node.data with | Some x -> consume s node; last_new_rec node.next x s | None -> Lwt.return x let last_new s = let node = s.node in if node == !(s.last) then let thread = next s in match Lwt.state thread with | Lwt.Return x -> last_new_rec node x s | _ -> thread else match node.data with | Some x -> consume s node; last_new_rec node.next x s | None -> Lwt.fail Empty let rec to_list_rec node acc s = if node == !(s.last) then feed s >>= fun () -> to_list_rec node acc s else match node.data with | Some x -> consume s node; to_list_rec node.next (x :: acc) s | None -> Lwt.return (List.rev acc) let to_list s = to_list_rec s.node [] s let rec to_string_rec node buf s = if node == !(s.last) then feed s >>= fun () -> to_string_rec node buf s else match node.data with | Some x -> consume s node; Buffer.add_char buf x; to_string_rec node.next buf s | None -> Lwt.return (Buffer.contents buf) let to_string s = to_string_rec s.node (Buffer.create 128) s let junk s = let node = s.node in if node == !(s.last) then begin feed s >>= fun () -> if node.data <> None then consume s node; Lwt.return_unit end else begin if node.data <> None then consume s node; Lwt.return_unit end let rec njunk_rec node n s = if n <= 0 then Lwt.return_unit else if node == !(s.last) then feed s >>= fun () -> njunk_rec node n s else match node.data with | Some _ -> consume s node; njunk_rec node.next (n - 1) s | None -> Lwt.return_unit let njunk n s = njunk_rec s.node n s let rec junk_while_rec node f s = if node == !(s.last) then feed s >>= fun () -> junk_while_rec node f s else match node.data with | Some x -> let test = f x in if test then begin consume s node; junk_while_rec node.next f s end else Lwt.return_unit | None -> Lwt.return_unit let junk_while f s = junk_while_rec s.node f s let rec junk_while_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> junk_while_s_rec node f s else match node.data with | Some x -> begin f x >>= function | true -> consume s node; junk_while_s_rec node.next f s | false -> Lwt.return_unit end | None -> Lwt.return_unit let junk_while_s f s = junk_while_s_rec s.node f s let rec junk_old_rec node s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> junk_old_rec node s | Lwt.Fail exn -> Lwt.fail exn | Lwt.Sleep -> Lwt.return_unit else match node.data with | Some _ -> consume s node; junk_old_rec node.next s | None -> Lwt.return_unit let junk_old s = junk_old_rec s.node s let rec get_available_rec node acc s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> get_available_rec node acc s | Lwt.Fail exn -> raise exn | Lwt.Sleep -> List.rev acc else match node.data with | Some x -> consume s node; get_available_rec node.next (x :: acc) s | None -> List.rev acc let get_available s = get_available_rec s.node [] s let rec get_available_up_to_rec node acc n s = if n <= 0 then List.rev acc else if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> get_available_up_to_rec node acc n s | Lwt.Fail exn -> raise exn | Lwt.Sleep -> List.rev acc else match s.node.data with | Some x -> consume s node; get_available_up_to_rec node.next (x :: acc) (n - 1) s | None -> List.rev acc let get_available_up_to n s = get_available_up_to_rec s.node [] n s let rec is_empty s = if s.node == !(s.last) then feed s >>= fun () -> is_empty s else Lwt.return (s.node.data = None) let map f s = from (fun () -> get s >|= function | Some x -> let x = f x in Some x | None -> None) let map_s f s = from (fun () -> get s >>= function | Some x -> f x >|= (fun x -> Some x) | None -> Lwt.return_none) let filter f s = let rec next () = let t = get s in t >>= function | Some x -> let test = f x in if test then t else next () | None -> Lwt.return_none in from next let filter_s f s = let rec next () = let t = get s in t >>= function | Some x -> begin f x >>= function | true -> t | false -> next () end | None -> t 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 _ -> Lwt.return x | None -> next ()) | None -> Lwt.return_none in from next let filter_map_s f s = let rec next () = get s >>= function | Some x -> let t = f x in (t >>= function | Some _ -> t | None -> next ()) | None -> Lwt.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 -> Lwt.return_none) | x :: l -> pendings := l; Lwt.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 -> f x >>= fun l -> pendings := l; next () | None -> Lwt.return_none) | x :: l -> pendings := l; Lwt.return (Some x) in from next let flatten s = map_list (fun l -> l) s let rec fold_rec node f s acc = if node == !(s.last) then feed s >>= fun () -> fold_rec node f s acc else match node.data with | Some x -> consume s node; let acc = f x acc in fold_rec node.next f s acc | None -> Lwt.return acc let fold f s acc = fold_rec s.node f s acc let rec fold_s_rec node f s acc = if node == !(s.last) then feed s >>= fun () -> fold_s_rec node f s acc else match node.data with | Some x -> consume s node; f x acc >>= fun acc -> fold_s_rec node.next f s acc | None -> Lwt.return acc let fold_s f s acc = fold_s_rec s.node f s acc let rec iter_rec node f s = if node == !(s.last) then feed s >>= fun () -> iter_rec node f s else match node.data with | Some x -> consume s node; let () = f x in iter_rec node.next f s | None -> Lwt.return_unit let iter f s = iter_rec s.node f s let rec iter_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> iter_s_rec node f s else match node.data with | Some x -> consume s node; f x >>= fun () -> iter_s_rec node.next f s | None -> Lwt.return_unit let iter_s f s = iter_s_rec s.node f s let rec iter_p_rec node f s = if node == !(s.last) then feed s >>= fun () -> iter_p_rec node f s else match node.data with | Some x -> consume s node; Lwt.join [f x; iter_p_rec node.next f s] | None -> Lwt.return_unit let iter_p f s = iter_p_rec s.node f s let rec find_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_rec node f s else match node.data with | Some x as opt -> consume s node; let test = f x in if test then Lwt.return opt else find_rec node.next f s | None -> Lwt.return_none let find f s = find_rec s.node f s let rec find_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_s_rec node f s else match node.data with | Some x as opt -> begin consume s node; f x >>= function | true -> Lwt.return opt | false -> find_s_rec node.next f s end | None -> Lwt.return_none let find_s f s = find_s_rec s.node f s let rec find_map_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_map_rec node f s else match node.data with | Some x -> consume s node; let x = f x in if x = None then find_map_rec node.next f s else Lwt.return x | None -> Lwt.return_none let find_map f s = find_map_rec s.node f s let rec find_map_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_map_s_rec node f s else match node.data with | Some x -> consume s node; let t = f x in (t >>= function | None -> find_map_s_rec node.next f s | Some _ -> t) | None -> Lwt.return_none let find_map_s f s = find_map_s_rec s.node f s let rec combine s1 s2 = let next () = let t1 = get s1 and t2 = get s2 in t1 >>= fun n1 -> t2 >>= fun n2 -> match n1, n2 with | Some x1, Some x2 -> Lwt.return (Some(x1, x2)) | _ -> Lwt.return_none in from next let append s1 s2 = let current_s = ref s1 in let rec next () = let t = get !current_s in t >>= function | Some _ -> t | None -> if !current_s == s2 then Lwt.return_none else begin current_s := s2; next () end in from next let concat s_top = let current_s = ref (from (fun () -> Lwt.return_none)) in let rec next () = let t = get !current_s in t >>= function | Some _ -> t | None -> get s_top >>= function | Some s -> current_s := s; next () | None -> Lwt.return_none in from next let choose streams = let source s = (s, get s >|= fun x -> (s, x)) in let streams = ref (List.map source streams) in let rec next () = match !streams with | [] -> Lwt.return_none | l -> Lwt.choose (List.map snd l) >>= fun (s, x) -> let l = List.remove_assq s l in match x with | Some _ -> streams := source s :: l; Lwt.return x | None -> next () in from next let parse s f = (match s.source with | Push_bounded _ -> invalid_arg "Lwt_stream.parse" | _ -> ()); let node = s.node in Lwt.catch (fun () -> f s) (fun exn -> s.node <- node; Lwt.fail exn) let hexdump stream = let buf = Buffer.create 80 and num = ref 0 in from begin fun _ -> nget 16 stream >>= function | [] -> Lwt.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 '|'; Lwt.return (Some(Buffer.contents buf)) end lwt-2.4.3/src/core/lwt_sequence.mli0000644000000000000000000001071212067037505015442 0ustar0000000000000000(* 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] *) lwt-2.4.3/src/core/lwt_sequence.ml0000644000000000000000000001165212067037505015275 0ustar0000000000000000(* 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 lwt-2.4.3/src/core/lwt_pqueue.mli0000644000000000000000000000257512067037505015146 0ustar0000000000000000(* 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 lwt-2.4.3/src/core/lwt_pqueue.ml0000644000000000000000000000616012067037505014767 0ustar0000000000000000(* 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 lwt-2.4.3/src/core/lwt_pool.mli0000644000000000000000000000371612067037505014611 0ustar0000000000000000(* Lwt * http://www.ocsigen.org * Copyright (C) 2008 Jrme Vouillon * 2012 Jrmie Dimino * 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 'a t (** Type of pools *) val create : int -> ?check : ('a -> (bool -> unit) -> unit) -> ?validate : ('a -> bool Lwt.t) -> (unit -> 'a Lwt.t) -> 'a t (** [create n ?check ?validate f] creates a new pool with at most [n] members. [f] is the function to use to create a new pool member. An element of the pool is validated by the optional [validate] function before its {!use}. Invalid elements are re-created. The optional function [check] is called after a [use] of an element failed. It must call its argument excatly one with [true] if the pool member is still valid and [false] otherwise. *) val use : 'a t -> ('a -> 'b Lwt.t) -> 'b Lwt.t (** [use p f] takes one free member of the pool [p] and gives it to the function [f]. *) lwt-2.4.3/src/core/lwt_pool.ml0000644000000000000000000001012012067037505014423 0ustar0000000000000000(* Lwt * http://www.ocsigen.org * Copyright (C) 2008 Jrme Vouillon * 2012 Jrmie Dimino * 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 (>>=) = Lwt.(>>=) let (>|=) = Lwt.(>|=) (* XXX Close after some timeout ... *) type 'a t = { create : unit -> 'a Lwt.t; (* Create a new pool member. *) check : 'a -> (bool -> unit) -> unit; (* Check a member when its use failed. *) validate : 'a -> bool Lwt.t; (* Validate old pool members. *) max : int; (* Size of the pool. *) mutable count : int; (* Number of elements in hte pool. *) list : 'a Queue.t; (* Available pool members. *) waiters : 'a Lwt.u Lwt_sequence.t; (* Threads waiting for a member. *) } let create m ?(check = fun _ f -> f true) ?(validate = fun _ -> Lwt.return_true) create = { max = m; create = create; validate = validate; check = check; count = 0; list = Queue.create (); waiters = Lwt_sequence.create () } let create_member p = Lwt.catch (fun () -> (* Must be done before p.create to prevent other threads from creating new members if the limit is reached. *) p.count <- p.count + 1; p.create ()) (fun exn -> (* Creation failed, so don't increment count. *) p.count <- p.count - 1; Lwt.fail exn) (* Release a pool member. *) let release p c = match Lwt_sequence.take_opt_l p.waiters with | Some wakener -> (* A thread is waiting, give it the pool member. *) Lwt.wakeup_later wakener c | None -> (* No one is waiting, queue it. *) Queue.push c p.list (* Create a new member when one is thrown away. *) let replace_acquired p = match Lwt_sequence.take_opt_l p.waiters with | None -> (* No one is waiting, do not create a new member to avoid loosing an error if creation fails. *) p.count <- p.count - 1 | Some wakener -> Lwt.on_any (Lwt.apply p.create ()) (fun c -> Lwt.wakeup_later wakener c) (fun exn -> (* Creation failed, notify the waiter of the failure. *) p.count <- p.count - 1; Lwt.wakeup_later_exn wakener exn) let acquire p = if Queue.is_empty p.list then (* No more available member. *) if p.count < p.max then (* Limit not reached: create a new one. *) create_member p else (* Limit reached: wait for a free one. *) Lwt.add_task_r p.waiters else (* Take the first free member and validate it. *) let c = Queue.take p.list in Lwt.try_bind (fun () -> p.validate c) (function | true -> Lwt.return c | false -> (* Remove this member and create a new one. *) p.count <- p.count - 1; create_member p) (fun e -> (* Validation failed: create a new member if at least one thread is waiting. *) replace_acquired p; Lwt.fail e) (* Release a member when its use failed. *) let checked_release p c = p.check c begin fun ok -> if ok then release p c else replace_acquired p end let use p f = acquire p >>= fun c -> Lwt.catch (fun () -> let t = f c in t >>= fun _ -> release p c; t) (fun e -> checked_release p c; Lwt.fail e) lwt-2.4.3/src/core/lwt_mvar.mli0000644000000000000000000000556512067037505014611 0ustar0000000000000000(******************************************************************************) (* 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. *) lwt-2.4.3/src/core/lwt_mvar.ml0000644000000000000000000000572412067037505014435 0ustar0000000000000000(******************************************************************************) (* 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. ******************************************************************************) 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; Lwt.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 -> Lwt.add_task_r mvar.readers lwt-2.4.3/src/core/lwt_mutex.mli0000644000000000000000000000451512067037505015000 0ustar0000000000000000(* 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. *) lwt-2.4.3/src/core/lwt_mutex.ml0000644000000000000000000000335212067037505014625 0ustar0000000000000000(* 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. *) let (>>=) = 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 Lwt.add_task_r m.waiters else begin m.locked <- true; Lwt.return_unit 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 = lock m >>= fun () -> Lwt.finalize f (fun () -> unlock m; Lwt.return_unit) let is_locked m = m.locked let is_empty m = Lwt_sequence.is_empty m.waiters lwt-2.4.3/src/core/lwt_list.mli0000644000000000000000000000422512067037505014607 0ustar0000000000000000(* 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 lwt-2.4.3/src/core/lwt_list.ml0000644000000000000000000001066512067037505014443 0ustar0000000000000000(* 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. *) let (>>=) = Lwt.(>>=) let (>|=) = Lwt.(>|=) let rec iter_s f l = match l with | [] -> Lwt.return_unit | x :: l -> f x >>= fun () -> iter_s f l let rec iter_p f l = match l with | [] -> Lwt.return_unit | x :: l -> let tx = f x and tl = iter_p f l in tx >>= fun () -> tl let rec map_s f l = match l with | [] -> Lwt.return_nil | x :: l -> f x >>= fun x -> map_s f l >|= fun l -> x :: l let rec map_p f l = match l with | [] -> Lwt.return_nil | x :: l -> let tx = f x and tl = map_p f l in tx >>= fun x -> tl >|= fun l -> x :: l let rec rev_map_append_s acc f l = match l with | [] -> Lwt.return acc | x :: l -> f x >>= fun x -> 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 (f x >>= fun x -> acc >|= fun l -> x :: l) f l let rev_map_p f l = rev_map_append_p Lwt.return_nil f l let rec fold_left_s f acc l = match l with | [] -> Lwt.return acc | x :: l -> f acc x >>= fun acc -> fold_left_s f acc l let rec fold_right_s f l acc = match l with | [] -> Lwt.return acc | x :: l -> fold_right_s f l acc >>= fun acc -> f x acc let rec for_all_s f l = match l with | [] -> Lwt.return_true | x :: l -> f x >>= function | true -> for_all_s f l | false -> Lwt.return_false let rec for_all_p f l = match l with | [] -> Lwt.return_true | x :: l -> let tx = f x and tl = for_all_p f l in tx >>= fun bx -> tl >|= fun bl -> bx && bl let rec exists_s f l = match l with | [] -> Lwt.return_false | x :: l -> f x >>= function | true -> Lwt.return_true | false -> exists_s f l let rec exists_p f l = match l with | [] -> Lwt.return_false | x :: l -> let tx = f x and tl = exists_p f l in tx >>= fun bx -> tl >|= fun bl -> bx || bl let rec find_s f l = match l with | [] -> Lwt.fail Not_found | x :: l -> f x >>= function | true -> Lwt.return x | false -> find_s f l let rec filter_s f l = match l with | [] -> Lwt.return_nil | x :: l -> f x >>= function | true -> filter_s f l >|= fun l -> x :: l | false -> filter_s f l let rec filter_p f l = match l with | [] -> Lwt.return_nil | x :: l -> let tx = f x and tl = filter_p f l in tx >>= fun bx -> tl >|= fun l -> if bx then x :: l else l let return_nil_nil = Lwt.return ([], []) let rec partition_s f l = match l with | [] -> return_nil_nil | x :: l -> f x >>= fun bx -> partition_s f l >|= fun (l_l, l_r) -> if bx then (x :: l_l, l_r) else (l_l, x :: l_r) let rec partition_p f l = match l with | [] -> return_nil_nil | x :: l -> let tx = f x and tl = partition_p f l in tx >>= fun bx -> tl >|= fun (l_l, l_r) -> if bx then (x :: l_l, l_r) else (l_l, x :: l_r) lwt-2.4.3/src/core/lwt_condition.mli0000644000000000000000000000621212067037505015620 0ustar0000000000000000(******************************************************************************) (* 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. *) lwt-2.4.3/src/core/lwt_condition.ml0000644000000000000000000000461712067037505015456 0ustar0000000000000000(******************************************************************************) (* 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. ******************************************************************************) let (>>=) = Lwt.(>>=) type 'a t = 'a Lwt.u Lwt_sequence.t let create = Lwt_sequence.create let wait ?mutex cvar = let waiter = Lwt.add_task_r cvar in let () = match mutex with | Some m -> Lwt_mutex.unlock m | None -> () in Lwt.finalize (fun () -> waiter) (fun () -> match mutex with | Some m -> Lwt_mutex.lock m | None -> Lwt.return_unit) let signal cvar arg = try Lwt.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 -> Lwt.wakeup_later wakener arg) wakeners lwt-2.4.3/src/core/lwt.mli0000644000000000000000000003744312067037505013564 0ustar0000000000000000(* 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 * 2009-2012 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. *) (** 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] *) (** {8 Pre-allocated threads} *) val return_unit : unit t (** [return_unit = return ()] *) val return_none : 'a option t (** [return_none = return None] *) val return_nil : 'a list t (** [return_nil = return \[\]] *) val return_true : bool t (** [return_true = return true] *) val return_false : bool t (** [return_false = return false] *) (** {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 async : (unit -> 'a t) -> unit (** [async f] starts a thread without waiting for the result. If it fails (now or later), the exception is given to {!async_exception_hook}. You should use this function if you want to start a thread that might fail and don't care what its return value is, nor when it terminates (for instance, because it is looping). *) val ignore_result : 'a t -> unit (** [ignore_result t] is like [Pervasives.ignore t] except that: - if [t] already failed, it raises the exception now, - if [t] is sleeping and fails later, the exception will be given to {!async_exception_hook}. *) val async_exception_hook : (exn -> unit) ref (** Function called when a asynchronous exception is thrown. The default behavior is to print an error message with a backtrace if available and to exit the program. The behavior is undefined if this function raise an exception. *) (** {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 woken up immediately. *) val wakeup_later_exn : 'a u -> exn -> unit (** Same as {!wakeup_exn} but it is not guaranteed that the thread will be woken up immediately. *) val waiter_of_wakener : 'a u -> 'a t (** Returns the thread associated to a wakener. *) type +'a result (** Either a value of type ['a], either an exception. *) val make_value : 'a -> 'a result (** [value x] creates a result containing the value [x]. *) val make_error : exn -> 'a result (** [error e] creates a result containing the exception [e]. *) val of_result : 'a result -> 'a t (** Returns a thread from a result. *) val wakeup_result : 'a u -> 'a result -> unit (** [wakeup_result t r] makes the sleeping thread [t] terminate with the result [r]. *) val wakeup_later_result : 'a u -> 'a result -> unit (** Same as {!wakeup_result} but it is not guaranteed that the thread will be woken up immediately. *) (** {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 *) val is_sleeping : 'a t -> bool (** [is_sleeping t] returns [true] iff [t] is sleeping. *) (** {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. [f] will be executed before all other threads waiting on [t]. If [f] raises an exception it is given to {!async_exception_hook}. *) val add_task_r : 'a u Lwt_sequence.t -> 'a t (** [add_task_r seq] creates a sleeping thread, adds its wakener to the right of [seq] and returns its waiter. When the thread is canceled, it is removed from [seq]. *) val add_task_l : 'a u Lwt_sequence.t -> 'a t (** [add_task_l seq] creates a sleeping thread, adds its wakener to the left of [seq] and returns its waiter. When the thread is canceled, it is removed from [seq]. *) 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]. *) val no_cancel : 'a t -> 'a t (** [no_cancel thread] creates a thread which behave as [thread] except that it cannot be canceled. *) (** {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 resumes and pauses again, it will not be woken up at this point. *) val paused_count : unit -> int (** [paused_count ()] returns the number of currently paused threads. *) 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. If [f] raises an exception it is given to {!async_exception_hook}. *) val on_failure : 'a t -> (exn -> unit) -> unit (** [on_failure t f] executes [f] when [t] terminates and fails. If [f] raises an exception it is given to {!async_exception_hook}. *) val on_termination : 'a t -> (unit -> unit) -> unit (** [on_termination t f] executes [f] when [t] terminates. If [f] raises an exception it is given to {!async_exception_hook}. *) val on_any : 'a t -> ('a -> unit) -> (exn -> unit) -> unit (** [on_any t f g] executes [f] or [g] when [t] terminates. If [f] or [g] raises an exception it is given to {!async_exception_hook}. *) (**/**) (* 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 lwt-2.4.3/src/core/lwt.ml0000644000000000000000000011002312067037505013375 0ustar0000000000000000(* 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-2012 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 (* A type + a thread of this type. *) module type A_thread = sig type a val thread : a t end type a_thread = (module A_thread) (* a_thread = exists 'a. 'a t *) (* Pack a thread into a A_thread module. *) let pack_thread (type x) t = let module M = struct type a = x let thread = t end in (module M : A_thread) (* A type + a list of threads of this type. *) module type A_threads = sig type a val threads : a t list end type a_threads = (module A_threads) (* a_threads = exists 'a. 'a t list *) (* Pack a list of threads into a A_threads module. *) let pack_threads (type x) l = let module M = struct type a = x let threads = l end in (module M : A_threads) 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 = { mutable cancel : cancel; (* How to cancel this thread. *) mutable waiters : 'a waiter_set; (* All thunk functions. These functions are always called inside a enter_wakeup/leave_wakeup block. *) mutable removed : int; (* Number of waiter that have been disabled. When this number reaches [max_removed], they are effectively removed from [waiters]. *) mutable cancel_handlers : 'a cancel_handler_set; (* Functions to execute when this thread is canceled. Theses functions must be executed before waiters. *) } and cancel = | Cancel_no (* This thread cannot be canceled, it was created with [wait]. *) | Cancel_me (* Restart this thread with [Fail Canceled]. It was created with [task]. *) | Cancel_link of a_thread (* Cancel this thread. *) | Cancel_links of a_threads (* Cancel all these threads. *) (* 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 'a cancel_handler_set = | Chs_empty | Chs_func of data * (unit -> unit) (* The callback may raise an exception. *) | Chs_node of 'a u Lwt_sequence.node (* This is the same as: {[ Chs_func (fun () -> Lwt_sequence.remove node) ]} but it is the common case so it is inlined. *) | Chs_append of 'a cancel_handler_set * 'a cancel_handler_set 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 async_exception_hook = ref (fun exn -> prerr_string "Fatal error: exception "; prerr_string (Printexc.to_string exn); prerr_char '\n'; Printexc.print_backtrace stderr; flush stderr; exit 2) (* Execute [f x] and handle any raised exception with [async_exception_hook]. *) let call_unsafe f x = try f x with exn -> !async_exception_hook exn let rec run_waiters_rec state ws rem = match ws with | Empty -> run_waiters_rec_next state rem | Immutable f -> f state; run_waiters_rec_next state rem | Removable { contents = None } -> run_waiters_rec_next state rem | Removable { contents = Some f } -> f state; run_waiters_rec_next state rem | Append (ws1, ws2) -> run_waiters_rec state ws1 (ws2 :: rem) and run_waiters_rec_next state rem = match rem with | [] -> () | ws :: rem -> run_waiters_rec state ws rem let rec run_cancel_handlers_rec chs rem = match chs with | Chs_empty -> run_cancel_handlers_rec_next rem | Chs_func (data, f) -> current_data := data; call_unsafe f (); run_cancel_handlers_rec_next rem | Chs_node n -> Lwt_sequence.remove n; run_cancel_handlers_rec_next rem | Chs_append (chs1, chs2) -> run_cancel_handlers_rec chs1 (chs2 :: rem) and run_cancel_handlers_rec_next rem = match rem with | [] -> () | chs :: rem -> run_cancel_handlers_rec chs rem (* Run all waiters waiting on [t]. This must always be done inside a enter_wakeup/leave_wakeup block. This function must never raise an exception. *) let unsafe_run_waiters sleeper state = (* Call cancel handlers if this is a thread cancellation. *) (match state with | Fail Canceled -> run_cancel_handlers_rec sleeper.cancel_handlers [] | _ -> ()); (* Restart waiters. *) run_waiters_rec state sleeper.waiters [] (* [true] if we are in a wakeup. *) let wakening = ref false (* A sleeper + its state. *) module type A_closure = sig type a val sleeper : a sleeper val state : a thread_state end (* Queue of sleepers to wakeup. *) let to_wakeup = Queue.create () (* Enter a wakeup operation. *) let enter_wakeup () = let snapshot = !current_data in let already_wakening = if !wakening then (* If we are already in a wakeup, do nothing. *) true else begin (* Otherwise mark that a wakeup operation has started. *) wakening := true; false end in (already_wakening, snapshot) (* Leave a wakeup operation. *) let leave_wakeup (already_wakening, snapshot) = if not already_wakening then begin (* This was the first wakeup on the call stack, wakeup remaining sleeping threads. *) while not (Queue.is_empty to_wakeup) do let closure = Queue.pop to_wakeup in let module M = (val closure : A_closure) in unsafe_run_waiters M.sleeper M.state done; (* We are done wakening threads. *) wakening := false; current_data := snapshot end else current_data := snapshot let safe_run_waiters sleeper state = let ctx = enter_wakeup () in unsafe_run_waiters sleeper state; leave_wakeup ctx (* A ['a result] is either [Return of 'a] or [Fail of exn] so it is covariant. *) type +'a result (* = 'a thread_state *) external result_of_state : 'a thread_state -> 'a result = "%identity" external state_of_result : 'a result -> 'a thread_state = "%identity" let make_value v = result_of_state (Return v) let make_error e = result_of_state (Fail e) let wakeup_result t result = let t = repr_rec (wakener_repr t) in match t.state with | Sleep sleeper -> let state = state_of_result result in t.state <- state; safe_run_waiters sleeper state | Fail Canceled -> (* Do not fail if the thread has been canceled: *) () | _ -> invalid_arg "Lwt.wakeup_result" let wakeup t v = wakeup_result t (make_value v) let wakeup_exn t e = wakeup_result t (make_error e) let wakeup_later_result (type x) t result = let t = repr_rec (wakener_repr t) in match t.state with | Sleep sleeper -> let state = state_of_result result in t.state <- state; if !wakening then begin (* Already wakening => create the closure for later wakening. *) let module M = struct type a = x let sleeper = sleeper let state = state end in Queue.push (module M : A_closure) to_wakeup end else (* Otherwise restart threads now. *) safe_run_waiters sleeper state | Fail Canceled -> () | _ -> invalid_arg "Lwt.wakeup_later_result" let wakeup_later t v = wakeup_later_result t (make_value v) let wakeup_later_exn t e = wakeup_later_result t (make_error e) module type A_sleeper = sig type a val sleeper : a sleeper end type a_sleeper = (module A_sleeper) let pack_sleeper (type x) sleeper = let module M = struct type a = x let sleeper = sleeper end in (module M : A_sleeper) let cancel (type x) t = let state = Fail Canceled in (* - collect all sleepers to restart - set the state of all threads to cancel to [Fail Canceled] *) let rec collect : 'a. a_sleeper list -> 'a t -> a_sleeper list = fun acc t -> let t = repr t in match t.state with | Sleep ({ cancel } as sleeper) -> begin match cancel with | Cancel_no -> acc | Cancel_me -> (* Set the state of [t] immediately so it won't be collected again. *) t.state <- state; (pack_sleeper sleeper) :: acc | Cancel_link m -> let module M = (val m : A_thread) in collect acc M.thread | Cancel_links m -> let module M = (val m : A_threads) in List.fold_left collect acc M.threads end | _ -> acc in let sleepers = collect [] t in (* Restart all sleepers. *) let ctx = enter_wakeup () in List.iter (fun sleeper -> let module M = (val sleeper : A_sleeper) in run_cancel_handlers_rec M.sleeper.cancel_handlers []; run_waiters_rec state M.sleeper.waiters []) sleepers; leave_wakeup ctx let append l1 l2 = match l1, l2 with | Empty, _ -> l2 | _, Empty -> l1 | _ -> Append (l1, l2) let chs_append l1 l2 = match l1, l2 with | Chs_empty, _ -> l2 | _, Chs_empty -> l1 | _ -> Chs_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 (* Make [t1] and [t2] behave the same way, where [t1] is a sleeping thread. This means that they must share the same representation. [connect] assumes it is called inside a enter_wakeup/leave_wakeup block. *) 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]--------------/ *) (* Cancelling [t1] is now the same as canceling [t2]: *) sleeper1.cancel <- 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; sleeper1.cancel_handlers <- chs_append sleeper1.cancel_handlers sleeper2.cancel_handlers | state2 -> (* [t2] is already terminated, assing its state to [t1]: *) t1.state <- state2; (* and run all the waiters of [t1]: *) unsafe_run_waiters sleeper1 state2 end | _ -> (* [t1] is not asleep: *) assert false (* Same as [connect] except that we know that [t2] has alreayd terminated. *) let fast_connect t state = let t = repr t in match t.state with | Sleep sleeper -> t.state <- state; unsafe_run_waiters sleeper state | _ -> assert false (* Same as [fast_connect] except that it does nothing if [t] has terminated. *) let fast_connect_if t state = let t = repr t in match t.state with | Sleep sleeper -> t.state <- state; unsafe_run_waiters sleeper state | _ -> () (* +-----------------------------------------------------------------+ | Threads conctruction and combining | +-----------------------------------------------------------------+ *) let return v = thread { state = Return v } let state_return_unit = Return () let return_unit = thread { state = state_return_unit } let return_none = return None let return_nil = return [] let return_true = return true let return_false = return false let of_result result = thread { state = state_of_result result } let fail e = thread { state = Fail e } let temp t = thread { state = Sleep { cancel = Cancel_link (pack_thread (thread t)); waiters = Empty; removed = 0; cancel_handlers = Chs_empty } } let temp_many l = thread { state = Sleep { cancel = Cancel_links (pack_threads l); waiters = Empty; removed = 0; cancel_handlers = Chs_empty } } let wait_aux () = { state = Sleep { cancel = Cancel_no; waiters = Empty; removed = 0; cancel_handlers = Chs_empty } } let wait () = let t = wait_aux () in (thread t, wakener t) let task_aux () = { state = Sleep { cancel = Cancel_me; waiters = Empty; removed = 0; cancel_handlers = Chs_empty } } let task () = let t = task_aux () in (thread t, wakener t) let add_task_r seq = let sleeper = { cancel = Cancel_me; waiters = Empty; removed = 0; cancel_handlers = Chs_empty } in let t = { state = Sleep sleeper } in let node = Lwt_sequence.add_r (wakener t) seq in sleeper.cancel_handlers <- Chs_node node; thread t let add_task_l seq = let sleeper = { cancel = Cancel_me; waiters = Empty; removed = 0; cancel_handlers = Chs_empty }in let t = { state = Sleep sleeper } in let node = Lwt_sequence.add_l (wakener t) seq in sleeper.cancel_handlers <- Chs_node node; thread 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_waiter sleeper waiter = sleeper.waiters <- (match sleeper.waiters with | Empty -> waiter | ws -> Append (waiter, ws)) let add_immutable_waiter sleeper waiter = add_waiter sleeper (Immutable waiter) let on_cancel t f = match (repr t).state with | Sleep sleeper -> let handler = Chs_func (!current_data, f) in sleeper.cancel_handlers <- ( match sleeper.cancel_handlers with | Chs_empty -> handler | chs -> Chs_append (handler, chs) ) | Fail Canceled -> call_unsafe f () | _ -> () let bind t f = let t = repr t in match t.state with | Return v -> f v | Fail _ as state -> thread { state } | Sleep sleeper -> let res = temp t 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 _ as state -> fast_connect res state | _ -> assert false); res | Repr _ -> assert false let (>>=) t f = bind t f let (=<<) f t = bind t f let map f t = let t = repr t in match t.state with | Return v -> thread { state = try Return (f v) with exn -> Fail exn } | Fail _ as state -> thread { state } | Sleep sleeper -> let res = temp t 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 _ as state -> fast_connect res state | _ -> assert false); res | Repr _ -> assert false let (>|=) t f = map f t let (=|<) f t = map f t let catch x f = let t = repr (try x () with exn -> fail exn) in match t.state with | Return _ -> thread t | Fail exn -> f exn | Sleep sleeper -> let res = temp t 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_success t f = match (repr t).state with | Return v -> call_unsafe f v | Fail exn -> () | Sleep sleeper -> let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; call_unsafe f v | Fail exn -> () | _ -> assert false) | Repr _ -> assert false let on_failure t f = match (repr t).state with | Return v -> () | Fail exn -> call_unsafe f exn | Sleep sleeper -> let data = !current_data in add_immutable_waiter sleeper (function | Return v -> () | Fail exn -> current_data := data; call_unsafe f exn | _ -> assert false) | Repr _ -> assert false let on_termination t f = match (repr t).state with | Return v -> call_unsafe f () | Fail exn -> call_unsafe f () | Sleep sleeper -> let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; call_unsafe f () | Fail exn -> current_data := data; call_unsafe f () | _ -> assert false) | Repr _ -> assert false let on_any t f g = match (repr t).state with | Return v -> call_unsafe f v | Fail exn -> call_unsafe g exn | Sleep sleeper -> let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; call_unsafe f v | Fail exn -> current_data := data; call_unsafe g exn | _ -> assert false) | Repr _ -> assert false let try_bind x f g = let t = repr (try x () with exn -> fail exn) in match t.state with | Return v -> f v | Fail exn -> g exn | Sleep sleeper -> let res = temp t 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 async f = let t = repr (try f () with exn -> fail exn) in match t.state with | Return _ -> () | Fail exn -> !async_exception_hook exn | Sleep sleeper -> add_immutable_waiter sleeper (function | Return _ -> () | Fail exn -> !async_exception_hook exn | _ -> assert false) | Repr _ -> assert false let ignore_result t = match (repr t).state with | Return _ -> () | Fail e -> raise e | Sleep sleeper -> add_immutable_waiter sleeper (function | Return _ -> () | Fail exn -> !async_exception_hook exn | _ -> assert false) | Repr _ -> assert false let protected t = match (repr t).state with | Sleep sleeper -> let res = thread (task_aux ()) in (* We use [fact_connect_if] because when [res] is canceled, it will always terminate before [t]. *) add_immutable_waiter sleeper (fast_connect_if res); res | Return _ | Fail _ -> t | Repr _ -> assert false let no_cancel t = match (repr t).state with | Sleep sleeper -> let res = thread (wait_aux ()) in add_immutable_waiter sleeper (fast_connect res); res | 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 | _ -> if n > 0 then nth_ready l (n - 1) else t 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 ({ waiters = Removable _ } as sleeper) -> (* There is only one waiter, it is the removed one. *) sleeper.waiters <- Empty | 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 let add_removable_waiter threads waiter = let node = Removable waiter in List.iter (fun t -> match (repr t).state with | Sleep sleeper -> add_waiter sleeper node | _ -> assert false) threads (* The PRNG state is initialized with a constant to make non-IO-based programs deterministic. *) let random_state = lazy (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: *) nth_ready l 0 else nth_ready l (Random.State.int (Lazy.force random_state) ready) else begin let res = temp_many l in let rec waiter = ref (Some handle_result) and 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 add_removable_waiter l waiter; 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 _ as state -> fast_connect res state | _ -> nchoose_terminate res acc l let nchoose_sleep l = let res = temp_many l in let rec waiter = ref (Some handle_result) and handle_result state = waiter := None; remove_waiters l; nchoose_terminate res [] l in add_removable_waiter l waiter; res let nchoose l = let rec init = function | [] -> nchoose_sleep l | t :: l -> match (repr t).state with | Return x -> collect [x] l | Fail _ as state -> thread { state } | _ -> init l and collect acc = function | [] -> return (List.rev acc) | t :: l -> match (repr t).state with | Return x -> collect (x :: acc) l | Fail _ as state -> thread { state } | _ -> 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 _ as state -> fast_connect res state | _ -> nchoose_split_terminate res acc_terminated (t :: acc_sleeping) l let nchoose_split_sleep l = let res = temp_many l in let rec waiter = ref (Some handle_result) and handle_result state = waiter := None; remove_waiters l; nchoose_split_terminate res [] [] l in add_removable_waiter l waiter; 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 _ as state -> thread { state } | _ -> 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 _ as state -> thread { state } | _ -> 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 | _ -> if n > 0 then cancel_and_nth_ready l (n - 1) else begin List.iter cancel l; t end let pick l = let ready = ready_count l in if ready > 0 then if ready = 1 then (* Optimisation for the common case: *) cancel_and_nth_ready l 0 else cancel_and_nth_ready l (Random.State.int (Lazy.force random_state) ready) else begin let res = temp_many 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 add_removable_waiter l waiter; res end let npick_sleep l = let res = temp_many 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 add_removable_waiter l waiter; res let npick threads = let rec init = function | [] -> npick_sleep threads | t :: l -> match (repr t).state with | Return x -> collect [x] l | Fail _ as state -> List.iter cancel threads; thread { state } | _ -> 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 _ as state -> List.iter cancel threads; thread { state } | _ -> collect acc l in init threads let join l = let res = temp_many l (* Number of threads still sleeping: *) and sleeping = ref 0 (* The state that must be returned: *) and return_state = ref state_return_unit in let handle_result state = begin match !return_state, state with | Return _, Fail _ -> return_state := state | _ -> () end; decr sleeping; (* All threads are terminated, we can wakeup the result: *) if !sleeping = 0 then fast_connect res !return_state 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_immutable_waiter sleeper handle_result; 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 = add_task_r paused in 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 = let t = repr t in match t.state with | Return v -> f v | Fail exn -> thread { state = Fail(add_loc exn) } | Sleep sleeper -> let res = temp t 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 = repr (try x () with exn -> fail exn) in match t.state with | Return _ -> thread t | Fail exn -> f (add_loc exn) | Sleep sleeper -> let res = temp t 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 = repr (try x () with exn -> fail exn) in match t.state with | Return v -> f v | Fail exn -> g (add_loc exn) | Sleep sleeper -> let res = temp t 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 | +-----------------------------------------------------------------+ *) let rec is_sleeping_rec t = match t.state with | Return _ | Fail _ -> false | Sleep _ -> true | Repr t -> is_sleeping_rec t let is_sleeping t = is_sleeping_rec (thread_repr t) 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 lwt-2.4.3/manual/0000755000000000000000000000000012067037510011772 5ustar0000000000000000lwt-2.4.3/manual/manual.pdf0000644000000000000000000054214012067037510013750 0ustar0000000000000000%PDF-1.5 % 175 0 obj << /Length 1284 /Filter /FlateDecode >> stream xZMo8W(+VkmE.R݃"3drI#n-l\St8< ^%G>_O^"0*x0yWDASJMh]Sx4azeZZudhG1 ;0&JI&Cc`7c*&:ֻs҈4sGEi>)eݠ $siܘ,p}~U0߰BJ(b(NRS-L d:Jir#ULݨADvm3uѕ`  m|1M;uMkl*ۼ]ӯ<2:Ce &Hq0Kx2Xb$ϲ_seNJ*76ɾ s-D)yW~P6+됇nޚ|m+ ߹|A6S}smއ# LfǼX,\tجJ)EmuQَS4eeIGMDŽ{UW^8j=Ģjz$ϫigiWW8xơ٥8z7ٸ'H!Fybߟ{!4zR!jmm=B ~#{K}Q~vxBavGRv}ƝL5Pc-.W6p~ݙGD6+񯹏;ir,ćmB#R$G97y0NϼHy6r? Knm |lӽ'ǩ"Zh*/Z%n]e=jnnA]ͬ@e43҄rF^vd]dk.R-"RESTdJD3Tj<|29jf3EYfR]O]EwMH"!vo9=WLͲ5Eޙ)lxܵxI55f%3"eZ?GZhTME<Oco!Al`ZFNF@BRL'W! endstream endobj 2 0 obj << /Type /ObjStm /N 100 /First 809 /Length 1814 /Filter /FlateDecode >> stream xڵYnF}Wcf/@P  }p@kL $:3ĭ#^=sfv8Kj .$BZm3'4G1WxWK# /'apjt. ku4.A! N TSGE/|-")|C1VMHCE HpE]t>o1Qc\(LC/zϤ$@P[X#JQaNtAPR<= hLyA K{>O #:Xh8\:fȳIIЉ>F BhcH cPV0QcfdH^r r. K | gYZD,Aְl3wYqnj!;<TH+*!°HP,l7L[d+@R,-,qP.^9x;ȏ,rdX|lxu_5O?O/u6Wxx,݋uf.۲hyjoWlkʝnZ߶ka<:NntlW%ٔ<"udvz?)cl<6ͺ܈o&Bn'CcIKݗ"ǀj6wۦR|}Yfnm~omHyvFl~utesȜ7Uϳ8(KѽgxPmYm.{WVnwbcuU߈rX۶i˻vt]]ϫ (l$&]mxSߦa?u/'\IbݟqӓmէRb}[utSFGr{Wը ]1PPm:2(-u|xr5OϺ:j=M| x/V?Vϟϋ/,V@(VY@|kzf׮3_rKoUUDP3d>haˍ5wBpr׵8qtH1c=nG#x4шG#x4шGER)4xFGm/VnQj%#?dT&$a# .cQ oD8=,o.JE vAjt1:LSYPY$i'dy^PTdZ&y LBP{v!p$d@ ؒb#\9m{VusŗJ1&~zy#V:J& &Tg(=Ny鱪t !~ mTlrߢW$=MBnV:YasTA Hͥ'j9*jPK|$ΰC;QAX 2̤oo,w_/t%3'< e+;JnTDO'Y,M~!sN;C3X4_BH$rT=5SA 樲|aQuу:l y>&< Rkt~,u2|~cѰ`XpQq*,ɊG:F?.4Uc=#O~LɊͲt .Jޤ̒hg)!VG+Д YKDJTY s endstream endobj 189 0 obj << /Length 248 /Filter /FlateDecode >> stream xS=O0 +> stream xڵYێ}v,#.o $3b"e69}nvX,VwWTu_<,ŷ7>y.LAEq.Ylq[ V f˾kWkvGCKSZĝ"@)N$ ~HRt1A Yi#n1Vvc f{-"N)C=C!u'`(:o)2-[$u6&l u@u5K%m[Z&̀8Ϧ6//%#aԭlxgw^3({N1;L9ϔi9*]5\`Es:z_B&VBñM'oZ\XW{y ʕ"J*I?D N]Ӟ6%Gj-_[6;Yzh*8ťlrŸ.G1Ip(=% 1xRsF.5#α2[#d{/OV#۵ ʧpyH :܎0-qGFVkOc\_J(N>nxvjy+/pXћDBtn(|4%uNY*jˋAXG'Tʖ'Xͬ 1Zqnˮ`Hu}a)˩k kKLF$'MH :H};p5-m:r%H.\=T:/%RG}d\Ƅw δg0rVqwvgfF PWզӶ>,Rwhi .Ɲ]QWv&8jj7yMmFlybWnBdy/],5,ɡ'G0)S;/#8 h BƜF7@ OW;']5qM.\6LOc]g5[ {q DTb7xQ\@w/uyr(I3_@t"pkX%C#ϗ\}؎*"|jԤ] qLm|&H~.-] p+^xdNꐮ')r-`UVr ]X*jɘs2H,AzYשG8y)hp.gxG/=FuӱsFzl6GLB|luX"Q$"p" Fl~!0&a!+ʨu"OPڡ O/(pJtwfLlNYJ>[;vi8BOWPbLȺMi1k KF!3eAn@(xDӦL{B"AӾsH׏gz `&y>}zJ#@_zU)N1]s }GWA.~֪伢gB`V9H r,y|W稺|zlT;iɆL}/L{23:%0Ih]xYBiBoopw _, [aE~nRtfqsa,N0jEG,]t-4ŒHaZghx2C{DF,B]8_4C[.߽ hѰGdi6׮ u#>QΖ.V; endstream endobj 201 0 obj << /Length 2641 /Filter /FlateDecode >> stream xZYF~_! Cw7퍁,ba,6ypautSFckf}!QWUM1è j>jȅ}v㉖2ӶެKD+u˥%cEٔӶ-&6mVSiv+]XfÐkZWgXr=Kc@= jwM=l+tl>.C&R慵} cMq0&1>klkri͟j\ X-euWMU\}^M& nUgF/&L>ӐȾ,T(53n$[MlY͸ˎ?uųizi˜{Yq'.XSu#K\8مȽE3BH΍#gUMWXore(F_;卅r)?lEJF qghoȭ0˕.?|Uf<)=kzY/ ) Z'3?=%zAtI4f/֗^ Nn cg'0 ͽkΣ(BvCDO^] )`!d`JS*,Y .DR+ZXf?*[õ47Oƍs}!jPCB23SE}E0KĶsGv53vtU"]QgV}[8ݢf?zC_ᎎ4G!?lf-NP|(3)rU/oT[GB71lBq,A7hSslVGbT2!uN񌎨k-j`x `٬.[Pۦ ^>OzA`"khY 1R`sI9#Uϫ {kFc|ɨ?)Oًl(yGSAt϶f{Y.ydȴF6)I)*7u4jڵb$ * ^^==df=УlYu.B'SS#Oad48k+zt0b5bpՔ8( !QӓiZ@~VPInQw 1ޒIU=SѳG[&BrGGK)iBfѥK{vj86æ7`I\X˺-剬xUC1fSԥn<5\QHdiU֟Ǡ` nb1v !:}-dDx^IS4-F&)8EI+TytWS\6E`]=MJOnx[AeoKE]]67(DH<"0٦@tWm1f#d>1(:|E6N`y>8A̻' C"Ojɷq6G%@ {?̠oxJ endstream endobj 223 0 obj << /Length 2551 /Filter /FlateDecode >> stream xZm۸B\ _EއAqm(pPly-D\I^o}Clƛw@HI g^83$n"G]_zd4ItLBR)#(BGC2=۫7 % ݾ#fsUlΨk?̽mӖ՛h43FRx&ϺE*̾xܖy-W٭ҵdU6ykv=-wcqyMWy*?6}涇( 1*B%#F\aFٯv2k7-`X0h.4%I۵]- Mַs8@UHGIqfq:Z=̽9E\\~52\u]}y5WuY}XjW-{toPψPƜԋ5kJ0#m\tngJYCP|fix_~FɔaLO¢ï4ZB%"5{n"AQa!$ Rl3aBXQw~ȷV.Wם%ʺF%{+GyԍT.'rf@NԓC/NF0IBbF we7YNK0OmVSa W2R:!'HTs$;knvX$5A[T]qQrMVca鼁\z֎L.< (ժn6Z1o).]B{$Mnl.lagrĈ`D%H0oE ,,}3J PG)K`JZSt\HyJç5Tisv~|υ4Sr0sN_cO# >KK?ݠp&?j ,leLS@]ˉcVI>a_@r9KCέY ʍC p#vN+DgSpy9)<}n0 `eʰ2ps9o%bc;Wf M2K̏9͈b(j*FT Z }.+5Q/RBշX\B8G@$hqPmPe2K<)X ]P0!0}Q~f qsQ> '/Mf3]ظqn-[8`\N;8x$,&>tCJXHDzy)͞ٽ6TȦ2[i6x2{pۡ 7$H{eǝdOGLdJGP+,ps0$)j"{#cHdmS3K]ZJ)=WL@dk?hl ޅtɟʵlg)![gzj֩LXHԉQO)0_sz M&N/\6 QpS9({>Fzu63Ǝ܄kp_Xr윟ݮr p%`8"{~iD"!XʊDx=YR?yHN5$CV$7xl-s-]U[,0Dgc<*!zVFc5h4{d9INmsdj$Mf7Xwmova::4Ave/XSi:g>3-\`r͸EVO 4'lI!TنJ]QᮘG*ѫGaYsW.%\)"D"5+~w?߈A{.4A !RrtmJY~&TuV.$.  M޶Mu-]V-KO,̚p9OI`X8eC6_c OF~c&Ru8Fl߀*b.DD¾NċDkw.gC>6W, 3w~ 3"gG[ _7pp#A-X92q,!Irpu Xo&ԍՍn0><S;PjTTҵ[ߪ|z@uҶ6RDPѠ}EhdjGCߛÅSRp |v%8OaTK> stream xZݏ۸߿B@*1Or=\\mo>b˱.'̐%[7( $ŏp7!mD$ۛ^ e,3DȊ%Fu,K_ժovb)Swۦۿ~* DK2fn+h/Ҹ˭x,_@Ws,|tWvCosX*%WTu.fVs~m޺U+}Y]SmfX4QsH8\q\,q7Dj3d{}@;zTX}pk#'1''Cbk*F2pJf47$gvo=ӿM8}s wiLAsn헺`&F3,I{^m:ܶo{ʫ'osW=@cVb>\`{5;24&y+=C/UZ CWv&~l'=sGhq53(< y"7A[q.WK+ yo;FBMff'fr>AS{{8m_8ۓG8_qgiOS@HGJ+k?r74׃?S3IO㞍I2nT퉛||~5D1B^ @[6颇;[JAچ'9u|!9 XQQH endstream endobj 275 0 obj << /Length 2584 /Filter /FlateDecode >> stream xZYoH~ fX z>MXvLmsëc㷪IӲyi6>꯾ngWޝʜ*^ޝLS)Lgg\3id& d"|٧". |;z, Kz"C)lFq{=o^P9'R${bD %rG2hA ߻߸tAW$MZomLۋo]0g?H]WxN@rMeA%TD%\&wF134C*C"2+*TtMWK{ɌB{в"X7"8FnGQHs;Ό7u '3h#AKZ3[JV2) 1K>WҖYgLcM.G[• Т7R)n{A++1|?h#8Ov kQ-fC!2A bE| 'hVz W݁O[2F/ĩMEM !Cȯ\5ʧk:_̋8܎,g <-7Qj"\jhjՁ`C}QLӲjS|8z(ӓh>.4tqUe1b^!/r>Z+umZƁa: ;ú@PX/b_E#L~zEmAmb;|,GbmuM߸PԒw=b>FЦL+2-&uaId5 vX,QsR6v a8(ͨyk I@$lV8;_/5نjt]|]A`ؘDr4FuDe-,AZ8 SjxFM?4Y"=y!4!q/;"ְ )kc.L _=w*BNP&zoXJDg7pÀOall]'$UoCWh}IaxϾ&x !%TOF#+1iy,f9O%>*)WC+\ Bi"ɹ*֔b2Wak`qH4u5#Mu_@<#4Ty8=]j6HH!3\ps}Yl lS;Ȗ@ÚP:ȅ> =!2DgՍvq(B"NįH&(.ç<; 9@d}L10LBY'R'G|FĿ Ƴ,$3^d[_f]00n΁=F#COաm (Z0|eoJgȜaaW.Dy+hB_K Qš mO6))\U$"r}\8ƆטZ]W6r-[Ŵ5A`$dQV+M{,JTa2-$$ xGaZuE`Sp%|L &T~;x=] 1:#0Wi㢓s92ZP.x4U5\mPp!m@Ǹ\QvՔCJ:6xB/T/>XuݭjD f5aP+~f#v!<)϶jCD\;12 ChGfAJO֑eE7#;f~^rkl1Jg8B'),m= ?tFu]?Hbg >4VOӸ%?V*9;iVw _kj endstream endobj 186 0 obj << /Type /ObjStm /N 100 /First 878 /Length 1422 /Filter /FlateDecode >> stream xڭX[k7~_Es&ĸ-`<5ye)awfx(f>}::71Y )@0~sAcAqrg j)4i( xIA0@O {7rB0d 9A{)..䯦d8Ss`Įs03tS0Oa%8I.5W]>;SD|%sOͷaP0W ,ju3M ƀZBn X(`p7(7DE 0Ad J+D[*I1 avSuͱU>( շ nnEWZƁMp/aԅ,(Ar`nt,30U!a! VYVj  i.sAZaRt[ CnS Q#@; ۰Րɝd΄pr2owf_~_O Onum|yAd_>ބc-셄 Sb praefkܬE9<{6U9 ) ? 8ϟ0~"&k:۬o&nWy3C T/|ӳ0Y} ߶Z߫a| Vk,vt^on>mtK &BΑ/'́W-|ԁCKڐǰ\#Rwna!ofUt]ڎtwBK.}AJ2.d IѰua3x-vqf}va3xVR4Ri.Y@Mc>'  =K.jimn]D_HmQ,a M^lͱz(4 wjPe.k±Ώ 7Gf;/dj~oiQ\VA:q.砄d}PιakS);pl7{+.zWy*8S@PEj]ħfM߇]XCI*8"r+/uCˣzlм\7`}L)4UoD9%3}3gz9\Al2sWghV>[j'/)N^4Rb!D9N| JE -Ap%-KRB1/rrIQ-Rfkn˙J}q i;Q!5*B_HM ́B3b3mR3؂6)V(_b endstream endobj 318 0 obj << /Length 2472 /Filter /FlateDecode >> stream xZK82 9|6 l_Ij[n %G *%[vE)Xϯ(> &qģvhhF :]CN8Q9SByZ>k` ab]& pcj<ͥPaf\Ɍp_C6HEۤn06]굧U˺rL*usY/ޯ,n^˚^oQ6r,n47\K;gJ9u&K -fs!dXVK$)@7)uwHeW?{\P~K׭Z34<>K/# ReMP[,,:>èv˛l(7wfE| @Ɉ0Ƀ%U* V7:ʎC](FL4\kj%Z3V 1&(>gϠÔ]F2jQev\mrph;^$h)v[Rܒ*Dܑ­2k7Z*(~d | ~osC\:df0Ak1pGey3{-lJG \ u qLsY9K\@tN'> 7%+W:nU4Y5,)n6,0]x_/1hӑS6PM6׺.xZ1[dH,|߮F1@7H,Hj<օ2|3H9ۯ@*+UGA?T+XaMTPMڪZIW@"Nʣ ?[]!lL(ݜLAMڢ Jui8T~O6Q'v2DO.nqPӗVX%kWHKoc?OUVL-6'9eUH*2Zq;)FNVԵU[=ǍeCQcS^veDga z:ڦ, 4wݱ?413!|X̝EkHBp,ş NMCU0jOp"TF/8ԐHesPRhO#9~#YjI#̺4X߰٩@& ȌEГ KJ+q} 2sh!&v`6yU_I_]rv'>i&aZeS< 1!E~"Iv*:mt .$LE|˕yRM%t9`D 1{цjb\\'|Fa/evbt۵OdmqsQO h\3%u-2%ZbKh>,;CjHyG8A1C_r>mrH1eZ4Sg1#(] #4Oф@w_W-]ѕڣGsF`$F3$͔84`<49`Y)bW_<> stream xk G M8!@Ackbd' ܏OUwK=c7_nuuZe$4//M\'׉aPaUSʉ l1%DmnOzUV}~U/I,TYX6;6zmڇiݶŲ{( MU5/뛸վ }[;t.iL&N7Na}ٯ]dS!!Jc?3M6 A9N J25J';٩HF e|](}_$(4 8ƒ Пf(YwScJg4%)jÈ2u{H?D< }i|Fq5Kϫ?CIa8Ұao hkqɢ=`Teh1;?ɴ+]VX3` ¦lcxrKN<Ds]DTC|"cUvsS9w"b10DL(~[;sG J endstream endobj 338 0 obj << /Length 2728 /Filter /FlateDecode >> stream xZ[~_!kwiS d`ɼm֖jeٱn}υmg=$/ER-w^. MFATVaU T6`L)VU6J^8W 0_DTnpr7:dQD}v7BEY&Qw_n^C緣P%P{ 2nI'oGJ|G0q^|#*E[ӵw T'I74RuM '=yT ˁWuб>Zac} B}c9_0ngܑ*Ⱥ#S>!j(1Wz_q#Hx9"7<T̼BZJ ƾ{9όP&@ɾHzQAZ(J`dSuDX&-W[ h12NBlsR:Հ~ш-yN U?nͿhYonJoSfXwfip]S\J~ϯ1|q;'&mVU9vS](x.©NgrIKV/q,˿h]VyOG[5mun@O!>~Q).ԨzJ5HbͪU^ht4lmE2g10FNκZeS~aڬ]h"i])Dnwu:u~ht !ȔUIl*E<-m az0LVTEXKDzl[2vO7˃p (+AQJ>5yh-}YlZ%fWE<P|T ]g KfXZuE7t%g·CVLJvQ| gzW`3Py.k}l҃ =1 CUK P @)z: K`]>[3P:Pn[:^ <4< eܳ(ὀX;VAzk*\>.! -?V ،{W-vy!V0;*3UPxʺ*Py- *K,_加n$=[ R!-jpAE꫋RKMx S{2;𽅥&Y ` 6>ϠZh`)aʾ5[m{Q"xFaaǰ8N`H (CI{(4y^eW s ""1at0?fV?B#/5PĈX㑇Ln߈ BбlqxG֡H q.-L@ [ޜId]ˁ&™ x/g٨7[Q1Ti%P?e[/7 Q}6t 9W, {g'cc_Ǿ?ոY=ug<Π;tt&/D>ɋO_PjCnt;hp^ UzY+Dc_&䀲;-#Vs^lq)9mu==@C]/؊aetdeݦ)%ߘKtBh М M:R{mybPdbbD!PxcX5-pNらO$6U.8rOQBGL(%5,~?Xt8A^2bghPQŬLes(f]!A_Հjq\vl WO(Ok5]t#S)89IJ)Sh\Iؖ1]_|"`̊~C5;j]ѵ6Tl\V^WI<#LCd.~.S~N0iϠ9~*_N3;2y.Xxo4 ŧ\M }$d '\NnRW0Sڿw($6B4w>i.QS6bԋ ĐT6V;2X7}K}N0Vf=/u^'a *]=؎2TD@C8/{hqU3e(C;? N/\}+DM0:)sw~<~TWqCA_x#'2DirH9A"-)Kl>83~1SsΚ21N>GpZ5J,U"]p. (AaZBJ!Y;m;YSp͞&=˴ /NSЯOW N+EP h't/ N?S2ʋ(ޑJapJ )8́UzVl%SYK; endstream endobj 367 0 obj << /Length 2964 /Filter /FlateDecode >> stream xZ[sܶ~ׯظf"H̤:I'mޜޥ$\R!{..Z˛HI^H"_|s(,'j\ZY, cb>z#U )EvWO(9U`\HeM") q_O>{"[_,|V2.ŋO?};YdYzgRLpz="+' ycnsDH"8T6N?cSjubCֱtOûE_; ^퓨.ť`SxNeczBYlu5pqS5%.ă-ʴ^,mI$Ҹ+ĞjS=LH0Svp9hӠOb _PB Xx[R{ǃ\r^1_gLb<hQ`Ta6L5Li(qs**W :n}ɺ c`&%s?m7rCF%&fgXҽmnϏ5TuЅ?F3^tA *> Жmcp+]%=zI(^_3E'z~G.dnQ ( TҳCYH-z,ENZ*%yw0ޯ9s'Sξ3cFB>u)+)L  ԱJZJ- /?F h<Rx~:hʛ{頁/oBUq; `Q ę.xeͩ3Ya;Ёɝ_U+ ؕ̽͝pT`WR*d1o6mںCD1[mx WB͚%D!#|u]o֠ثUĀ4̜htGov*:²[y7m4ŀu9ġ0R*J`r5̅{hޫ(N@X(,ykYfWSTa f>!T憏hxh5'!v:)##X2XI ZmS(M Ǹ)[d"|ׂl(h f@u)MCFՂ)d:<42&3_"ɰ1ZA>Ie5&Qtwo=P{$k ۼB$yuDE[}-D/fsT Ѱjޡ+((޴e endstream endobj 315 0 obj << /Type /ObjStm /N 100 /First 863 /Length 1226 /Filter /FlateDecode >> stream xڥXMo7 ϯ/Њ"%ȡ |+95r0EQ Exc98<=O" *ࢊ1BxBnx-`H ,ҁȴ'c<@KxJljX6{1܋99 [2 tl'aZ:51 gBu na015 `J0KxEbBʳ`y8-0eNۡEt ˀh2a0`­w@Of}p),>Z1ኂw+K:B#WϱϾvAl!46€@C\xo^ 8gDjE|hD[N^Xc3pB㄁\{ ,x=Z[Ց>j$YWثNVǖqCz|Nh_ls!U@EQ'GLOgurW:- %ykI^ZRN^vx}zq&Ur:UVfE쵷g7.9b2m:vn?(Wee}}(|g<6|ٽ~?_}r0aW|GZ.= -yFHӳu%ڇ-QM\:zJ5:MNr>W)iUlCZ&WUH7pKb(:M*JqKT^1^L9JPH~I C"9ty!a辉 ;O}T*D#HEJEJEJN*\iVQ7mj(AWeuS.$s>6DGh3uNʉbk}*y/YZ[}*Vl/YŲ%/a)Jz/ .ܮiQgdMW[eeKn__kk]~bJzdESh8M 9_G9>x;b'aQ?9ij endstream endobj 393 0 obj << /Length 3626 /Filter /FlateDecode >> stream xZ[~Їrk¹L)PM7( 'HWK"$\fx]k /};g&^Vؿv7ʭ8]%jX:Y]oW#s6z崹S*Q-;#NM0]e"srZ+)R%9ξ.͕J߮_`SgjyEv n8nu3U4 /mqz[<*„Y&~.ZCoM7Be'-kM6}Uߑ_h#2'H)2kh\|:+6;=ԛ>k_lT5&H0-/}$"MS/BzHltߖ)a "y. dGzW{,W=q*,Y9 f/j ߭b?]=PJ I*S޽qځB PQp;49Su]AA:5cl*ܨf2T TzF3K5EhDtlgv.C抶ȷX$`kT,_o|K@% gAa9kF[nQ©X@HeMEfLܪ9 FT".~Z'Yӳ WLE`NAϜB (J/Q OwA߿ 蹡5΢5 WPQ} -=Kza3a%òkzWէI<" B*c3 TZ˄VZdR>)ۼDi3)Mh i5 K̲*#`5tUyU}ϱE[l\g=S'1` 0ۘۃjzb,)s/)Iz_`ٌ)l:`10\}7yXK: "I 9雃7gu53Ff>rzez?0HSJyw,`Mr<+s#4A]Fm+}\s!By=hW͚wJ7,Xk\Ap|zIS=㇒0{ @ '9n5khS v_IXX&*}tVw",JxF `-G|>G< K6ܓCӼ X8VXv;ூ!^bSxur >fb-+٦{EzLFAZs\:6crƂop QW&' H%^,ꠄ8Ax>ZtvwvBȏyaBn [n^ۼAR/mUW8f.OcGlhTq8;a}+)"7̶VDVu#?P}h)Rh(^=R43 cm@D̷|y٘!zB~f 3G5`$rΕo@Tm'Z-T#h ȫ?Κb.C>t8hR-l*OY(p;@Kϼ NPag^g^i($te4 ,̩o4ӐTI:%*:MiJ({ !.>|Es8٠ne׋iƆN̹q*3N^A(Sϟ~@9b.p8?铋}>AL0GN,;w%l4\ 1"gL9oJҎ_%R@pRt.~ &>?<.mD}hɝꘌ#8*Ga=ρ6^p"˲Pw]TWTdsf^PNy\cI(;ns.X?k?plSiͣ$?|w 0ˏI%Q~!I[2-ǃ'|F|yMN2rl8Fǘ8zLYCp7 Ͳ[x-!q,펭 Q]E~;#V8l7MѐM $4 B88b@yh_PKG f!`,5σ`ғ@$imIY^$> stream xZK8vXX3|Jf`lO2@e0veV)v?0DQdՃ4 ś'ˬ$q2q3\r5N>_| 4$PI.@Г]/6<mQ/y/|iYH"Δ?Ƥ,l1*`Jَj2XV`|ϲSLJӍf" ˎXcq9 +R2T\1m|22cb%ΦT*"J%u/ۼ-fEPx7Wa9 &fT|xu -j,3V%k&L"?ML.=R%s&tM`0d " {ڠ\i }h.qumi(*RY Bbț"ۑ˾T]3|UX`Q7< sp:0G0ӺeMX__]xكj\s"R,vmc$Z2v>1 5 % `'U@(a{h*SѢa/π*m Z#@t,KAX ߬v GiVi ;ݩ$d`YN0^>ĹLO%T׽uBG)6F8 E.ޟ|gc_˨Q XG8 =RBjIl-oxc/CvG;Ǧ lQEp*ٰ ˡ#j9lO[zIL䲨 <,MBJ]IuNah&HekJZ]=cNPm;a,R ajz2?l0wq=;x?"l0ujmhԹJ:UP$>NҀ8M3-e,SfLg)hr xA _MNl-Nݲq30 #\ÃI3 3z>\=βR(I9&~̺P :;-J6$yB+t2lv : endstream endobj 440 0 obj << /Length 3188 /Filter /FlateDecode >> stream x]~\yHmi^CZ*K$go}烒]{|pf8c]E2zL~}ū,E&it\9%.XF?_M\,.YŽo}חVs3 LqYVe#oCK=r Tv;nQZ 3mlnUwU]T*j5[,m*;x : ~g je9tTX?'-:Ϣ꺎4t WE?'ْL G{i&8:f%'Nz[Q0MDj5"F$6[Q14qkr/rKx$fpy"ҿ.mi.y,^OKhK Q1,),xMiI)̳xN?C>K&7Q HJZ*I K @؋ F-*/lK+JkJ Jni~I9?WVjhGvV : +a#H:I܂X'{BLtSXPDVj;b(2(ڒ t-CJAg="0~,A|2¤kۗl~rˢOPzdc~/x9XzY2 uPHT6ྺO-:֓=s#3qGC ±Ů~ýVAA AСJ)' ߔUŌN$bSM ﺡlaPw0W ljw 㧕0Y?mL7~9=Sɽ9W?HwAql^o;?{zUA\OЬ'N𣎅ʅM܇?2D&B)xtGGݶ׎\ % դH`@nƢ8>tnN4V0 PQ('GUqY^G\SLfy^WʋD[!ݰbdI8r{<Z$r%Ů@j[/C6Sm9 fb=ʚз]uQ^"d 0.̻fF3{|7)VvTUAW%,% n+k}غO9h)hGS%y&2GT*4LR0< y2ṇi0(:cP[[ W14"̂GǣhF| u>es RP 7~Dl1#(UP$T&_|X4ӃRe!a/ avyJv G`t_II?(6,`*<-Z+wv4b ,]۷E݁mt8!Coς׎߻(x=)EL} r6m95 @}X7޹ۮA+<]6w7e3?*m=wzAՂVֺXAp5- ' Q&zf\{u'ԙ鏍V ~5A[4OzHUxpy(.лpPGx>]k:eA܍ՔߙXc%7Tf4Sd_aؓb?'{"7k۳@߾C $'iOHeŽ= ^$Vy3>ZiD*\LU=qo/iw%p߽{7}{Fh@#nAv) endstream endobj 465 0 obj << /Length 3098 /Filter /FlateDecode >> stream xZKϯ` ຒCqU*\RkGS䄤vv.n)ifeIr@h|"O'ۻxF>H=4:ԶEUy~nDPq_] c՜לvV3 հ^3 /#-[`pf&`BAi!MZ\:>cZ aX.ytV.CNMaSA)2goL o(rK(mB Sy=ָ^lU>%A/czj-@IX?c(SZIׇ'@#+qu ,[RҚҞI=qM?[|oKሚKX&bdIbAlŧom:49QGӒG I Cs$i`>+ 1vpp%.gliB] G̏XG:@~zvaxUtpF [Z'pTA]YϸQ0D!oXvŹ`l2ɴ|1,6\>w0>DßڹpiRό6ыIXGv<=}v@gM"“vxmXeLt@)`3QniS-Ҿ>(PYF8(~Ivj[rH x_eRC´붹 eƫ,`TOY,{Rj1hs핡سpxAOfpkyXE;0>UY2p=q|"K Lgٷ`jtwIѱQ-H5{Ecz3ư{גI\A 1ُJA[zVoeTEhlˠ%2"hFy_65[t]H]86jX`ȇ¦|YV7P{'^Q F.<}gR;JA1aQ<̨ꯎ/,c܏qWH@D lO c<Ҝ& êX:iL"g45 K,AJTEdkm*vz1 [Xc}J7 Lsuzȑ/`(N;ҿW:} {R w܄PΩ;*WT.\S |"a C5649G+-8O! =9'?'s@XTsQzɝOs /)dcQ{?SmvUa2HR{}G̈QzI.1!yO8GS2ZDSqϬy9/- ^=V#l=!鞸 .$o{q'v$-\hB~?ρ YTP^Uyׅbs p!Ҩ2CvSm8%\}Es0h2Q'̠!Vkwuk&{uף偡D5 %QM9$!؆dC5♱9| Wl~D N d)l.͇%vS']0l݁(:}+g=71o>lu E{8h:TLGgN?!M? T rI`\ĝ^D7NW %MgD_`Ň щ/?,$a?&|D: &:TH5V(^>]cZaCE6euh7wO&}b>m A$lL7shC_T vc5tr9.+R)BH''1ql>^>\}t~d1UtqwyN{E=dq̩?>+4=_8ekd)c[lN9xa|I]ӯ7 lDPӚ57C8l'x]w[%%<;DϞ嬒TZ H^Fc@}ix'?`$}{?>.KӇcPx yȢP"ՀOeXjЁl11&1Tz;7#̋iāCfY|̹0q p#>H/w̛Ҥ^p*;@Y$.>8Ș5PĚRTd&aq$ L\hr/B./\ɯ]Fƒ28P/rp ?O9 3W׳xޠ14=`<1?#݀QO 8B 'a;K U^4) RrAvv^YxsL endstream endobj 390 0 obj << /Type /ObjStm /N 100 /First 865 /Length 1257 /Filter /FlateDecode >> stream xڥWMo7 ϯ/J94o4FF(va;@8ݵ:{3OOE>Qz*H"{IQSe“Rm''%2I&.:H^[-'2*I%;GAWK}£9 xţZȍCnIJ!n݀D+CʋpX>F !3\Ah0 r= .c >0{c=FutOT:hS@PW\_O_U `A0ƺNu:GM.bq%ts cVW8\l=emr*P-sɭfyٟPR/yW͍McF;%]CX< ~ӕJ]:+êc؏+'qIqy/U\İZ;{*AMN8d6)),Jtk]81m`M'AS6h 1T! 8zn'i +{,R%䈟bKCbPxkWA^dkiA^c5Xޖ~â-s'=x rV#'rmqOjC9KZ$Y(.UoŰ m7y4SJ 3U B+I6S VIb&޵ oC'A^: \(ȋ S)I9emG߄Awa2bE .^5GY{>S2*ɶa旱S[qOʄSUaqJ5۞> stream xn=_j¹qfھ&vE Zm&%u|edZV pfΜeϮf//^fD(T1;BcfN"nvKwaW~! 4Z͵Y]벯:+VeS۪\hWqE8S.xmh9i.(DC]Zf&%2W}We\|w|\7}2k?lJJ+L.ӹez8LI/ 8CQlz}>[·fnijf?X{PsE;I(QHݮp cY^eUTww]_/PD!o&ز—m9&&_n׋ެETZE2, P_۷.f m>U9lQIn."+ YY'l?^t]sPli7H/mtbxlm30HQxs\74P =I9|. ]V ƢQMRVKsIfʦ!op7mP5/l7Ͷk&@څQ&I]Gn ;((ȼu$?a0boNeӼTYwS^")lpi Lb7;6.~ax7y%r{_Alu%LdJjgՄ7mkt›^r0Z"9ߧw~@ Gkq`lT)~Aj+`++B^3ObU~&P{-sςj '>j|R=f8ʁ!*=%PUǬ4$+4ql3_oaTt(&>= F'q1w.Mc-AUȩ``(a.:a4esBBuy$u:~z`X\Ϻe>A]6CcB-.;6Gwn|?VRjDJ*H/ptͣlD3U`q{q 'mUlU.`uF緤4rAjGMr*K"m|ͫ]7hX =c4Iڟ  `,ՠ> Ƹe!ѷ&+ vR]VulLfc١C =BG CyT.0C־yP= K##6X11ipHf-ݷovMcqvJɣ>fWWWPmZ|Z5QKiE7P] c` G_dp/lE7tƣݣ9@P7q pL-TLiKxxCg4T2w8].B]rT%=^#K3Zո^/2l 5Ҹ(Ӫeo[ ={pݥ5)%NC&M܀:!]hƢOŶ߿ LZV7MGFaGĢw׻êѳ:$5b2&PoݽIOi(فKVaܢ AA*mR<vݷpާA`-L.p܀jv ˢ>vZ`T9.VREyy6wy=oϱ܁5=f-[--թe gCOp::쒞z\2P$\N@R\c:w@JyA%ʑ40ݳ 6띹ZƓ".{O>PS1^c 3#ra5C +P aL;99GNN;'E1i{L|?"#Ks^x=ڤ-oep@>(7Ƒ∔ޠnóz@1Nϵ kH?K3%(*R\…s{COQ)Wd/c OvS,(͆L%#?"!=%.OU+i?b<'g?(PINưKk C,5&> stream xkoq w6z9_PdER=]R+r(6a|]{)hq~B-17_' ҂FLa&Rbx{K/#Nb>*OIs㯥q%\Odb/N^piQNTaPaM9>=3"\~xr~zh9B@B8A<=cR_.$}w {'o}uy+ Ka^#wl8="74-5fA'ؾYW Dg؞GsN{4aU0Y"hO8 W&6Õ~jJoZC n$0L9qʷ '{(DEPCd=ۜE”$EA&Ծ(!YNnW|pԳ'>$O&9s [:N<0fH>9uYͽyy#ZwzVKF #LV7;gjCiN-NѦD9Kl3v/#H)E4~ĺ/e$ 0KOCr37dɩrUm69RJZ ]Ɖ )`r~xS7~dp*DTj|UX.9|U>uо%57Wxۣ_qZlxfP_B^.p^r%9SmYnD'*sHtuQ1":PŬN5^`|b֕q0(Ϊ+lMpM"VJaMU]@?#\VTQ4!п&D:\(/g"O$:;Oŗ;Ǚl淿@H:v`kEҹ!2@^'N1}E]Mm5urK[NIJ!`$ b0特r Q(I<\Y攗EjB9HH›rބl5oףnX|žoq+3)PӬSBPATb4'[KhcET0Vfz+1ӄ PI# (:215Ech6!: j*Qoܹ ;^lK;R2dJv~(5ђg';I†a'@0/ YJ$V瘕_I2NyF$>GRJ%-n8V.oQDrw~YEGa%$2.gP \:FB 2 [&w(3 ;7œnN !G:fb'$JYU59]h|!h*Dfc%K*λ^GND}zrɉINt+%.e1bEM`6TH&pbC8> qx}u7B<1b!z#s2BVYn$g.tͫx;}y1iL//HǼ ?sgd_!x\`řk\ p endstream endobj 552 0 obj << /Length 1502 /Filter /FlateDecode >> stream xZKo7W,z(VEEHZ4A^!- ]IMRÏ\~Ǝd؇ܥf9faū;m3wJTN1-\eڈj4߉I#+!X0j&oJ6x%T;aξx~'kL*`*%+'8U{e;^kΈ^;{}Kcw3zM;WD}=颀ikW] 3)9 u7) 4A;h}}p=P4r7G|vլsj30%"Jxi<ڠ:{1i{n^On8qDk*Z! ){]5(A~[ꐉT,\S!}E9|+zmpjv ?<0hrq $wI9WXoz~9,`SO8+_5 >,'-~'1+|uN\=('83|LįJ hH҆Ҿ Եm@_*mUSji/}xǜeHMjSOaj:SSoʩ&5S3T3: wvdtWfǠangVRypV^S*ӛ$?LMRgujN))T݀@Ay2=jÙBT(>A')o23@^hd}gi E ,Ih:6Evȱdw--SFtqU5E}U>8Ҳ1tO(=Bκb}wG{וXZpFQ5Ix/J?.< Zg;+4S!{D.E6%;R:93+3e6Ѐ :1}[ƕ$U}~? / endstream endobj 483 0 obj << /Type /ObjStm /N 100 /First 874 /Length 1217 /Filter /FlateDecode >> stream xڭWnE߯/."`e+v`a553gNWLNm鴦yو'ѤFDIp&x5JMt&ox[qfsOh-m3jjm]iXCj0 \t/#B](Whgc8  te<۰ BA8-puyi6 !@ ^pIM-I0F٘҂CX8vL0YV;`6Ţ%``0ON0Y! 71s(@: {! v3 q Op4()ɂ1l XT\jSeD3 挍!b鏂M\mO,K 3&$0PɥUjHiY*em869kMd*6ܨZ~,4]ܝ/ۅz6_| ݋}T}`VK5x'+Ҳv6B"XO☺i>kA)`(iFb,iM4m;;ks4_'ZlӇl3H 4 ,o@u}mhW/mқ?8ŻXpy{_n>^?iݣObAx2-=p6Qp٨'nnҳ N<$ާ8 'qJy}q a 5jX)??c5E^ALjX>cհ$}+G" ^ OSG?OWcCRZf ت-^swjYuLE^+ eװp"_u k1zk ;Wu65bieYtH;:%,FuְZE9zHCW"/K>ѥ%„Voko"ElPT>t{`h+*&u E^nE[5901zQga(*YT>ꫨ|8UT>Ƽb QT>(}ԼdE<uDV=׺px<{n{ f_`y} S3̉l{d6GfMl{d6GfMl{d{[Sf+,6N8Xtk論CNn endstream endobj 580 0 obj << /Length1 2143 /Length2 16304 /Length3 0 /Length 17590 /Filter /FlateDecode >> stream xڌTk gMSqɶl5ɶmT͉zZ;N^lj늌H^V(jkDHTgd000100);Y##S:8pBh!6p0H:[l\\ &:p \̍2tI[#G|((4F6'3GF#+9BP99qӻX;:~;@1/Yk࿩P5qr5p>VF@gc#;@IB g h.W s l lmL&V@4 /C+Gs+nP|07?G#s;'G:Gs8"6B@'G'l4;kicjdbncl cg;zs{gm>Dpd@'+;h@/oO;[;   ## `45C 4迃@c KcŒmmbzYuUSRP Iebe02?>7+K }D1pGCߓAﵡoYۏy(6+/K+:[Y2bMՀZhA[+p2SQ h,odd!O>[mp GsFGV?VS{L}7pp0phbx2~,1:}>yLl(8%b Az"vF G?# /`ALz?@}T/@G?#꣼Uez^?L0}P?>jQR:;ܟp,M0s32V$[/?xl&X0[?`(\*뇹Ǖ# W8?>Qއ?1}w9;|pu4[^5 xsݟ'WK\vt~BNtHCY_!|-^E/Vqv t/A|ϴ^^ୠݒd9Hybne! lR/esQ*?r 3pha.ݐͣeOJRyF1zjn1E?.xW(39jߢM̒{ %Ib/yEn.eŌ -H8Iwd;XMȿxWe~6}|%WS5%9=Wb:&Ea{y/7L4 YÚTQuj(|ϥ+Ud5Ɓ-?l(pqZlT3pE3twƉ9*F [̮2UsS3bx|8]g =,.cfOZ֩#k,0V7,#q XN<>jih0f ~iS9X=.U:į3$/߁=͉R◱<"yuix[t>JTka%fa,v4\;0җ X:Љ|(3OΒE"x%E)XaZJ\t4M5j /*(D@6VDxcR/K{o+O-Ay7|Z`v&`5qgK6jŁE_Zf9lDhEOĒ&1 Ck%B3ò(NRHc[Yn0ی;lzE*IC'x? ҉%7Uz?0 5^ZdVXpG|"f;-3;|Ez8?KƝGQRCb*j{ RbS_ufk`bqyE~P[H8PKL)t˶tN-6"DK5n2Hjě4K?:7DK Ѹj$';co8; >'zwq o0Fd=>D+p.KH)Ü3[9l!hUSS2A v_SeP[Q47!}Xe[XOWNxj"#iڥM,bOǺ:A~ef1ݛo:kxo-/KĊP,t]zZa0Ka/,Ez5򪋼%o'BJb5 #ZTKcCXnz zdѷ|V˰չ(d6n@zѓ/`ێ(F07cdU:t1D$$l ^+U44C 33be|2NGraE-vv}Ёh/Mpm;Msb`y>Bp*t"Bِދu@zlѣЋĤ[M=I#yʍ>U hV+޻)TwlrE<AgEj_Ϗ6Os1KP@+,aew<h4/1Ϳ^*8]u U]0MiB KRƲto <4^΂~繘T0ݿAQ/ǔZa ɰ ?~KZQ '~=BVJpxg19%R*k7/0Y!~6 Y)Nv4ɭ$fs=]9钵j 9*0gv rߢbvWV(L[7*3w]Kq*of#붿F)ԌU$x/tSQd!b%5Y)P6ecv?xcY=jt,G8TR@/..xyn{wTnϿyjr 9fZgSeJk:"+~EoDP;\"3^-ŤApTγdMx]VYv(r7|5 mt32e>טeWk ~ڠ&a9AAEZChc,@V%| N1QeyUh{ 2mFhiHD ,}G&u)60ݰ)5743LH|z*;#]$ZaDw~66p}w1lRp"R8rZ bot8;=+agƳr8\AOaj94 'kr\'i!P98.CI'O eȇ@̭mNk5G}V!BYZ"vy՜sJ u^! nLpF]ݽ1r=OBT|x' d!S@PWZn!v QxgDG]sb`4 >Bq>;Cq4xā#RQ ace/"!Wʔ9Q!_]]뷽HXNVB@ w`84y]ƠKW9b0>?Gй -et$z/kK u {Ö4C:XT:H .5J]A~Sc 9&bg`EM\:`Kon"'dKi?]l’|WAPPɲVoO;T\qhX4LךϾYe *|A(1ZT&UIo3z43ƋX3e |oxX5rL <^Pb|&24Y*(_ݸ7F}B3sď˩ 'hgҘ.^CEm CڧPNJQQl[z~抆%}@qN=+x?p!Ya^arYDe36wGtW뇊Sr(tXijz27+rbśJsA-цMb&V=Z~ E !`rOZ;%>sG'/-{,CGZՏЦ,ŹGb v}dȉܕN\8vG''}ޮ2i ~ tɻD<woV?(_Rӻ=*ֶs0L F`ޔ~[\<A9}(Y{Gbc+yDV/vz|5pytdO _ߋ7ѻcItrhd>%e&caXtѐcO)U1 E(UNvi=Z6A4Z I=81zra,4}@l&߯`hPD!'bh/[Q 6O'?ײZej l=L"3P3<={S-Z2%rN]z| j-/-y7`D 5MB)L7ّYm¢xTv=:JB9Li xBCa6U:L?Bs䀙?'[Lv`d&g$>CrBHskAJotΨb'Og;]q+"8V0Hpdm*5!xqţM?pڠYg;}޿-h}W~*kED1tCx#K S^IU)-nBnSH`DQS7ݹ5X v8y脥6AU1 -=l=b5t;jcSHRD1_h Ҭ SDZ҄Ѡlz.O`p"-Cy> RDWSh h)NS:;!mZbl/ 2ȣ^uRZGLt])Ɣgw*S%9HT!,j m0{|t6|(Aw`; ΠxtQ[iuLG3^3{F 6ȫl'$b ֮ſy( ˿Խ/%, eEMhD1L4OnbK,L10g tk /k6G`v_|qNOQT!e x ^U #U8Iw4TK6uHJ-f7I U"|sJaemO`;8]|`6\_hݻNg >b{kRƓGgj_vcn['[v[rlz|˲*$(_*}6WZK4ץI7'wq̼e*lO?E,p5H>]ۢ}x܄,č#,\̰P6V(K%%bgK2whZH){u,YfXMXQX}mddqWE.5T0 vd깿AdO+]cbE ;㫬1O&ItֱJ DTCn_hP(Nt}&lNsU0&6py u|}Ppvu^J氉m`@JvBwE%9f__'F7/DN4*&$.;tW߉&+9T.C}Be}rT#Z<7)iYh ^[J㙂ke ʈ^:Xn }Fu e61Cdo42A+Nɸ׊ӯp ~eyW9 Ͼt jAt _(z,I63%(ˢ)j'C-L|ۅ*C$Bxz=]TO1!\ɀ&UHnY]jkb¦s6g׮Ը,kי&R̥`e=aU:>-; 1kfrX/2*=t4V%U-d܀[x&N45ٝA|oOj( P[K~]eFlɆ"/atn`ZQoiQGGRr~JVх{\7)ʈUPIK\/myob;ܜYk4/UMFl}cg>Q&T%_XY!_e_ʰ[WSG`7Kq8$=i= 'c{>@߁+2V{#۵/\MzF:n+gVo:OôTN= /$fЮE9.XD*eQ/q*eKG{ky1Bi7MZh5敏<>-1E(7 l; kq"Q"CX R4:>ЁDeCq,[ҝO9L`R54Ksy6+vM)l<Ӂp3 "SI,Olð.SʌYN?{nmԉ6[hx#"v?.:"/\m &tAAz-euфP 0 e[0obJ0Y\3* _oZX{5K\-|>:N@h_zog/fkC$9Hia^9ykP5 =R!:?{Cj/u:Tnnގݨмpތ k&bGSSIukǖKyx=کOk>Wd(S3Wq:fīd! h>afә'ofhr; ܓ'Daw"*@Dȗ~;+) TO$ >MP8'5Az,YA JYSr7LF_ -US떙.`RBvSRH~oB~ך?L06>2E0sB,R(FuaNNq905|ZJތH JqHhB-Ur{Pӫ~1JWZcII[NJ!<.},22Ϳ إ<̔(M:_c_KMh}%NiXRvgJ(nNup\4e-F)*z$e65#`ЖXww^غjdoVotUڴ/}VN3ɞm>WußE}֨o6:#R)7 ڷЃz6?G}n2_,@a& EU)B~rt'[D tsS'^C5<74Eb\A?dѾ{@K7AP=$ra[`~>% `~)\&5>;1[u/Y[Mj:J&`_ۄ:u\֣ŧB ZY٬j.Qrؔ믻IlkQz乷}Zu!qqIMk[eK \"<8D)?MB! ma>|g5YR l8䓯y)[Eآ#WlOX+r&!3paA6r}}+ҞE /h$ ^Uw]u]Ŕ&&}U(*~;∣HkBՄ:YcBK K>b #Hw?3.Àma̗8"&."RxBK/nsҽ)D>}w3A>J#[,peUf2zXqVc^ <&G\<0~hiH$NVe0K}>+ ʹ\)$(U;*MRz_) ) ƪD'-چe;''3&IԪ> Nw !NͿG]!6W=ͫR?{j֎ 8w[776 қSC6`拉 f\-#R3"'o,'riou#1T'ߐĠDO5ӥX1!|%LDO~tv=72Gւ6Fx8eB4z7y =qI:Ci}hX?+J$er:+= P5Tơ`=f0cLή~6 -#۸֩LQil峲oa)X 7٨`{:ڝ9`=ȀsՒ4n&&p#بW=c~lJ /"".ʡJpkBP 3,f5C!p4[F7Hmh+ zigۣ8,uΙl~,V{Kɬ-k7^"SoԹͮuVe{= xv8|)A` " ?oi϶e )8e&Tv1 u!3l pNs4ALP u^eX ,I]6fH^x  9O ]Â!"5+~kkï2dFsdƐiYc\QVV5v뽿w7 7b2XW3ĦUs@5'.pc/2'$_MU1VY]H̥ J|xc-ft9lO$NjhՑ|O}>XTbPA[ev 2E1a@Vf%}yPaH6PbkўXšܘ{$Om, Ǚ#ޱE F(Ҳxm|otӚ4 ǵmU_rw+^ I 8(| I@}:TBuM*R.j]AiCW!e4GU6 ;TaK1ZO/4;ȅW6Yez n(5BqV,1 kohD**EJ:1#Tzj*#6{ *52SH2Q=%d:2(Ȁ|+@IH%vI J\iMHZ&*+N'H1D0'ˇ"J:ˊF75DHqX:DϞ~]}A:eC=Q`3O\|>/}P˴r@_lɁ}B$({,XHZ܀6+!gXV! ] 1.h\YN2T]xRn L޼4MXsVBa.˓Hʳl0FGf^u%!X:P|~0u?*k{W-B+C`0h6I.A6aV!`աc:7xf=>A-A$s#2)dA= BY7O/8aCj+ :GH}5v *CLOKD1$W֥#h2>l.U&UW߱0<2oTa9Jl%'PJ7zrTGNAr*.h^ W <||&#6q;h."D/MD.I69WT*A4,49,'RsšlK*g/[i~{z~71rM4E}Qaηmkp{,Fp=b&Qq+;U/i _5E-H3tPR?!H_~ n65E}QWj3$]U2UW3-{eƟs9Aq5[O㔾Bnႍ-JGSw).zlktx[bé{OPs5y+|1"疡 Eqt~MoOss[WOitZrrZy\e1] @L״Ѵ8L̤YNqoi-p- A?af6 !TK9jMV;P I9pP7kCi Zo.HI+=~#dJ2d˅SrxSŭ\ ~~\j|EJu#B( hof}r *?vA^x,iC7Krr݅إ>IfKPdEr W?{#2&l#J{SJ% $pEyP03"2.cSd1ǫj6C']xWxU(9YMj83uRv0c麌Aa\K}~MKQ>.B!l&,RL(>H{< 3ko0 v;^K(N#UNge4o &g4>גsN*_ܽid7HgȳNJs ھ6:ӓLC/e/Eyɋ!RYV/z/'.r;ЃkSCr咆ſ]zڻ7ZV A%ʯpKoPWhIUEUI;ۤ8\pH$swqhOyp=Qݍzd/uǶHW1Pϩ6T.NŒ8.+Q;{h{^"줯o9|؍8×(5V5迈mVA$FymD_EJQ-9b]CKz!LI|z0/2TI `,?V(eu0+ukbrSO72꺗5nis[X=v͏KؠKn&&3q2 kʜh=Wx-DC@yM?{#C :N1ʠ/LkB]` }#p-Aݮ@:=/-ͣd`/q6edtSP7@|ah/_ V "+{%aMp }GƝ隫Vsz=]-cޥ4u漆q,N?̯em)_B88$ܺ/~nvϰЎi_qSڡsA\Q<,]a|!&9)oppy .q2.+mpyvHj6#KAhds|QIﲗKYdO[O٥D8 YLܥ0֭0jFØdC2}pƛ$,zfޡ]m͎&_*I3Fhqj.;P*7 :ԑ G" IW x1V^)σi m $q؅h=} HHȝtZJ0?6rjN eIgѕBtTϹӬ!{^רSrrcpi_^uUPɷQ\U6 endstream endobj 582 0 obj << /Length1 2149 /Length2 14639 /Length3 0 /Length 15921 /Filter /FlateDecode >> stream xڍP\k ]wwK !Cpww'8ww_y%ޚZOw$UVc1s0I:ػ22DY,,L,,lV(5A.V|s]e@wC{-`ca3@neP`:؃\(,,]@cJ `f br2 @[B[:13{xx0\-iVU d2@h75&J˿j@g]`ke wywq79޳dJ ˀXXhj`[قJL _@[w;hnсI:[90Xő0e7sٻ u>q+g{ݽ}6>AVf0ssdְrrɈ]Gfrpps@N%_ ԽA+YsqtpY|\ 矊E3+SW Ow1_<z, `'3sc3+*(FNv#'+8-UZt,"؛;xEz!Π7{?4_DnieYz⽟\gC}B_-`ku2 o\$f Ͽ{dx'0wpFF̢bY,e S0+ 6Szq5sj#~j?=_f6|/|/ .{?wps?;'BwN^Ż?;7wrv ;z>۾~?+d?뿥SB9Ϯ?JNYy)_.{?3}??K^ww$c{7a2us~{j 'aicu]h Z>KΝn(Iՙw"I#}4$/>ǭ m*OF ӻS؃ߎE2 8j@wR:(c^2>W%\6Y#F?x2$k ƕO7z>ls޿*\z(tq oǦ|Deq|Jdã̉ ;?8jIF'7Gq>lOǙlQڪtsϼ t`{GWf: ڸ*E%:8H^Z?C-@8a$U|orR.[F]TP} pՒ4#i` 8Ai9uno~ceCa$']E2=tl5l=ԨS9Z~Y&Bc u%@|j{e"ҙOfբf_|eʦ¤ =>)|*fk%D2M]w2as-T)5 :U(ae'#mg6ZY4ҧjzT]n#<7POmoj)2h+v@ϊ]*+7ߗ!vzylwl9)o (9 Y O,*F6@"0LxkЍWmKzxA̍o3}2l+.pM)çIFZL[MI&ՙNSŷP9b-\-9=֚jܘ;AdkQ4,ooh.E\)jq*#HinilFepȏ4?HRzkC MRBS^JxC~<( mȇXNpH$"#Z歏Qp^f{p5a~52vѭolpaR,}eNJZKvlF:oiWw/W:gJ }"fPqs| ه9\ F?Z)cfo;)m;־=\:0}1Ngy"X/b<njok>EImxӹJ>wFe׸ƫi.1|F$9QһJAŽTT]8"o,)  a0`??-/NT#Q(lL xt,V0ڤғgckB<[ʺv0v qO\m _x,%ziqisAsb] ieHŖw5/ha%7TeVD~czX2`!t}CQet%|?jlB#HDW~<#ې r ~o<5KJQc>OmKo+Irġ,Ҥ;@J/4QC݉}*o ϐz>aުZ(A%@#D;2uGKྞSFs1SּF=I'U 4#=G=ZLT*DDd+l!Dk]RˈAO58ȢV)%BK뜟o~d-~׷C !{g;oK0Xry|0Xr &V7C"rb.7HSJT8QmFhtDٍVXV?FSdrO^tj(~wVR\fpM pw~To]C}#U;:7y qg_/b2BЈH. ~n e]dr]?!ۯvx)}1-%Q$auғg~goT}L,SGn 3-g;I zWh@S^P1l~#UlD䎥3@-VhHoߚVCU D4xMhʬ5=[ w]Ѣ"C$0%a&:Zp\J· e}V"f[qGM-EDY{t(G7t-蔖G~Q\ï lF|5c9 ' I+F[zN't0Wڇ'Z7zLRSyD0z|a{1BZڐkͯ%g ƾ:NIsWD\ n;q2+־29s|;>8Vx,IƞX>qR\4(;.,49W +CG>L'R3B|G4B+^g+TۧN_΋!6ɝeh \ \塠_-":B ԩ|VP>t!R4d2jpaZ0g/P.eL:keC.mBDcZ鼝h(cҔUYW=m,$uNrY HUV\sh9*3@ǧd|fJQ}U dBY&Ba=7.>LUIޚy$x| n87}ؒExIзOR[0Bj|| Gx3brG4U Aaڜ9x&'M !]%"V7 ){H4NR(.翔}"ֆnv|Qp_84Vmœ.]JV/76ܞsg.¿p@=:^b,mVp5I1@}N Q<">ߴ~svP%G gyվmt^4*2U^Rs3aZUXEүGs!i5$GKtm{rCi`OzCjT3.#-1z5Soi𨹦ykz y'}0K h>oE5Y_^ֆ_5ΨOOB`=*@*cnQn@wvFhsXB*QJ)?BoͻðZ rpsI%`^7*޼Zo)qtb.uz5Oj~CE^7JKS }0=ú bQTeJ5O_o0,9(>oeqeDlz|Rv)M)MU7;HBx11yHV?g6!PA)R>ҿͳ6!!Ǜ^TqUix*I,<M]\ H~# dC~AL Ft3:Dݤ ;n0Co7>Ӛ-?ˏ YC 6=Wnn@3ۊNcBz3"v)Bgjaah;MaEi2S|,p%TWT? hqo @",շLa_j#z|\N)1q nH u 3PBe_h;r-m?ІM&҄L4 wVbUmb]^!/5`1ap1v$.Xt ޲AP=z¨롹M]Ϥj#ebq=(G5NOWDArFwtk-oCp_&L"f2ݽ2ڄO/ݳ,8hsU'L9uÙP}ϸP[,_h/K\jGDs J| ~%p.mzd&8YgN1&zj_CrWRƬ[2xpogbDˋyْ(>hY|#mlXmiXH Vʡ$4$}<>lڳ.-EJ5C _!>T1|6鄢%2I9srV63^OǥzS€mvcg݊2&(^|~&,K1@o4Vj8JAdn.ϩճ=}<`Rsz3( ^zHఇfZ\"%ORbD [~ہP r"ͺ|wx] ~cU*yk|j1؉ʖj{/V< \_/d;*C>ѥ_m51AO| _jT &O[//@1?.4 !tC[f29GU`9C(Ͽ:ꙺT$T1ᙲH3* l{U0?=VJ{]3oj|@c]3WBߌדY U6YF bhaZuwT3\YOYKvW0fcqʱqHIs푡oܮBZ "' 9~ 8`Af,VC}uT{PbmgMa}}U=#lX~8&s x#6^.z{cv&k&tcаwDk |o[МUB(DAN"rͼ|fW^&N4yϜT&Й먜^$5p@HN!I_{eC''_etG/ k3fFN@ErҲӶ#ғKPaaKK36O_,{_ 񊉽8f(,_`]; Kv#!Mw!u~{*t(五)Ԃ5 )%h7}-2hmr>}$_\HI2l w[a˵B*EX(= KXttA={h.soi[[n,ʹa^VgLs NoFPc`/,-Û0:oER[lݪ3Gc }b8ehd;CwCuCt%Ieq \.VY-ZP+0m'cesZc;, t>s )OME[Fc>z=: bD3RfG4{o@Θ́|_uXJ%<0oޕQ!~H$O=1Q%d)ܯL8([`uaM6ǥ5qAy{7;ve_NZφ]tG\ߋyǗH;L[$9(}9C22I[rzhMZn75./q_J?ik$z:E֪N Z3$9q sVQO< b{jWvi_Z;AT'5]xQmNV/[eBw#E5vH\Wssr Ƅlꓒ(A|+F&۴1/v" TYE'5_q'hTsg[X5g|룫&D\ڼ)UY ]d "gT.ƚ[m$E*<C_h;Ֆ%{:ew;{`VnbRME4u3Rљjx aq ASfdv^X| qZXƸc KgDYxlqDJ( ě5H6+ٸF.jAy ` bTpF!VEBA` { pf֓|F7fNi.ĶdnAOaƐ} 0lsys>AK$W+Q>Ξ'|ٲS;llK4@o=lxh,: MLcH8~b~&?msfygw M -ǡ' nPk\n:,rf\-@{)V(ʐgK 694Y& $[rY;t ;rm,NJ[nC {eN|#PȻDM*mG!8>֓d$;UT˂πΩ#r9A|ِq]M~z\9"±x/Eq^vWor,tpad`>u1w[0v>RŚ D[N6քRL*MDw,8QfS?aʐHG$u,^1iv`ac.f'ҹ[ 3o7#/\ u%3 LMPv +~lv?#1=#_·ݷl/Jcxg(7k RG!QizQ"1[Mfa0CQGm= ⿷wҚ ,x:JC[yO7c W[Ÿygy=ܰNɵ#iju?NymX5l.h@R~̆8UX]:#S4a DC*YȘljпfIiA#XBW1x¥Ղ;sMQ:e+ ?*cς*W!m&X$%,6˓fv|eM? np`t:FotB j4J\7ևn  8hi.+BвVrՙoD6;^d7- !Kd݃7%NjG} W^Q~p|s}Us9)0V?**rth+Ekkku^BbZ%ƵZ5$ }8u&W! UR\4Z<ux޽C:P .^fǓ0kKHBa`0d*q k&(-ArtAWBbgbJ ($mpfBUəϠƨy@:U(]Mc[qiFƅo`ǐ;8q_g`G_'oRJ|65jϹ*/rzRܛyFu"aJבqm5|̗+"{)-Ǣ{闔)>>!Sͪ̂_bͧȟi<M}A ~B}ְKs C%pp"zעqP:#ES}eUܾfCv XqV sjgf6glW:RIwn W(yN*B]@HWJGf.wZ9EAϴÑڵqBPb֡X-H 'PWMBq7r7#YƸl_0!qؔbNIEVAU ( A0e`t^%uu+P5oi~|.a]gu*BZ@ssx9|^M6cV=!RCCU>w&a ?22)ox_J;DBC1x H >5th2ZQx)fP _H~YB #ޥ1LiS#vT>`T*~hvk/hAh8*Kz=bn08>'3Dz6L8 Pȅۛ#.Л?Kѩ3W[FdT31?嗕)vy'rSk?.ùE^OD}f>aR?CedzFhkcȆ\J41?{z YW@TbG땺 :V.ҋicƛU^Ope"y∘b5DKu|T/Syoc9hDBpTPl}pc%p2prw 4˄~:d(DJ{ˁ3|((?Z иYs;#3dIJcW;/< :S FKar^&̀h.Hátsg!ꕊuj?YDEVz:URUQ|B۶G ȟE_ cL-XxS#L\T!VsQ ,M-kW}|q&Iy}NLvIТTMT? }Hj";ymݨ~ L/:b;Xm_wܢ~& k8 ۮRsB 2@l!:}Uz* m^UDa0\?6F(`BfB:aI'ZZ+;]h8N^[==u @* kI>Ɔy[0amx65!h]!45wh3ۺ=(wZs!GP.Xky.&.8:+9i LV鈑zybc|x[sIґpe;ԔdX>c9 ;]DG5d28.ҥO1k)eŨm^ t>v?T Dگ <5sMaUVQvHQ>G*T6 nr3>OٱOO0ෲTtVYZe~ R#S#~@-g`a6th }^a#C=>AFϗ{G O_]K#˯B4Ex#F.t:y'e!Ro{l 3.YqrD`gB )!>1xxk6NjTac|PZ~2-c5>[K'1O=P5 #l93*2H^}&.m4|?'~HpYu0jf1$z mp]kM 7 2 `:.֑Wi,~E4JIiΎ=vR^SVj^dKJu !gB5]jG~d$c?c 1 8] F$]AgX.Muf:68-9KV5,vx GqE*9Ԋ Ë|"&e>!/r;m~x?xՏ¹Nl>byY}nR"j@]zŹ U?C_~'{ѽ3]piA[[6|>:{}?pRrSX"4 ѕAMUޏ6?uqK2O繛^Q6'c ry`zi;REL<\.%\|_R>a C'$..jr?q;/nY2'g.)3?IJ.fW0yO /9\6G}P2{*2> stream xڌP]YBpA݃-h  ݂ܓ:{*cʘk2"E:!;#3=#7@DNB OFjl G Ott@h :l.&;77##vQCW =@O&bghaf G1/w  glE46[=CAklFohDohOE pp6(@63'[8-W3uv3t@k cH쁶m@ 6&zEdaPwvwښ24vZX :!@\H `J-읝,Te1[;Z8Ae`Vvn^S [_I3Z8D1̀6FFF.t76gEaKK ` Jca r2t]>^*&#-ovh75=&㯟tAebgk2H+J(:aa;w+#k8@>K/?Qw/Ƃ򟕡7hߣh yr7XFH/5_?Qvqh9lUX_!h=lͬ-;D_@@E;'_ ԰-Bq/O )fklgkփ &@F@ok r9(;Ao`8 "'A_` 3A7b0HF]7E@~#Pt߈ /E7EW@U~#Pt]7@4E\ Ὲ 34 o=tFFV@{_[Dh/bY&V_?? (&L s? /h2 X~ALֿ\20g*9 ,[AgGjffڂ6=(w߇9G JDfzmLHFVЩAWU*ߍ;9M[_R43gw ''Lj H@o3UbPRÂ.pgsG ? Y@4D@L@ǿC4vq5St/[Vu"HZpluy|"=pV`"Qc LXSRO'8剝fq#^|8<:U]go+Fvilwhn=ս%Ká;J2O%tjQ:d9F3XtԨH7SYcq4>,^Z13+T:I!nP'Ƚ1缊 y i,!3UX(GwW/1mgSm'Tף;+h֏Dsd﷙ ܪwZ~[䚬~L#j7tzqXꣻ t?X?Q(+gD-fĝyMP v3aW#f>#'T70)[EOY|4ʜnkQ|ls1Pʜ4Ώ9J)gu8)HEz5 gDr*JdS5ɍDJ`AW7{Aw^ ǛzV{J+1dK$/8¸*$`s#[D?&Ht Y{{IE$DGj"`P5eUS>X/d:kg:MM DiwRMϪ+G0^I?ei2~ub_JչqrL%f滃HPԔ_:Ŕ2 l'X|!Cͬ8]Jui`}?,93YQg؝0v 7,Uivfꯈ]\Ek=y2TX?6tͲbzB&춐f4.*Ύ h0s:ɚLon33D  V^?1wjy>R&hԊX9~#{Pa2%}uuw -Aݡ!fY|:|29F?b);3&ˢWKff~l^Ï_DOu IFQTk) "I-;m&whQq=ef>Ф^2S7`oBZ62Ij/x*|Y4BK! ;K嗵 /h]۾/uLBֿ>]ElSxrEM"d_뛉m@}HF8lS׹LXϟoݮdS7EZP[pMV{RRݽ:HQbgÛD+ULdLO.ֲ"L zl#8_z& #=DTh:} oTGXJ?[S^LՒ4vld85TKIeZS.j>={Ej I`5we * ~ / K@3HP k+ʚh8x5%gy t!'050"CW&(q2E%-r;t_Nߥ_RhCTA»tb[3͠^ wKLPE<%j Ɖ!^Y{eX&DѲ}1EiL~h4&2qԇe-)-b$= S9 ij>O =zsd#Dmg #1u4%f\Eຂgrz2ѢSm66oqiOªaqc~ v3LS|)Eb&[X"a\mNA)6ɭY3^X~o:Se^ 7c5}z츧 ? sP FhWF L eutBܵ5 D7(3/bǧiL &e6)&і׻ kbϫC {'ty?!d 5Ed]I+N%M?t>Rǿ}V(72 Yji[ δ#^(Tk2;41܎R#=ۍcG7fu>I]u;ғN|ǏsS_H~|TT&A|%,ԇxӼ ױ4h _?&!nuwSK/pX$ۇ:\B'\ڗ~KS w$CZd \+h@]8,-o/z 5ݐQHy; ee [Rjl˵nOEg45}@(qSG0z~A<"s;E2]NQgNo:'P (2ϴZ bE+4]ӷ,-:u'//liAjޑkÂ%f٥tSoE-1UC5Emѳbe[<bx!?FqhJS8'RZAUZď&$a [e $8b˼<.=C}zdgjT" MKflZ XbgU{fMu1.18Y2M 9D/(v! S:|SRp*Zn<%c[Jea6jLٞj}Ճm=b^X%*jR@}Q [!zDeݚ䘎_xLDp |,:?/#eXqGdV4 Tv#GʅJ$(z0z1'Θ%9:1+N45QtS?nf^0*5nBml 'Y2j6fhqHh0eÇ]EOQ#c*EI^@^Y0N.YCޤo Gho˾N9 BH=lH3Ԯ MF'vZը0#<OL @ I&v潢",J;۴̵1Dz,_^5kAIX"I7*7KfOӥDH$-rOkg'np#U- 95]hUS~eoOD9qrMQKBX ײNƣMP&ז=#|s 3ܔxw]<",lԨE#gձ:.ɳs(=*j3} +c;`Njb'~W̱/~^U1qdI`8ҀY B}WS*dפ [3"*; cQ̚w;[Q ,flfiR/C*xZ#LY)2BVByĺ_m҇&^x0^z5D$ "q/j`wXyyd w$BAN0WM}JV9+]{z9kAȞ5,+*UJCD(aR m"d|?%(M<|sT4>8/X &=Rrݹ_k9 / v3Z^V^$ 8r]kF$^?c a>yZ,oXy,nbTm (7ԱLdM6ggZPa^(!F4.ɯad5|ulRT-y~62VKS/mF`V!yJST{Ft-6lB7$6Ɛ0gϐߥ3 8r5&?o!SIfOk}b[vNLٮ#4Ċ^94[ S~'(C @[o-UnCUnSu y9>[uJZUB<i2k?O8wOgBШh0q7uuP@)7؇4-nqJG>[6YՈG1 fB5^ޥS+h;f~K0|5 v P qqnoN5D@W,'%x۹@״B`(J3[5ALC*sY:+pM2_;{Is66.>.Vawғs3{oWI.paoeѡOT"銔CjDQIm[&y}d@x1SjEԸ!^NhH(Y5^`d;6]6>y$Wza(/g4R_R+֞LW͹ 10H0'578}S衷&4[)NTJunqLAcf~Tt$ -59V,(lOnLLR'Vw9y֠ᓻg'E-pZԳ??{CDQ$.G]k쵄zeJ U= zP\ ݛDҡJ*?YP@ZR^ 5Xx %;fC*3>@A0;ؙ@^V]lKM~\֓=dזK{JYܷU}* @ +b_,߷Pwp {&bt %] ula_Hڷ=7$ DGi&>ٔXpTx y0)"I_)}RdBacjY02 ;-m'YITF M~ W1Zm_]H uAK-MC=%)b(}imX)5wKw 2(0\R]\8lZLuߌ~GP7'e9GgwKtn/؏ [2$L_zg(றS68a8:A^SUʼnDDijbX9BǴb7(}Xo7GE 7~|żdV+Yf6XFX̝̓m?%v)|L5icu씐8Aɴ ?Ex= +W8H^uB@^7C/'2`貖KڼMpzic j6PN$@V^`Aթ86`b#,D$@G]X-zuWF+y.)Z]7U^S= PͮUb3뀥^ِQiiD-)}$7͚v.OFĕ9#MEέxߙ?'LX hx"'߲&uR89Nt{ڔLIs0~{%8gA<+Բ~YRH.$C[^Om'M@̵Yqcؚ:c\ֿYEW 6N=ʳT AiOO9P}C;rijӬBb)*zjiol㿞3#NlyVd& |zW< })$X]/HkWA=? &%d;ӛRz}c:|NqG.Z_5p2 |}on"au5bv'H:x#r KXj_o(YvRʁ:3#@ܘ aw.K$rE\Wa6(D" 7XE[ ה/;kA9L ^s*m`DcT侦9b'@ cd'GR|Azx*&O ф_R _QKPV{aGU"Թs?γrv@^ 0 bjvTNm8B=ZyT+"ݱ,wfnk6S=>O[<3r⽳3Sl/g(Uߐ6lU'PB0t٩[{91Dk;)}&&x 3x=~D=C皸_GW%霡pYy_7uD^k]ˍLH 2 AI>}NG55cb4@{/Ԛ䖒 \EdIz$x<=O^RISy(Ɂ;г,5VjV/JWj{bG*$yͦ~b 4 {⇍/4PnFA!A֘;/Y_{Ndn95D'c~g;/َ9G]ӟ=iF?d~.CN Z#i#"Z|N8/n?^m{I dfMu}eŘ#^P\o2x2tyʊ>⥢Ubeq\B?w(-*4'x,͊jOA`5/A&$᭜H؇w!8nsF,:X~{YR8Eljw,&ۮHM24cΧܿ0gFsBlݨ%c$V9z1_+qV?ժ5Иb[<'e Uz:d೾CBZ4@fh[|meRQurYhRXaG5LWXJ=PvBy>15R"[<<@; ZCnT}B=9a|_Lwk}a{9 .`[ N{>|:M}S:Z1,;H0:z?"cGhB~N¥*{]4RXQ+ ʧ+2tȴ, \KRddМ"n+vg $HD]<â|0Ob iXU›v-6HcaiG;g?z+o; /)\:鉜<vDlCgА9uS`le-T#|F`UgM$*y%9!_o>|0tWb( 2kseq=7돸9+;kt*V}[UM ϣ<">KƁ˛M[u0)UHͩ:692<"Amޘ}N V͆ďhͧ|ưEk`Mi!5nAs~5p}f.d'<1Tem+@}*и cB~N lL#;-3m#~`yЛ-0p|A4餚잱O8U0x2kZ_+cKEw2BԷL:ׂCFfP9ڰdL`}~y:9 ҏFDOՠS6I+vI'ھBoHm.,[uYC`Y'1DM CO_v1 Λgg9hDT Pe13DQޗ1& ǚ܆)F>9%߷!z^+Sw"w٨e*d9!%əY9d3[v搝1~ṇOm0MirÍu赀(<]~+e@l|C0[\>v ?=FKr.m/U:]T'!q6PڌS۷K$`iNEY4l6֜E|F5Bq١5NK*1m9882 y>C>V¾JMɻ?;CN߉؊2(tqTnl.(r#_k98F=C&4>ª1a%w'MjNYU!-*MI_╂ǕK5c[)&q8xf{{`}#0ݩ&ĘE+%D^g, _8m.&]?X50\k\Ӻɥƿm9<,pB?lU1_`.:Aʝu' po]}]zF%P\eŊ힩;Q;V%~|]ݺ]7%:15VQgWI2/ZR9Jk/zFl~ Js\OfSN/$QNz"~f? ynwhXꎬP zndz;JuU`y ғ?ܘXuڤ}n8F썆ʄZwR a8k\j5ȤGz ?O^>cX% 69v鴾)탳d^aaMj`og5-g#ҥ+gkgRfFKaaS]U'.)Ra:#my8V`*)*h?;ۜ9uҿ !il\(ͥchM~ wJԨ^zŲg||"3 !rƢHyW#W1vF=hFjk'GJ`Tc1`)2G%_ Nvץ _Q608np>4/"G<j,YMq?1+#|3v L3}kI/c^<2/XH_QHb|-NXRY7B5ȚrqTO^hřB|ĬEߴe֣rBblFIed*BA2)eS; Hϐ_Hwܧt;B:$*e!^rƼ;מ[BF+a hUjE2j$iqNlpuƺo!Yq*mExST.E9!rWKZASV_kWBҢyyG@\L/|s7z87#m)n` ~Q`<oh, a(=Vg$14JKJ ?O#|loqVብa8,t[K,kV9QHz1sQc`CΖ4]?aK*znxw_J~T5~7Og!oD|/R՚4l`ޮyE[r|9Z?zN+,Q#ylp|׆Xf-t!dT[9¡j )L_(NUfm>O@ )xd1cedM g v[1 Vpbð:VZ밯XGiqeji;,1Z{g\; <ȧo9ȇU]Cx|gT4Dp~#ir ?xm #dJ$:}ΞDL1}  IUXF*Pnu>+NvIVv 0D %"^[zn:& n FaSNPP/3gMt[d dnN$Q,zPX]d%uuonSVV<5wІ3J3~׈=lﭺPUe"[qz HB|!0%"\[}wPf)m 1],D(J7%Okb L?z\<*o߿wwTf{x :~Ao|^ʣ3_ͤQxz>/"kl#ǧ(,_|me;.;jޒ"\ )e*tۃeCHNHV*-Bje e8JE5 CB#3BCMkb64BV.jH4Oǹ+(w\hv >K,Xun zm!0 qa #}CZeaJvKG EXjP?">]1n_p΢T08  w>%S+ʒɋ'= L:cI€MEnGy^l>g(O!*wL8ak^X6FVm"inT]s+;ԥOPo>d$vNF5ՆGo'c7Iq0Y@i6ܜ"j wЪ()x#LlG3<N %{,Oor#9VZK.h+E` l+Nϓ56pGأ؃pO0 \b2Fum\Iì)S˽V|nϔ:3Uu .I ÓCI;\_dJa̔lL;Y)K̪#<\e(1m AmmwNָ[m oVGWF@FKJk#u=N-͜l9$ $۪؀U#^d9FNM͊-+'dݎM+S[oUuw\ȱpjJY7q )`"o@22 GRYU i[-Q3KZsf,ס5b@i3/yMi(hFrc74]wQgMAYòG`늺isbiy ~niyco&:p,*cjz\Lzx'FH@m6 P瓱IaUs('H>'U(A %%\e01swԛKHU|"o@14b6pE; ){}㔋0#3=lک ]\3mB\r' l#pݏzH|М G?⨐GoRBnl#&WJp`+0(C KcY,LvZZR_La"+qm`Op->wH )֧FCuTfB$ij3x4I NTS&f2{-7YZdq7,5B7.MR dx)FՎ%>̜Svt ɳBy$H "d/0v&sGxlwvM҇ [p6'6 E-(41iBQ_얦iIۃ1CJVz?l/TU{Äa\7J!uYwm6OnFŽO-1?j!YCIzrF}F li7MUǿ,x?o]99u9W/n:DBG%H"|DZ4RX4ՠxv#$b"M}[=7#u~ZS;o*e q R z dn(<5ΆTS30c:ÝsZIՋK2W/d::pv]6BA Hrg`nCmr!t#Z?Y6Mf4|M@[qoFt4Jwǎw$qtX`u" d%X[\=l;Gj߅ԜԚ) <%ȣZzW`Kbyt} ɸ:sR~>mn ׏ X7Fn1L2ȵ6cMaX*t{GyTx?Cr- N+xuGJo;Ӣƻ9AH`c/n@b6\噚PsE5*xDzygٍ~#FU(^we9G ZRz+Ŧ5u.cg0ߵ?xↇ{S6 Dz:ey7WZ(S3dXRu7jXNpgeacJ|'i 6̪5PUaz4: GV.<j=>muޘ{ȝJ&hXIiTH"U;CN$LSd?ff@=R`,Qݱ!Yhk!ZjJ◃I+N𪾚f-#<4LKDQHXYOÜ5ˏRW]koϟ6<gNNRةouHmihRWگ9w9=+,}ђE}U</>!Cy:mD8 Oϭi19o mRfHM l4B \!jU+N`%4L?Lum =76]akV 9c}ߗ}9$Sg4rfbBrxYTDyy8 7wOwBdskv N99elt3D8;{ "ipVlNUm5"(VAP% vzJcOUM/N ؁QE9zo~3 7s cm݀Q H".Z֎|KQ)ƴ N?ttF|!ZRʍv>2f{j$H6y͖M9 bڤ.QiiE)#z_iZKQ*ze",=Je&l9dz!Q< Ps!tGTh.,4pmL6lו)>!i܇bpr%׼j:3lE<==(%%){?okGjN .s/8 3_QIwM[2񟽿*$޻i&'͏m={#oUU ?QtK:fxx9Z24sۥUҞ z1Y(!MfG0ښ Fd|ƴ5 a kxP2s ZL05ld*&;W_1-rަ̈9bYeUw@]%i,kK=-Q80Nn t"aN/c/\ wo%k0`r=`Fpe>&)?¥E9(RozL/IGc[a&PMG6 <Udaf"zY7ϛXǷ. Z-Tc}B65;۟twb&/EvhK=/FQ/L@| {4iTJ0C>? ״ x:ˆ+ RqOC~ L"ɟ^*1z Y HDp(!?ZSH1-K!Q% t>ޚc @ƒL@GnTb lAJ$c31G|B^!"Emǻ7VSӞąPlxXd'%<%9 d#O{eT7qMba<ӳ58U 0 h:63j9X^Zƍ3T~B>7r{Ye+VNM8̛CݫF`ǿvgMRa jJSٷ)npmgI⿬䡡dl>=,~ mkhLn̪)(R2Zըłs`\T 錳1V.mXڲ{Z{UOP~~Ư5wK?+:YMхS{l+KS4LrɮcR xH;ze{FtwUj5+|CC o[~jOH 55YͰ1KP1vb$WX<*ϏZn j4'7c`NK[c `߱y]}zyKsdktN Oͫy CE#@XBMbcͮ9OJdhbkc&-o !ѱ,ۖ^ʣ)D0d|Jz h0kc¤r6AM9O0}3d? mA=7:WwQ´b]W8] W#Mǯfd},0Ci*P3gM 7Ryv˜KT8܀P%h91958h=&uU*vN'k3PBӰU? endstream endobj 586 0 obj << /Length1 1619 /Length2 8196 /Length3 0 /Length 9255 /Filter /FlateDecode >> stream xڍ46{0zgނbc6ZtBtE޻ jw(!H"Jt$sνYkf엃X@% , @QA P ˍaAxBa2 /OZޮaQ tGTA>P @Pq!N^c KKKN(AP0y9CP'Acw0_%圽2BB 7OAw? 0xB>/=Ofg~cwG/_@9\` s ƚ:}8'XO?.WBPd0'##` WOwT>u٣o[( `qrCQG@k J{lPrp=_!KeCsmU?{  @@W OAM;@O _kcx};J?Q_'_Uo =vuAnPW(%{{BCd]^ v(Ü\n#! q0z* A =0?1Ծ]P'jVC:j0ï>%/qq@0jA  ܽP) ;D%B\-I1ߖ4@F5o4 mPg O>JB!LT?0 u8 zXFD@GK_P7 tWeqT{c~ $8xRy^+A~cOvnǀ//w5UR9d4p.Z07Ƽ'6dT?Goh=K*:6zw/ԔWDndTD[tTRf1`}?jo")+M`=MI/;e$h1ˊ&F1 Y^3CE񺋕"N˂&;'Y\; 9x̆ZݾW2sv?WRh%yfDqZ *<`' c8W>r3[J^Qq 4UL'>/Gv$]+kCЙ%J٤e]׹&<:J۟]s5!l~cG"!n `˭Vu") U.R٨7(?\P ~lGaw4gCz{A,E\`MG;.oO鉫Uً!񃢨HѢ'L_3oćuhlf)a)Պ>z7k($8 ȿI~bO l$@; ڞUw&3:jKSubDhb;@W 4X7} .'^LAȾZ> S{vя }q-̬NRri$?^\.M7j=oa/tv@FȂ>k.#ϲx pBw hT(\Sk/͎mĂ!5!54K[p%K6\#.!Ahx#&y̶:[XZYuϯ( 6"?AHLUiXޫp +bB|. #u1H}T:|NA(߀2F -V#xe)^GE ^%Gxaذ5 :qWً;PL'ՙ8_ҭtKw0C+-R keP)6@dEj.pXlmea _Ü-sArՠ %O%  gnfJ=HGú{ծ0T  씚eya zb/on,fë)q0sQPr@ɟ:Æo9+VeĿF4:0>9\~*iekHXAm89V=z۾VF8 j @"R,Y[JGTqGS>R2BqyK8h#MCXtDr|ogd“?5tHwoiez=، u[cpL=meљtd>\SlN#/^޲K1yyĩ &%;$TYNʔZdǪY:!ӳ?aKa<:՗l+"ᰘ>q wMՎrc־YSzX#4,a=3"NBkin}O|r}AsARG\Eg 'Va1wȥ9qs?:"$I6C ;Z:1ۇBֱ]iSB!4 %h5O b9RdA7W,|t҈}x(wK8;}4ZDirI+ٹBD0Ѵ "f讦>%7|d ehr-TZFg#+>nh8N/:(m* T"W ͸ܜRRpbB%SK4㺀BgxWtk߲ ,ƟERN%BDeN՟$Ey2ktQKy鲑5]۠K(ޭܾYu-^o3oぁ*A^\RF>eOǚՋpAQ(cb%h9.wy:+sە g}rTuYQ%q:͍J]˶Eӏl{Rz 5!M&'T#}BCQFpc_  j1p&pFcLFolM3MG޵wTKr9Fc>ռۺ$ .ӄ̊^B´8F3li59pG08 <ėz+00%kR; :f$DŽ@7=' .|Y\-Wv3$a7*?hyͧHe-jj0zԎ~Ţ9 ~% o|m̖xO^өS7G2Ց!(""iR-Y fiDTR!2PAA3M⒵[$\YQtoݲrO  4fTq,3,c sܬC i.`ϖbƳ~1;'4k=Չ=zEC 'sM7k`7rwIJeAN)yփ6iӋb; *<O<5כ$6^mۛ. Gn415+={ȼ|pnĺxqkv<_)~ x'JdbyqeabqQKE ;@ D17N]1ѽ sz#%ܺ{L}ɁojKk\_H\0a•2Q›(O^DRE ?_-[ ڔw`/QMof|dDZAj)y$nkY6)ƀJ>}}2Ͽ?{ά\<0wQnϝ-ɏsUf_{9+4gE&r?}aP:^IN"FfnVgXo8{cO8ѣIg8. YչY?|*9m8~Kr?~\~:kVC+Rkx'̔%xaO${&cS=q8* 2aHh:_3]OxNpo݄ڎu7蒜"y?ܶ~uRޑ,f/j*2\fT4 I_Kr\uq=; yQ Fe#эKe>p}O>h%NS ~ Se`|ٙ*8gT |Q|b~JeTs&~dn|qW(`wM2EX2KI@S#3];ٓCnA;D^=vGva2(w= vEQv179 ygV<+]CVq2ѣ?~f g (qt&?ꟴɵ7_+d)X_}8&v&:T ḻ*cFCR,-]OM RLn* --^ ձVkdO-1 ŘwT䨬 _iܷ/UCSʲ(qvwᗝֿc^#:q7n峢y"l.]'pڢlD?qe:.(yW$~!rkJ{ۖTL H8i:Yt]V.!4|^uf;s2CXVNso'{Fq[CS~#ӗI:A,Ù䡭#uLzXL鶮xJ}ҷbbj>X\BkDVYlcVp v 8>f2n# 8W'+=߇W8? l6꽦|QRB$ԭXyD/zE6kt~\w4ZskeW콐^M3C?Ⱥ+.IjҺ׶b/|{.cz،M"z{2qu6gcͪx |Xbޟ{4&g18ԞQ^~4 >zTuUQI*g3 Ce܌FڦmNWƉMBt_^z*>e>ȳ >P _fMfz1.gMɤ6u\l : j`Rӷ0YEl.$W\}h4P/,K5Agb! ܩMYkBAkCETW>iFؐ Pvj7ùm$2 aRzQ@Ig3בrs"K#˳O(ބ1LZ#wlMsBA9"1Ҭfr9W}g4'il~jdp-&! jqY}M.AQz[dR}dWW?_X~l&Mщ1ևCn!|r`w35UR': ^D=ɚO- lRK]g Vz떼xlO Ew|sVn8OBA=њ@\Fz up\i>?[*| Z>wE^^ [JDꉿX8Uh>·Q<1W3 `0ɇS2^>.6%AMYAd_j 'X/pia qCb ;5,fU>\f,M'=;Ott/s`IeDVErga)lLe1k̈́ų`#7"*i<<٧Ӗ̲H`ިQ:$A䇬@(RsO0_1/,fK&Z73^hVvL斫cW>oy!Y_LWGC? d 1퀟9*ZO 2eZOfe? G7&'3<[kQCĽf\iqiG@xz Ↄ/#']N{0(7+t{d]f@"[I3)<ɑ/%T ye4Q1#DFj6j]$ EH̡ ִӯcv dm-+ jea`2Z1HWNHDæ@|~Ӯ̨x`2qB{LCu}mzګzN٘/ ^钧-sn̴>~nB0F1~-Y븾&ۿbú+DIGRK|VҤqO Up*r\0e,Rif_rڒSCF^3ϯ®¢31l*R -C;boéL AQLˍfdPڥcJj9GoIGF/~ƈdms<ZmcT.T%4O,/}hޅ]jzc5ߴmT:vLo> stream xڍTT.t ) 0twt L)ݥ(- %H ݍ\[u֚s75RK<) Qprpprrc12@\?Xz`g.g0& rSCnP_K@)W Y rX88Q so'ي%$$; ;C@p hVJ0ڹ:  V qh]`k/u 3,F6 +0> n v7h+;so\\3W!w2 s p[  ,~ IU~2 wu>Y3~۽@6HX9u'7!&l`W''{Zrvr23qD8lI}!6  puv_X,8?`?;C<Ɯpz25'55 To4`x7j Jp@ { ?UİAq/e0pqZp?wU)$v3 g\B q? 1j`kJ鐂BF<lqCB}y(@@~5v.Nϛ}rV]qoK9q@ /,{yq|[ z A8c:Q~P7A#{ _P8@ // ޷u/x_7W+7g;7/=VXs3+֋*) IMTv96+$̠e3x ŗ4>0›4[_ܘio`}#-ܖzHɮ#ŭ @:sq4 /ߓIf}F5q q*gDb}Ve6 c?҅!s kzy-*SU?PKIHagtbmWy(bgOSK_yj.j?͗t X/mo1)0E#Mw1kE9Qk A,H"fF^GmzTM"*츗B[a NjʹP"cS[OąEV%Qr7Ӻ)o3V5ez*%dǃٲ3h!L1THa dE2Mb{"H_־;)C_tާF-i%>[FChcD]6<&j{8r4wAF#mE.I :OM&8녴fvEM+HؒTQoӽJ{bjn+g!\;/2+7vKl='ORu"U>hj&>=6P}яq@LRWmD3qaBm+=^7nD\>S>OҟQ?0FSTEW- \of^ɋ׻K-}*Ca:ieص! cC :)DY&CEw\FN>Z۽ ϣC Zq:T̗O;N^F-MGtMhxڳF  uȞiH݈y\pEWd![Gu]Lb\RJ*o5Q,[NQ Z}? >m?@7)j,ƙv*S+BFxhX1*rnz.=OQt s 7REVyis”'s=Џ}b+}7R[0(_a b{!4WW1E87e2s.JX- mb:u_Xzx7% ?Ë٧-s{HZWAZ{Gg͢X9O">(ׅpo/ R~)k&diM3,,OlX t/Y{ /Nh RҤpX) 3 6zId͵ϛU*LS`6HH=)e ˈ0t0kN!k[);l:I$.Ԃ*9n ;'x.@ Dua -&sheh̷ឈ|2od%Bˉԯ7Ň}l~6=ӾƝ$6`6+cSgiK)S-Yr^_DbbcCḳ̌Dy(6{;e_ourTFJn%?>2Gi0v|i#2m?leU ~݌in=HuЭ4j A'$5s7ﾬtlilt_(OȈCWY_m&8 L~M{cplǒxݠK>wX$:EM ؼ(W!K|DQlˍʇg()},,hْsQxU!I{=>)Y&H, OB}Wр~)U'3$?8o@UvZgu7yhhʊD)D uy+Zk?RnhBxքS4RRΑmJ{+jN4=1!SS>U굟`L?m{Lh.enp>K_m ! Րq`]m` /h wK{O9~lȢ}ȃƢ[Rx4`}j9t>321?A<5|)JR}z-KldUQsȏH86^{tjp[S0[{TJhZ6u=~AyY<.#Q~EQ UthZ:n6QVEwQE_vk4q$NW.*C 4߳A9o"5IgoS\hukB}Ȗ(7@[LVσ{()kpBO҃c6(Uۢp,8l<<˴ca#Llxvq:S *> ^C#a`)՟{Qo4C |*2QrL p#Y;`>7o7E.4pԷ}fK-CJ񴮮i?QdVy1hT1v>`tBK|<daR#:ttxC!ʼnKވsMטdZg_uY+n&Zj~k?z1H|0"o~nim ;C DSP/bp{7~͖b)|zJFS#EE77~E[">]CIpVB% -pos(2=˝݉}(kεo1`$9+x5\Qrw9WJ._wʫTQlC32ċYPW¤^I:@SE&*GyxWñM|_?7ި;~ *bYn  Fij^'}'dy~OV*ӎD!7=e-4=lK4]3+J>Eۓ9d-h |D޺GG?L*yB&#e2*Gp6%hqh A Gb{k4ϺoқrE g"5bw1 cYv-ZDL9W`7=%vy< b D} mԂzϾ9SpA4AUS6Za掲%H;3GmK EmOTHD쬉oTAy$lhݤQ, [9ƚJR:`-{J6,BOP`I8ڐKn?˫Q;ɥ33#@ >SDnJpLXPHvOzT+6LkJ)]f3a^fN'TO٠Y(J9/W:iYC '٪Dl "pj+pA,,MJ!I;Vpdn3B Ys1c+;k75ڏ}M[W ,NhT%)9FBv0A[VE:P8KgS<㈳RovoQ H`U~zkIbl6ś N.8([tw>5{paƳԱfX7aZE6.ʣ2=g4oLp˻r;U<3F%'~H|vX PHw!q'/cuHw_uy1FN\¿V&ѢV[~c9SUȴ%/9 {%٢Zf ՝Lg*™QC$3'+=*i`kTj=њ0w֢I+|plҎW5yOIS̽ڸ(.wQMtHX'š䷘e-k6V[E "s3Gb:fݦ|lAs^bϲX#w,Uj!^a¼\xU,řB]VӐqڎ@C'GwE,Y&n¿^x9_1娔N:km:X3v E.vq@ͤFx\9iO'jIlC$dtHχ0 _Bh3a`ι=((w8vb>Le}a+U| YS9%AŲ}hΥ+|A-|$WR+FOpXR2"3z 0NNőhLf0~GU1e0KDpqn`&2֓ ;Z@.Fg5l1QVmVtEԧ,kr)ԃ6SLVe4;W:~3b7^uf ֤C> O/1D27s}roSI[WԻ)q;o|{YQSj==V|̈wf\V+/ײ싉NDJ ) .eG! h:N~( )Wwb-כ F yPWi-^3&QpSMi*w\PIa\MSQ->YVRJg4IUbj>,VDwHDoRGLF}B9NnfBJ6C RӦD\Tz&4 Kec^xX(9VkUͨKLo$ΞF`.M%|vI.8KǴ\;.E(΍gT!)n~g*kU&v,4^'Ȗ+󖾴_Muwla9&1˽H.5x?/ q_鄭vdlH,hO4 I\M!#Oq{eD%fd@3NŌk>5t3*4brǒvAã?gc!Fv!/{xWX.#OݕH?K@}/a;@[}U{ɢ=YI =\bp5+2L2qpPɞ6? pii&8vAx-s)q/ PC5E:X|Dtd*>IG vv5d`ؘ8 aCu1.0'`}\ T@9H-M+G[D Nh{K@>d-V :PPrd gÀ$ *a7 ڛN I2+g?Jdwϛ\h2PW ,>\c_JZjL ek:rXvXx[G˦΢'5p?t `?jemMM) qӷa49LzVOH EЎ]@LMOС"a #kЃb 4_/RunUlYԄ捗 1#= nզϼ0@<**dM..<Ӂ}zvT;Yo,np7ҵ1Kh"ٶֲG#?)J[wd6ͨ$:EkzHmG283@ 5HJi'JC''[:zʟ,$g\ֺ3p! q!0=pp̍1C,E{mR m##'pCuec|y$5VPY f4SvJs v=g<´DL5uǼ$(šHҼ1pJBcΝn (Dx*w"[s\OGxҸqOsUri9޵hBAB<jrx-vRs>J.} e {kc v+ VtSN-௒iptחMR>`-ӽ> stream xڍx4ֶ Zhчu{NDc0D{ !: G'JM=5k={_{p (!mHZ$(i PD&0пD&Pw ;ؔh P<@"H\ Re'-xD@QDJHWw#S[7Pp `@v`*Bp!}#*%$%vA "dy^0#{B(t.?8F0_C= ` p@aB<vPw:PC E Ht%!~!+C8ap(@WUKv`8 {ap-{`>a sEQ0/B`ڬSB@hѯ)ܡL}3{eCa*dy@5`0&h(PRLLG_|\~HW=4f|P@  B`gǘ1X1>(TL PSQ H H .. guoz`؟GF =  L&GƆ :HP\@!,{Gpo?_v} 0z@cfCCM 6^ 43# @P0o qKK!Q_L_>A1~g]ikE`wwF(U;oH4&G:X(@#1vxc0^u( !ABÜ^(0x l୬vF'E9g9jgM)ؽ37W11|Qwnrz>Ko]P`qI0&NqDfckb:s.#rPr(9%gMg@)ub?1ge_E?"naakhimn_Qfo؋J:*ytIPXJilt.86? ےD<to>~QY>b1.Dr99ڑ&]t(ZߋK \֞Bka/4?snLK ||(gv7]auZ/yҌ%qmPO! dpYG& &*bZYd5OB^TA~^[Cyɹq#Y#mLBsp)rRJ/L/= iI>^?@^~KMD[C!a+·6:\a'gZS=~o#IAB]CxtjdwL3_vpm{7\RI +D[-Z'=O,ΤmZ}j9pQᦨ M5.)B;S8$PmxC BѾh.@Sk9BqQ/ 8DU⇧ȇBfbo}]_n[1(hE[)=h(4O~Whru%n-rEK9R=͏D=IG5A߆$9?0aa2VI=*jI> gQyEmzɬgX_$DPRMi? Rpc.G}yahPeYAVY;8Ϫq+ԫwPFOJgu9!}r\?o"epc o*ItBYϋ5:$JCT&ȺEּdTZa륕*7eN4PJ+Wv$#%pMgkV8׳®Ϧ,Tu憜zHd 32Ө-Aч1n/N(h1ܬš[ rWËIlƥr'ur)3a➤2z TY|NաHZf}kG$2E' (>5ANF\tl_㇓~YYki;3P\J>k5/^[B%Rjn\t[74.91$}/!U,n9c%'pñX`;h4b5y|dI!OKhBpu %Ydm cV}[ 0d+NvaeM z%(CXX2Z'xP;>qVNi)7"5?(?1FzuE .O} ):p@}|j]) ج2Yg[|'?ES2Œu<{K >L4X껞v'2wK=Lտ9,LCOӠ*M<8HqKYV-)ɱqCX?զ }bjjx3rwSWUf@K#[a,!>.ع./jJ> 7!汫brԋ߷j~89n71Ii+ϹADi.F@x$wvmX6XDf'TkFKjYǴOu韝{W Ǭ8ȁ W{.amXd.ȩ{7[_k@ Oڏ:wA@B礱*w3"!,*d:G>GbMty/#xxH"OKa)5dEI"8tgX$s*8xĒjO&~1~i_<>>*[G,4qr%-B}S;f~seBЗB%*[tS.T3oԝZ̊ {D>7qFY-b U>$յZ[r灻(Bqb^2aL[@{Ȳ=Hud2'8Iɏ I3[ɻlكh;!حiTެEGaeW%RO?4 ~Z6J]$l~8fM/8r_:6GT_*[k)s|f /B S(`xηiꆌ9F@Be -tAjk ؑT/tc˃Hd|MZzdH>.Ef쇒*4N2DO,yݬ&9+V0Uwb֧=۫nXV^/Oka,Jzg=a1a_zMgEIKݞ6jўtz_3 zTFaSu$+RS"sE=+  A\.{YƟ%]Y;Kmp̔%+ydYq,b&Wn^y?HF;;sIQ._XtҎg"u;"rt a#n9hBix:ì{̚Q}zʷ(csR\S6~M}̀o׏<#rSI9HH ^͔m{*BUEK8'f-zB m)t\"(IXŢclsqayY5W/L%4d=K_,Jh!Q"䑲Yw迦O%Tku6b%,b]Z EJ6O]lGI;<'ҕskr;co$׎^t;(<"h["WH] iEt:Z=K&Ij}7śuР<ɚ{81%]Wv*wO{*j,rk,ו/NYL.i ~D"d>{mJ=s6O(oi<AG6V^8UDo|I!Ҋqǎ7M]3w^r#_= _w_Ub}#rȾc魖bw±\' LN }plHlプ:0B*\WtEo#̫zf9$^[ڕM=dV0Y ?4C!RL2 1Zt+%!.T ߳b, F<˃(v Z1SJ%^O!{ZN?㡏5+#;|ݺsj\b^GbfȻ5u#s,KL{,vƂTf"S"XflIL{iԼ|1 _{s"g,y ZtͰ3Pس Kc*u!{T#wbzAB/𾏢x9;|y4GX=#[lg\_YeE~h{۟[ML3%פR;s!LnPSO.K~xZU[^l:DxBFIC%2`Hjx^xYv56KߴYշ{?Z!NJs˕ssc {;2Sd՟=WE iƤ ]Z%u)r:Uzj턜7:83-nN|UNѓg\hԗ`;Hr0q/h,ӇZ=w^G9XpG+fvPh5b-hk ~jɗa˂ifAgќyK"'krTUGO(νʨPꥪ޷GKI:$g̬WxҒe` Y%WDS8pHG1R&v#SYSSĘG&5 _+,/w1r^+/_=}b+Ք6_:Q8U9dS'8vd`'=b7eTo F?liG:Vt?V^.}|>V6L+Vi> stream xڍT.LtwC7CKww H#0) RR"]- "tዽubxit9mV (-USpsqqsb02Ꭰ1_\a`(D KLT<|A"^nn)B]Er`:@ 0e^`;{S}XYB`eظ9!`7:O"@p77yZ CT3`Tl ztn ?0xx6`k8 d`d~+`~<?ea6P1PZI﵊:%z|8^~˧?Z࿳Ge- WOW!og Ч}X&O?nCt!U5u p˧=9'?7_r0L íڥ )#҂;OV={ٟ;<j ,]]-06 |xn\(T`_Bmy@ /h  d@@NO >?>=";=.nЧ9h=(}j'=O y nOӟW4?Cd1? ySrU)M=ˏwqf%O$+v}ʗ9'1#z`l7-Rdjw@fCƎQǙ$+)t殢SrCT_\XH#ёdBB|XH!ҙ_d'ڔ`'R#_(^ l-r (U2$>PL2nuɓƱe Jҋf)o(lE+5*!"ˮKg{Z1oO+`.*+S$W@CWR͕V50`KΚL+ =F vsȴ Ff|9h^_ҍHq|KOWp`HQK:t la6}#H#Tw@gxNz #zf0?VYb9["ޤpԿ4K3%MgY+c.MTMCjĐȼ~3R R߽Я,u6x'9'fPpU2BE! \Cp\Nj^;^ra'/Ig>R ?j7 *aubT[.+oe؊ԓX %NѩS,d,L4j~i,fC&QxGD@adwН aA_גa?zRf:nOɒ=/ӟaLٗt '{G$bj֪9?%V_)kIg-a_}h^|{}K4x|aXSM%Ud:vi_$˃9E2b9*uaS}K2F463l\4|>i}8 ` RGӞALnW!,Dn$L+6-2kS=>^s$ݒ(pu5KadJߵ_3)Jl2 ҍ4=żz=}N2=ehD.뙚,"]W{E?uk?i%&@qg0=b_X/uV&vMثu/%FGlEQ #H"vv;potMrl -^^&baMy</,mi3'pL|zAAI@9q3`:V~rk"p$ UoU>ojἣI>ˆ)sBݗ[ }o7R'm^`[x4*%qǺemV6,BFvDKwEL*q\[iUӮY?k-KBG?0H a}٩?:=6An6U#Vm^CmėNVOGfok/|LΧEU?xCd/fP5A"5^A4&FdBjvuh?`apK|'qwr,X[N၈޹waX8 @DEق4:߭ߔ &8gԹ ks`RTޖԙ|# 5ZnVӮ~> |5mSmAfg ڀ)X0hJ9KОaR_ߡ؀wFi;C]\3koaCI*ϹUKΆ8_❿s-/bN6nV7h;mCӔ:t/qs6o{=xd|to!SUUw@2kI{D, 9s=;/ҐhhSxؚ oބ)5&3(/{gx@.B֮cSОk Iu nJ馃F24X\+3ŏ,fH />n\n%qZC5[bk%旕P^^Ooagtm}<=s_̂Tl׫a;$%i `E&VrbcJ#SA''dSLtpS6}ܦ8+j뀣&'7<~.eZ$˖B /ןw'F?M+tϘwZ68,t/`d>9κ{z.}{}#T4U'{RA3ܗ; [<0Z/䐷 (FtxRy%^& 0瑴46exhWm09t f,ZxYѭ1U0& Wք9,u\yW7]* d߳`e5`u̸?F }qdjnW.lhV}#Jg17EYэ#aoҾ':iaQmjğ^ę#Pw&{$br0*3|z,cFjC2d79sY q[5_>o5(^dECi{@[|ՖvXsw/~s7-|[DB|od2|(\]ԋ ~'QpY2E}PYehdt4}`-tnud1m@r߃1F4h d<܏q`EF%@e[hbC[˜yy*{S'[hț85h@A!xPHV-![& ɲzvvl Sst5WXhgAsÉSvU5h#5/Pgd&.KߵǠ؈I~]r*DT=geDtR{hU 2;uV,ʽX0 \@.QWT! FlM ޭ#ı ˏM5~![{dZ3Me dZؑZ Y;rt,Zh]QهOb^ 6wz sY8/"䚎'̴])u f4ZtJvdׁ S_v-V WLۡ{.2barIӒwgoܠ[o娾ky'!7%nJ}yJj}6( (4.597CB|dU͊#Y7I0;%WT +w޺ ཥw^({r%?<?wrx_pY E?C2 +B.멑QEjhK`|KX]9TsvGo!Carejd~o&㥤\c~7>?* ,{{~L"%{%k9FVМ&ZС31`+Qu_ÖpA,0iFP f1+M[+#FYtSCd, &2ZJfhmHy $s^1%Ez+q In?i_C c ;m[Q]aL dPxpqq)s \?C6,b'Į,adNT*O,x-Js $#ttmyϹ_Pv5e+G`|72XePG1FBNe&JxbݾU瘭>Z\en|Wved-GAPKfiqEO^*Y:y [e5+d<֐HCtǾ8$B~@\SQ0ek4.PyFMJXIU+N|Z9T)>,y؉vMC vhz|OFrnH.Jkk+t}S. >Y[IkQ/KlǏL_}={TLR`R,T'e9*[:92 ͤ1m;BȟEs(n>KKC{ vy ^bV`K {^cacKMV\GX=nayc`fK.%)+<:sQޔ/T?iiƫ:cʶV!>#XaA _!S iWtlAR*V,j%P B#d1eC?M-u-MR @)V&z۳@طȋzx-[ҢA%.),srVhTCK<)0n7ujps 4rKp \{uk09u|҂x*c{YQ:OE?:)5ΣrJ|eEY"Kf61_GirOͺgACXhe L K? O&CxM $-Zݞ2IRTfh3Ŗ R ܜfPjNDcYFmUЀlG^na*g{,E9vR(@tjmFJyQGFj㳾7|?:tHJ=X0ahӳ%F]x#껏`ɚ~ B;曛8z""E1@65mLV17NOΉTeXd$a;?+իxAc2/1eEKŮbМú] <9: G?C#&G/}B]SlvY=W8!&5,JN";Gu 6]q Z6{R>+sDW0=B[3nSjXR8yBd3#M):kP;v*Xף ʱݻⳢ`2*+nsZTIuZ_2-VFow\ڧbI Fnw\i)Xt[{K۷ʃ_KM(Uz6PyIJ}Ek׋*;F7>XaFnA<*OZ(;/h& _0/} 7D^*r=Hd*z a s[KaBe޴ֹZJe\Gأhd!wEǘô{ID"7.:O_厩DB1Br/Xuj_LU4NjM iAi9 +H.5xd.?#2Ht-(tr_l=En:=-Dl58U%/F6w|˫mslƍв1E_b 3{Z2`] 6EøC6$Hi-n]"F{rw6@G-)q*H>YHl?,IB1\.q㗆ڴͫyPMw@IC9?\wFgIv%cIsc>f1t,m,f+Z p H p0c5X%H4>duYY+)R3* Ub¢ ,G"A' ~T&R"pȃNZ _I >V}!†( YaỼǃ\%baWW31&Z=; y@B+ur1Q|,z Ld;yIH˕Vz7Y󃑓UpDcVvx!M[M4%>lHqFu" 6,[(ʆK^ZߊUu)w@HdEvTcg2Q6J%gˤiDT-_ eilFp\V~B2|)Ya, [t tʌp]+Yo+Rkou\NM34roa8ԁB%'m[ޱo̊u+R?ؾso<+D%)@Ȱ+ZDs cK"_ԏ#_ӄ/ɖ@HM _]jseP]zѼs8`\2j=l<7?8sp|_X]^h}p2pi|1kԈ %1PbtG<6(W"e Xg KB0?y1\Q_ 6@Bi|~2혅#>L.F^1PFaZSl6 hF✦)]oUG`:Q>-zCװ>8J͒Oi&'׈__dZ|ů'*χwFY^xn`$Nw /EP/+F@i")/<]zn Ƒ2Ó{ Eip)B۠+keQWnkC4h/p0 w]/p+}sCպϕ;|j 7fUBqCӾږf9~@ KqD'|#l0ژLn(~6#`qCS}9m;x ck_i ;e[R 18ߥng7+ Xm1ZdB(x25Ⱥ@L"n\3n+ C kLP&Gj P~CV $mXƗJM.R})`$;۱=v2B`6H(ss"uPRвs< Ͻ7a=giiחƭov#)nFȝ]2.>($~5«jc9˰cl`cÎXӜ0IUDmS~A2m /\5;Iɺ ϋtd*"C_l+oYFKykպٴ!2u(7̢ CR7 ϩsTqDJaCz-{W~OmSTѐEow$wG;@:(bbK7X̞KB@Rg h*Ħ_Qުi8$LJ 2|xA6{a3ŽOky/+~|<DU Jb H⒍Lnay./򫶍5He;d4ET<;P M#\O`CaѺWeq/LNzMw|^>p?LMm˷n]Ct&|e,JY;k5Z鐹K78! A^L ]{+ul}#/49fWߍP]6|gAV*=`I%Ah#燛W\N\Aw*bϙL5%G)Jӳ^9TR^9瓱:7,]G<ܨ_~]gMijH ɚQO0~";` TrKމ\ E<3J\&)LFbVo6烑OɦS]OsI&1}thL2Ԟ=ƴ̧cq%+ k-GE7\^LDeǽtTBoB|h!XzK!!7X)Wk,K5+bqԤF b-jlh5MQfihL *+.glqx8 G9ØCrpHBA[V\jUR(࿈DnGyJM*jEܵ߾- oɌQ᛿Tˀo &<0t|䧆kl.6B2(.lccPP4FEcWC'~"&Qvt&IBd<΁/64U@O;= )',"N=7]{}ѳ`HD츯vMt`ɫv=uL'OR P()L}|O*Cҝgzv!Z"yۃW$RofyG]oeUlEK4c&:nKɽUh X%p[ޛ}omءPl9jbiTfZ8s=;^ľAa#LPYCɾezkv5 [d򺦡npj!Hm?[$zkjqֹ'JSJ熝1TUmQ8(Za^{«$;VE)MZۮ*_*aMQhvDï@akTB&"qԖmB4ƢzwVA(K&>5,i@q:ęOd=7=X~؍(Aoutv|?۹:]6I1y]&&xbtrf8v)^g4< -ݗ+XB:4.{jٲs^Ԯcş2n.65n0\xx!ZW,3mv%]ڳF,Xr^NT7f9>5SzsUl]go|mA$Xo0rdI6W`ıъ!ro(O+{xcls>R,ً#{aCΓq"|IJ^ޥV(SYG<2yH\舋qINe+=}$_ Nf 'TLp(*%$O] endstream endobj 594 0 obj << /Length1 2779 /Length2 19357 /Length3 0 /Length 20930 /Filter /FlateDecode >> stream xڌt/lKWWGFFc;g j:%@tv~ P09@o3"Z]@*nf@g;@UZ[Xo:?030k_R665us4[r tc{_ƶ. }cwc+[c_$Ơ ՅẀ,no&`gwuA3Tw/kcadneof+ 37GFu{+'7?2 o:y9b2"rqtpYA_>.@O#ff+hae: 4l e3_ 3s-WED4diI_' @ `gppsʿ'JV=i{s)j4 @ P~=&v&SKoYF$fko 46C+ {fVnv˕v5mr)YZ51iȺ=PygfbhLm@g YofV`l/vv3hG̀6e0wpFRv/߈4['Q70FF'Q7b0JF,F߈(e~#P,(oE_F ȟoiF ([7g/bblډ_, s.Vښ"A $bbljbkbA_d?LM@s?^2M<7Ql/bh` 3aE]_ 93`c] _ ꀢM:zrp&HM SR*dh CDb:nwmo>t$:byw3uZ`t#5o6Ȥ#B^1CNF|.?D9Y9nz0:ruXkhf"KoEcfW̠e? (att. etpCdw =\L,;@P8ȨjAG_g3g]? 4EXZp0 m&ߙ%LYrnw{@@]|#amu[Zh稹6%Y0Qezaq g`H^MhW#S<ɍ E#Gg]XŽn5,S }z^PyIRWz"8sOԹYWDZ8>:,*X\tA^cMS~))D1O;GWNy[r̯1H >{GȑZs ɏ_ v"o#ia|v/A]k]Nzo#la6=G8a^ruZg}鵞xM ^ZwoYB}b`L'KÃ6eH4D%#.3paL ;!*VcqnòG3wGMGPs:9_4 صtj "q?NPI# IE}chc[M#4?Iᯝԧu,g &HKQ^TTBf}+5Bk%ׯ6.k׺_[Z[9I'VǕ鶢Ѫ|NG86&Spys7cdܝ6]שOقW_M,A" |6&(!eE_R/U>(=5Dž/k(tC3K)f@KXxjM~d%9N>96:%q69U|2xi@\fO*9r.{pBa >B0[xt1}e*ҫ^1>f&`t7h'dØËscNǂG> Eb*JQ]U`%4VD׮De|l\K THwکNQ +凄ppEi^YCAwkمJvsCFF>%eD1b5PCASrG>HԿUQ*, ePJ; PR-O1&.d؋HdsҘZAym@(P:Ȓ= rq,%͇R3i#bz0vD[ȔyJ t<>Ѫ,*(Bzy8Zq+8 Nзye%cK UFW[_`~bX̘xJCks QI4 tz`5Pњl_X KciiӃ/]n/}r轷mFVYCB3 Dt^j|Zqu^$%q/ l99u3~?@JW 6&V!إu6$i.i"@YDF p 1ͧ9(NwǜǦ㽍`MX_P2&c34_`K^5VJ`h_Q8c$Q{^66K{I+GP{ S|+Lu^E wCtI:7?=SwLH'?jwf/FYBa.q?KT b: .C8NX.vOt%\CpN'{wȅ >@$>V]?hi^C-F s;nKeL/ȨPsҫќ͎3oxD>,W~7`FjNK %M{*HR.FpE3 xˇ-Ґt)CY9A7&"yCO߸|WW$'sx[ØDnT{hM`3ޜwGyEhj'P;38ٰN{;F ;V pv+L2 釷7X3r^p#DF>>Nj_n6@ BfV=T5{MvfD]Sy=t4it}; ) *5,k \d38*lB)4BGβ+ oOeqS}-낡 WdUoSN[A\dX^_D"䜑}ͻ+(w~4!41(ef.qDM[3%{,1Dsf&.ޔC<;ƚeloh!6e.*"J7ŜyBv:tڇXƳ׷Y• z>#Fnkؑ$ WͬݑOa=z 2$ /16uЗ֝iU˻@)Ry겻ԟݛe2Y\]0fdq11ILǔQ:Mf۫,lٵe'Tw."  a\6W/Zbl4v-~<,Q~J4Th˚dI07slNP>F)1pqm^5t2Ȥ󬩍 @"S޻qomʷj!_cTf>3oQpue >{f-.eoZEhm4i㜮 ir[W[ֽwEӴ?鷌nعOp<)347gFk|?ˇ'`S9 ')j8<\.^WS>pJJ~Xh7bLHfLq%^j%n. .9;1 < q-kni=85Tzr&st\OCeUoq)y^˜q#x?u{%7&j3B)YZ̷u%SEN|Tg?%C\h $fij>V5+8aR,C6,3<[ jOfY/-DOʱ9"iKGu (*Xj$& oEN(F&) dڎߨ1!,+# B39⽞ȝקhA^^K1V0pncW> a5gW:rUdH\B-Qrwm&?[Fy4Mʎ ɞ b pD)Ga1B7 ;z!7/̯>"\PJ+@}lt.ȠFy9[KX 18M4qBj*E{ڷӹ=9OĥK#:UAO_}Anvh22,A&N ?${Oٔ[ja@_k<;nd,7m8K0nWt<0V7+]2:XdCV߀!3`‰ߵn4aU FePbgv+ ^bxDl4W$ 䝯8Hт3ޗrcQ9t|m ĞhKwʼng"YNkNcˆdr>"VZ똼aQ6 i*WﲈoDFۂ3"A8\O4̻E#6 3]:C|_8KAӊ43"n6¿E䳓lv`('%f>(:ѫNTH7"H5Ϲ_b, HUZmm|+n=#2ܽ/C΁KlF%cRr jcslb81;WRfH3 \&TEv!{fFu 1հ˥ˣK ̧H1GƐ>Ȑ {0o~єU{UB,\oRE-D )=sTBކ]ǡa aI^]Ȍy~8?Ɖdbx$]Z~EͰ>8f dzޢq#L1 dɃ(<nж/h35rW:6јh00E((m=#CMb9L. 4}rg{Y&)Exi>&Yһ_ <-.Y|U:)JQwU4`W,bt 7t >VP*pyGҊ"DB~-;+ l\;ި0쬔eI_~$u'85FcvX5e:rKԺ(؜A!UT4Wmĝ/gNXs.8i͐Ãhkt ܮ[NQl+yc  LK\ogM}~e߮~^{@H= !4$ص1c$`l@gafN6d.uRHR& @VbjP SAq\7)K57%k(?>q3 }Dsj=̦Է*;򰤸V9 p#ٿðIia;B3 '[%7B G4 #'L؄>o+za{mNp| dq<}9yLWjaoub &Jg4?̮^˗0+ iE%&ìJOk*z5 MrW6ǵzR4"tU$&|Mn^dm碙8O?uEYoO4I!7Ttmn;S0k4?Nds3M *vb<>NJ~=-N A1fIH TQ>Et ([W7h1ɢH]3m81&]`ve-m\^*!q G^.K6OiT3V_o^n[Êh2,YP%146|``\ OS{A+䟫”+DC_TSqerv$ XF7Or::CYu'nRs:Z1z^ I5W qgbٰt?}A@K}+=?uoV}\1l}^\}HDV[R8COi-,Ua?nyE~w,_L+K9[VXDtN&2?w.݇4">-EkrE3/]v N$D7Td l~šUɸ\Mґ=AF V6)J$TY\P;tsjdqTMń:u?+{w}~ȋIH:PvBvzG&[q9< +ca `W<5(&٢ |&4(QCunʉuW9"|S(YtbR)ӽjU|ɺBw; [àmuc\֖Wgݻ[o:/u+OPEJ wSUk|݌]V΀So.2?|f[Zfԣ=Rt_Z]I7ë0DKa6 )$(q24$`$6N0lOmEy,o Tp5M8ޛiA;^QwTǰku}OUGEpԬ7?HY? ;w``8SoGݛ0xBWFV<$$¢c!3WcI$$8Ej"ɼ6mC {Թi\䃺!ڈ3'8[]AW~4KR bgǘ~O?-""svc8rV =Dfwp zDT7 Y8 #q]NŃ=:xEuSHAY\bKߊ=nW7fui&Ȟiоa啚pWTQ1yU|B!U-qq#jS^檓_&rMA][ˋ\ٕ<ԪI0f08ŵztJ̙݊d\A_]HfN-]ڴ]ޚǙ;*-9ڙ2^00p_PGS_''nͫ{26?}p2 j]ֆ%"[)vErxP'wo/o7^Ex,禣c:zė>\|EXf 'VHYY~@rUG{:Oml[d.PpK%9)m,5v'PDNXj$#RZx=ߩeȊ@~L*>HP"aA=B$vaPH\["5>m, `Q2&33Ǖ&gl1RPů`>x<(0I=/" ѳQ-^%v<^0[\Y 1Knq7h kMC08#ΩpˑwzDP'jsNs}9rxr۩6_FyOWw~7f:Xj48=BSõPWv3h>ƅfzf0Ky^(}7~,sH#CODG1 gӳJfhJŏ?bC';#`15vdϡ17?sRH 1aDOheV(O1|lQpT|/j=KS ԗv^픉pxfnCP۸k(]tQ>4/g.$L ,?9nc2!;D->N\nwiмJQ}?pn ̙ u[;ʕaQicỸ5 +䢯xrƩ`.G}]^۩R_"|9Q(Ãm#7\~&O)\CpٙKBt:eb$Zg^ٹw1W!=Nʈ;-US#^ӮT`Y]Vb`#aPq2Z'z3Ar/GvVՙ"K7O Nwe9{'lyt2Mdv'vrRÇs7ޥo0OnWt=;{2߯$*YaGs턆GqZZ*1u9,"UZb}u9}b֣DCG`3L ~yT6'\ZWuxY^Gi.$yrD)]":HK*,VCBɡtjg8\@K 7 ն_uB I)?@4V[$:ji<|S>5c }~ R4-kw']5𕗰j cxߢ / `9@Ą |; X`A׼wC.2܂~UѨܚ4a5HJؓHJK׿_ )A@J}Q'*Ca|eE/Wv]ޣ g^ѐm;nyP]Uؕ-],řcMR4 "pEr5وgqB? [ fu2DӺ6rSo ?0N5E=ՠǞ1W-<~dgW~[co)X\+*\bE !^HeqIn (I6*W^W\00G^MQ\ĶEV5@_íC ln,sp|ױ1GӋaLn:a4-94S,2Z7mot:bN?c\j8lQ!NIݒe<wh~M^rToҿT5PfhwOJUN)SJlrj K- ,\hBrgy#)Ot5tyJl: X{XO;nV3F}EW&LѳԮ*-#ӭZ6zME{K+v;"d#S ƷxBOb`F{1(:<;ݥN0lmT_jZکfWzZY7Ybyp~jӻ׫ן8Iw-nq,DC~$ 0] +o:JDL`g Ӫ}?ȣ MS]2ޮB=SM$HB pŝ6ySS6U dfDY;  ڶ0dt/,}bբ.F+Ɇ6/ZDnc43=;1n֛4]8R'7hP08 fRǹ>m!UC xx b {e!His+ ~Ea}R _{P%zkp2>ޞOUxè:SytޛkEm~ڏл?䗻4ɱ6HIƊ(#[s_ߧʗWtk}&h2|>x5@=V83@+sOy*]wk2Ҥ1w%vʊ>W`dd@? "K{.rx/tZŊ5tE"T{\* ec"rՂNѹ3F; P5䍌}rzSGPvɘԉ2tYgհokrGj̰>,? N$l9BZLc la+l9I{-^2~E17@)nߠ! }fVΔݸ.x\8,r=a-=uT'q|^G+}h鸒8gƸRP#BFg᫈otУpja\ HtȽA<~n*לBoUg}u$,GzˌvH,ܑ9QФ?7hۯǕ˰"HM@GoYliPs (]eΊҽ* >7Уk&a|.4) JA7$M++y0>ǧ}%4}U]\"'YHcO󏍰R ql{'RGrՅZ^q?=GAsKU\$#TxuV7$XqxAtPgRI뉈v  +lԥ?>M]3`Dy8.R!o橱F- ZƆF AQq*PQCz6jX{⁣4`yηdVq>n' ;i#OT435{{~S2,ngJhKن~=bSeȔv'2N*eV}V yE "߹}p$֤q2':O3μ7 Tvc~ƿ uQTGϣDzmQ>9^F!JaQH+8F2f5:ܵ^s6yuYd`vީ33/)MeChː) zj ޓˑ*C%֟0hDa@o{@ $ϵjީWdq1mvFVzyڳӶ4:v }~ux[6=/lW7 ˩Қ)k ސ;STdWY|qLyq D[[]-?f?EM_2\97+Wlu3^Gn7E}\Sj TnߟWf?dQvl99CU>NV8yhCnTErg1W$B [}Ӭcܦl >+u䈑sj!2x ~3(؍Z4QA~[0>{ju턻zۢyCc"I @Teo)NڛxJ.|kJ*L̞j Iso; {`*#XPF[vvP02U?H:{~HߍYӞcoǀ"ޙso2uO/A8+!Vt*c/*|ٱ xjˋV^1ˢIOSL^[Lৈ0K Ђ%i<mX%7*Of4}nkT$dRZ@%tT{5ZH NZ&ŊUȟܦxh U3~߭tykm{D]2GvJ8tǨՅ.i\Gk?C{JR@/ ]W7JE@'=3EiǤRiqd!bk04Nz?C(WEEqccv30؋ҭjl8/2~~afw6"AF&iٲIШ^R%Pak 3!JEgSX1쀮4d1J'y9X,jG[SL>>#% F(cC$*ohti "^f-ˋagL{˹;ә)=۰E-!wg1ooN&=I<5ujqҢ703' ;䑔@x>xMs/3+_/c֢. ]J7MA"Yl(&}sϼp|'zE罵ڿ5^:)G gK|[.I<^>gcCXROVvf3'6M;>:*FCD{ȧ rayT޺ |2UB?3/l{?Vy2l4++IC:35D-v;F2 ,/9˅fMg}oiUBy)TFffM'6eiu#mX_\qO΢Y69"<.v >|#׍7D T!-A~IWV-wRm2,`'̒ơ:, TuaoVBpX $Olfz4̊LJHflϕ'n-")xߤve{y&XY^SkwvIFw9]_?7s z[8^A$f8/ "WķHh? n̡m&!d$/6Aed8$ f#t1RYR3:ֽnDxxwnC, iSC Sk;|߮մ7IGe-FĹJjD(,yc(l ulj~}f<8WC=}wIt#tpB ]l"k͓]/$̑.) =W3"Mca='րB- N$-129 lڗo3 rP%2sSҼ>/ =o]#6$UD}: >oi\Ȕ<,U EEMBնTAn72":TӬIDch3I,}qJDݓ8,B0B#Gmnuũ&,zy.dUC;4&x6zNB3 Dr['*365xxvK.e &$hنcqSsͰ>_ې~]6>ts! ,bc`6|Ms?ij~fЀNlqhC'ԃ-72R)y4~E_vҁ'%(0z3a~ bmTPe<:ÅUtuȼeM+]V`N@g"0JR?a;>fC}pQu5pbYtNzonSgw7sK3E~rKjއJMFfK3nfWF `v-{cg>-S6%vg۷!{ CE~!,V=l\٘JU=eIJr :JЗV,2#Ԕ9^Hų#:s; PqTDppMV37"9lF%~t[E/˦TTA,ˢZُmrwKaB"W \5]k]n%uM3\ijV+ƄР˧e@X -Uc옱抛8-rRrfW`W 3q/ zt0mՅ+ L+ۓ7֒r?4p3/L9HzʭU6QX2y!*Iň7yXY-TIakk@ 5KMǡ`֘'|S׋PyAe4.rqvҺ;nZDFWcWAGdürRbLq>HHRpuqr^-7g{r8LrՅ~Rngy)5di.Jh]X[r&X5|wcYCb_*' )/]'y&yHI=Lo c":o|Ow DټyNr8j!8f`vŸ7JIn[fSzOźm@Z9 BMxI ]5F΅Y"腙a 8Pg[3淚c<)w͚yjեEbֺZ.l$^%~I G*zq"?Լsi͞Pqp@"kit儹ۆ>Ykk\%<,Xe'"WvFTGZ  [Bw]7>buGH w:ZNYIzy*ZL&pAF$#f8'6X %suufJ&Z+S,o;֤7VeҼf(IKosێV'Z}Ipzޓ_lħo P9p{eA?OHuJ qu%T9€M}о5+F;zu~n}AJ nR;8so3GnS,{y`2)B-*(w)?Rtfy_$$< WׄT/PA^$=i|muzE! +觩*2JNE!buStk+;'KA~4%&pΝ[Z RKW0Wb``_'DR ek'4JBkXPH9_Of[YX|; [,`ɘr3h go)9>lHa]dzxW]Ġ|rlH'= Z'Fc6#$~zW1V~"sao|^~⭆~s/Wga< Ȁ"oo[åPo tO6G=LtqIN(sii ĿxYlA.O{+)xjC6όvC=@@C/9՗ 6رrdjRb )S2#7e@A_w2’zvNJڇ^P\Y,fv)iX Z M˫7>*=yTUn _,ώGRIK&l=A2PAz~ڇܧ~m%7hEoHmc^F:hfXUl\c 4d-'tDb5xSb'/#\ױy$OXC N}{1!cJiOpЇ& a=\r2]<r k'o `ɂkrCc`ȕ{D>DJtA%3\Y SXJW씿?C1kZ_@=YqwcMP[AvBܬl:%>0))ſٍU%n&sQܒ.E;0zrM{nԼFy'&U0WĜ_Cidx#E52D]-NMeC=OrbAml6s=jiTUjFd#fjrxnKN<ؠ즰Yf$"BႋC*R8.1o2&Cn<g$* ՞c~)@や.aN}Íb'\$]O'ف cEo /ۛ@vW kf^_sW|<ܬ1_UU=Xv|$nP">s )BOዊ'Rh |  *^pNV]x?ϩ976@ 9ؿ1];F VKh2qKw/u%s>mB h:f u@IC. TWyP?5c SD f8 hL1Qia&e$*%}H SEnƈb8r׌v6 . ٍbX@$Eq=~=,Ê>%\kb)CX۱}Zdc*Co˃L'UncAS,Ƽm->kL91V|$IhR*N 4,!SvH]W> Ae\+J$@ܰXˋ H#"uew/kU^g/ UH_> stream xڍT 8{'ו) !ʋ0l Gd1fe;f1(Q]u(TnBBEɞY ~|3339(:j?h38Zx ppsNP**n~TAF!,X v9fv\:zFx}# p_0I b3YP@ /xCC}t 89`ґB09?@r8L#,a!l خ N AVH(! 5 Jp ؟0#@q! `#)\dHwՖ82Ag03@X-Tb,')8IfCAъ9A]l'!:, X2p‚6 ї8b lɠZ!! F-o')ȽcẀy/ bPiK4\&v7 傶;W0 r]g ȧb3 ~ɍpdL "0స`T-P!  [u >Y!pK~A6 3#[y:xl[5hnH-HA=)qAWn̖7t&W v>ha27w 㡣s/%>U{8j$0Ϳ_s_7l0d_W͠ȌWMjN 6Q*#p\DbvՃ_l40^*x2qVك'6[e7t]z36~-ƴ>zWZ6ۖoŠ tino Jq1Wl~hǴ˨~Fw f3k},Bd' O-˄h v({FzMmyѹ ~NQHR'rKN~|yYuYEӺ)DW'o6~<+>(-(i;d"h_쎃;YJy|MK\6בּyǻ<֪TE#73y:)]QO}W{Mi2ͦDI5Moֻ+Na>\mzz}m¸"Icv_iGɦDCOFzHYpW9'nhy)w禍ib>JfՆNu,n/U&n; r YShqktRr]_ZgA-6VJZɡ ӿwrWwȓr cQ.EUXHcÌzb7W@n:lߪVr#VTӹ]%ІS?IB(^mZJ&s s s1> SkT{HX \-WCIZK4Gٻ'qwۜ>&vM>Ǜ0玨}==p&H;+6ú/268iȪihDɖu[ }"hDOLl]NiF3) ޜ+xRGbuj2,<3…(F'=j7=OXa^eb8Jh&߬MOf ?[|"l Tq싵@a_GҫV@#,!d{Nꖭ >WrEpG7֞N{tV-o϶Gq}OYfGP vB&Q*},M4g&gqb§HQ5T7<ՊH})Ȍ@DDpdܬ'|L}d~GHg1hM\$wS{f\8(zo06ws2 d+1i%4mIz P9 .cƙ ڡ+ <鰺QQYh[^aUS磉:~ffձ &ǚss x6j-}l,4$$ b/^,4˿yǤD U< 6`vzdR]Mge/.xy)-e2FIg=TOUS}zO,/k;. |L~ 9SV|̣)=a5FIT'%Yrױ>jGjv2:_pث0`?gZΞKBoˬ,gU endstream endobj 571 0 obj << /Type /ObjStm /N 100 /First 916 /Length 4493 /Filter /FlateDecode >> stream x[[oG~ׯ ~ qb:Ocibω,9Q_~dL_8-+=TE#dMc]oXS1 Ɔhg Hq1To&XlkG&xci%6!HDMhmjb%rDV&I,&dKaNƚ#KX]"=j=G:ЙICR>8GX:8"Y[J)xהhhўG"MLS2-[K!,m. \ Lc(!]]m>I1Xz}L–2J,1M.%ڗ j*C86:BU@^  p 415dMbm!o9lDr،؜<=bsTc8<ȜdB7b@3Myf6fsL gkRd@jA\fx?%޸`=UQ"ZOH7+,!`B$#D,:4t$#Th\G2b@H1HN=J$/HL3(iF2R%=c Oddؚ\fsG('v|C>L!z:533{p,ޞPVs.rzyDխ6unyR(pZv#7tiڿvѾmڳ]./OO_OW7}h?U{ul?ˋO]׫]ĵ^}j7rn~jo_OǂY ~U|q}O_<;}@pvp0+p6 w8?&嗄c paw_>~շ/r0] sN}|Ʊ 0Qf[_ڋ͒0{8ya C?wso$*@|j)?ǃ~~@sВ@߉0<珿ᑄx>`P?xOZX*8ؐWbWO js&T"t^xؚG^ctzy,zE>nk &T{rТE)]pNSrSJWs2OA=u-5̷v`>w߲pF/%'3wۜRzqy.gfuq)Z\MY5g.ow(~v:?C(rh.%^.H4_,k7ޒwa/n֜͊٦y3 syNZ]]/}S맯_H!Dm;O!t8?Ksŏ3^ih݁N߼#i>߷qdpu@NZO݃u_oޯ_,~ܚxꉷ=G}XzH'=]K/Yw']ױkOzq/>?8~sw?Mc~ >ć統IWw5$#zF߬͏xѤJF@6vs`4Ni}=$"F=! ٣ m2lف1h0fsAoUU{\QSX!μ9}w~mtgO );nӠlzS; {!nX⌦q2mS\j:nMښP2@neaI4{{2tk7lꚢA-IFA^fGѶP03esRQ+^QvЗ!^Q,.;܋^\cSQ s>ux^f;T4C;kf8p';>6q} 1©2׀0H&KMaxz EڄauP ;D}9(rօ~ Di%t\AWN9}A% 龎?Ff_)DžrpLMN^,1©} }m̈\?qڂ8\I%@z)fM<&e{+uT$!~Wg^nכcT/."7w',wp_B 'aDp 8AҫOVVfoV 聎KBU*vT%`oX1ϬA,H2";3@OX͉82*v4 4ɳ1ˬ9@> endobj 635 0 obj << /Type /ObjStm /N 43 /First 380 /Length 1647 /Filter /FlateDecode >> stream xڭYM6 ϯбS (R([?Ѧ"M2Hv_>XzHE=>Y4B9 AHBE%dJdg cQ{Bj֗"Ū/)DΤ/b!֚vpLmf\B}CG@1<8b!g T9ĝ0", 0cȅ1` j8PbKR`NB( pQY%W)C w*: 2BF/6 ʨ#ÌR(梞T$ȕww/>%z'ezUb aX {Eټ%S!gt&) h# * gNyP7|K5B턔UҼ|{@CoSffSyM-چ<ɀjn.ԧT3\Ê8_k+uW=E}Sv"40_y|s )sI*4Oxx{|I9Lmt٢e+kllK0\M9qMcy9~y`AXۡ1;Q3ioN{;VuhKu5M% c:> \0͇~2uNCYSk+h]dkF,t͈U+O~.N:j;vݟ1_3׌Eܙv7)K5)[JRw)VT3ٓ/>t47sGKW|xQeŋ2BEo7Bb?b_Ŏ^Ʋy}b71b.b7)zm2E'b!bWbXe(7yQe-,UbX]'VƉUmBkuqB!fuy_llbb/vlɴ$yk3"lDl/?p>[,  aV*v4[?t~LV! #[o,*voSӨX*Xob95=M= `]2U~s>wwVGso_tI|h-uj6 /sgutxa}~ u endstream endobj 679 0 obj << /Type /XRef /Index [0 680] /Size 680 /W [1 3 1] /Root 677 0 R /Info 678 0 R /ID [ ] /Length 1538 /Filter /FlateDecode >> stream x9s]Ik˖X^}_631ccyƋ,ʋ @PLD@AQEWND |7 " Ͽ[J)2*}Oӣ2ZFKk`ڌE1Xga\O 7e 0TmpVoY&&cj1 [Ԏ3 jy߳`YO wNsj6.1{.}l]U;mx:oj>2<G6}Wۢ{pBm'N 﫝Ra~Cj F=T?yZ |3j1rrVgƘqÜsj )Za y0|IaZKN]ZA+p<\7܆;p}X%x<'<V7މr\Ae2aY7׸ ry< gb'kx:kS!}X} Pgkٹ[npi++{A~B Lwѹ'k9uۥxnUtIQnub-.\]+"5.H]K|p!o)9]TtQEJ.*]TtQEJ.*]TtQEKI.%ΐR_J.*]T;y*` 1Xa6L4d쎛!{VN z {B{'Բ>Q5TCU:WҪ^W5;VmuL-Kiu)eY&R.Tt+p :, 6܁p",x1< sk_@9闰5@rFr#Hn$7j6 Z}~77Z~0l5ɍoRۨm6j$Cgr:3܏m QXmٰrajDJZn"6[G; 6yM4jSo~XfKht7*p8o7yq8o7tc197gHn$7ɍFrpoXoazbNJ.˰` 4,`5<}n a~0kAmP`5X V`5X V jڠ6 jڠ6 jڠ6T@mYU_ B 4 B 4 B 4 ,kr>հJ~H@mXoooo.*ޝ;ZCQ7^߾ou?jև?ʫZ7ʫZ뼚yfgjզ:ŏ*OF! 1uXpnmw܇EX<1<'exyb|/a^kx9uNQbG`7 o 0~ 6&(9h)ip`t38K a}`:9pQc cf8'TwJ?q endstream endobj startxref 179550 %%EOF lwt-2.4.3/manual/manual-wiki.tex0000644000000000000000000012720212067037505014742 0ustar0000000000000000 \chapter{ Lwt manual } \label{lwt:manual} \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 solutions have their advantages and their drawbacks. For the first one, it may work, but it becomes very complicated to write a piece of asynchronous sequential code. The typical example is 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 should 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 fast 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.simple-top";; \end{verbatim} \medskip \noindent {\tt lwt.simple-top} makes sure {\tt Lwt} threads can run while using the toplevel. You do not need it if your are using {\tt utop}. \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} \medskip \noindent This function will wait for a character to come on the given input channel, and 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} \medskip \noindent As you can see, it does not return 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 creates a pipe, and launches 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} \medskip \noindent 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} \medskip \noindent 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 has not yet returned a value or an exception \end{itemize} The thread {\tt t} is sleeping because there is currently nothing to read from 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} \medskip \noindent So, after we write something, the reading thread has been awoken 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 the same threads twice. {\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} \medskip \noindent \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} \medskip \noindent {\tt bind t f} creates a thread which waits for {\tt t} to terminate, then passes 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} \medskip \noindent 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} \medskip \noindent {\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} \medskip \noindent It has the same semantics 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} \medskip \noindent The thread will then fail 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} \medskip \noindent 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} \medskip \noindent Here, cancelling {\tt t} will in fact cancel {\tt waiter}. {\tt t} will then fail 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} \medskip \noindent 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} \medskip \noindent Canceling {\tt (proctected t)} will have no effect on {\tt t}. \subsubsection{ Primitives for multi-thread composition } We now show how to compose several concurrent threads. 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 waits for all of them to terminate: \lstset{language=[Objective]Caml}\begin{lstlisting} val join : unit Lwt.t list -> unit Lwt.t \end{lstlisting} \medskip \noindent Moreover, if at least one thread fails, {\tt join l} will fail with the same exception as the first to fail, after all threads terminate. Similarly {\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} \medskip \noindent 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} \medskip \noindent The 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 store 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} \medskip \noindent 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} \medskip \noindent 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} \medskip \noindent {\tt with\_value key value f} will execute {\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} \medskip \noindent \subsubsection{ Rules } {\tt Lwt} will always try to execute as much as possible before yielding and switching to another cooperative thread. In order to make it work 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} \medskip \noindent Or in the toplevel (after loading topfind): \lstset{language=[Objective]Caml}\begin{lstlisting} # #camlp4o;; # #require "lwt.syntax";; \end{lstlisting} \medskip \noindent The following constructions 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} \medskip \noindent the thread {\tt f ()} and {\tt g ()} are launched concurrently and their results 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} \medskip \noindent \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 exceptions 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 might appreciate 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 don't 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} \medskip \noindent \subsection{ Other modules of the core library } The core library contains several modules that only depend 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 concurrently, 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} \medskip \noindent \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} \medskip \noindent In {\tt iter\_s f l}, {\tt iter\_s} will call f on each elements of {\tt l}, waiting for completion between each element. 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 touched only for new elements 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} \medskip \noindent 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} \medskip \noindent Note that streams are consumable. Once you take an element from a stream, it is removed from it. So, if you want to iterate two times over a stream, you may consider ``clonning'' it, with {\tt Lwt\_stream.clone}. Cloned stream will return 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} \medskip \noindent \subsubsection{ Mailbox variables } The {\tt Lwt\_mvar} module provides mailbox variables. A mailbox variable, also called a ``mvar'', is a cell which may contain 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} \medskip \noindent 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} \medskip \noindent 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} \medskip \noindent 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} dependent 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} \medskip \noindent {\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} allows you to register a finaliser that returns a thread. At the end of the program, {\tt Lwt} will wait for all the finaliser to terminate. \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} \medskip \noindent 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 supports logging to a file, a channel, or to the syslog daemon. You can also define 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} \medskip \noindent {\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} \medskip \noindent 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} \medskip \noindent The advantages of using the syntax extension are the following: \begin{itemize} \item it checks the log level before calling the logging function, so the arguments are not computed if not needed \item debugging logs can be removed at parsing time \end{itemize} By default, the syntax extension removes 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 provides 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} \medskip \noindent instead of: \lstset{language=[Objective]Caml}\begin{lstlisting} open React \end{lstlisting} \medskip \noindent or: \lstset{language=[Objective]Caml}\begin{lstlisting} module React = Lwt_react \end{lstlisting} \medskip \noindent Among the added functionalities 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} \medskip \noindent Another interesting feature is the ability to limit events (resp. signals) from occuring (resp. changing) 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} \medskip \noindent {\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} \medskip \noindent \section{ The lwt.text library (deprecated) } {\bfseries WARNING:} the {\tt lwt.text} library is deprecated. It has been replaced by the {\tt lambda-term} library which is more complete and more portable. It is available here: \hyperref[http://lambda-term.forge.ocamlcore.org/]{http://lambda-term.forge.ocamlcore.org/}. 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 with 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 fail 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} \medskip \noindent \subsection{ Terminal utilities } The {\tt Lwt\_term} allow you to put the terminal in \emph{raw mode}, meaning that input is not buffered and character are returned as the user types 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} \medskip \noindent The second main feature of {\tt Lwt\_term} is the ability to print 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} \medskip \noindent 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} \medskip \noindent The second class of functions is a bit more complicated to use, but allow to control a running read-line instance. 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 pool of system threads. The main function is: \lstset{language=[Objective]Caml}\begin{lstlisting} val detach : ('a -> 'b) -> 'a -> 'b Lwt.t \end{lstlisting} \medskip \noindent {\tt detach f x} will execute {\tt f x} in another thread and asynchronously wait for the result. If you have to run {\tt Lwt} code in another thread, you must use the function {\tt Lwt\_preemptive.run\_in\_main}: \lstset{language=[Objective]Caml}\begin{lstlisting} val run_in_main : (unit -> 'a Lwt.t) -> 'a \end{lstlisting} \medskip \noindent It works as follow: \begin{itemize} \item it sends the function to the main thread and wait \item the main thread execute the function \item when it terminates the main thread sends back the result \item the result is returned \end{itemize} Note that you cannot call {\tt Lwt\_main.run} in another system thread, so you must use this function. \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} embeds the {\tt glib} main loop into the {\tt Lwt} one. This allows 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}). Notifications 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 three functions: \begin{itemize} \item A stub function to create the job. It musts allocate a new job structure and fill its [worker] and [result] fields. This function is executed in the main thread. The return type for the OCaml external must be of the form {\tt 'a job}. \item A function which executes the job. This one may be executed asynchronously in another thread. This function must not: \begin{itemize} \item access or allocate OCaml block values (tuples, strings, ...), \item call OCaml code. \end{itemize} \item A function which reads the result of the job, free resources and return the result as an OCaml value. This function is executed in the main thread. \end{itemize} With {\tt Lwt < 2.3.3}, 4 functions (including 3 stubs) were required. It is still possible to use this mode but it is deprecated. We show as example the implementation of {\tt Lwt\_unix.mkdir}. On the C side we have: \lstset{language=c}\begin{lstlisting}/**/ /* Structure holding informations for calling [mkdir]. */ struct job_mkdir { /* Informations used by lwt. It must be the first field of the structure. */ struct lwt_unix_job job; /* This field store the result of the call. */ int result; /* This field store the value of [errno] after the call. */ int errno_copy; /* Pointer to a copy of the path parameter. */ char* path; /* Copy of the mode parameter. */ int mode; /* Buffer for storing the path. */ char data[]; }; /* The function calling [mkdir]. */ static void worker_mkdir(struct job_mkdir* job) { /* Perform the blocking call. */ job->result = mkdir(job->path, job->mode); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_mkdir(struct job_mkdir* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "mkdir", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_mkdir_job(value path, value mode) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_mkdir* job = (struct job_mkdir*)lwt_unix_new_plus(struct job_mkdir, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initialize function fields. */ job->job.worker = (lwt_unix_job_worker)worker_mkdir; job->job.result = (lwt_unix_job_result)result_mkdir; /* Copy the mode parameter. */ job->mode = Int_val(mode); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); }\end{lstlisting} \medskip \noindent and on the ocaml side: \lstset{language=[Objective]Caml}\begin{lstlisting} (* The stub for creating the job. *) external mkdir_job : string -> int -> unit job = "lwt_unix_mkdir_job" (* The ocaml function. *) let mkdir name perms = Lwt_unix.run_job (mkdir_job name perms) \end{lstlisting} \medskip \noindentlwt-2.4.3/manual/menu.wiki0000644000000000000000000000003312067037505013623 0ustar0000000000000000= Lwt ==[[manual|Overview]]lwt-2.4.3/manual/manual.wiki0000644000000000000000000011664112067037505014151 0ustar0000000000000000<>.>> = Lwt manual = == 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 solutions have their advantages and their drawbacks. For the first one, it may work, but it becomes very complicated to write a piece of asynchronous sequential code. The typical example is 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 should 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 fast 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.simple-top";; }}} {{{lwt.simple-top}}} makes sure {{{Lwt}}} threads can run while using the toplevel. You do not need it if your are using {{{utop}}}. === 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, and 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 return 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 creates a pipe, and launches 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 has not yet returned a value or an exception The thread {{{t}}} is sleeping because there is currently nothing to read from the pipe. Let's write something: < # Lwt.state t;; - : char Lwt.state = Return 'a' >> So, after we write something, the reading thread has been awoken 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 the same threads twice. {{{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 terminate, then passes 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 semantics as {{{Lwt.wait}}} except that the sleeping thread can be canceled with {{{Lwt.cancel}}}: < unit >> The thread will then fail 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 fail 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 concurrent threads. The main functions for this are in the {{{Lwt}}} module: {{{join}}}, {{{choose}}} and {{{pick}}}. The first one, {{{join}}} takes a list of threads and waits for all of them to terminate: < unit Lwt.t >> Moreover, if at least one thread fails, {{{join l}}} will fail with the same exception as the first to fail, after all threads terminate. Similarly {{{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 >> The last one, {{{pick}}}, is the same as {{{join}}} except that it cancels all other threads when one terminates. ==== Threads local storage ==== Lwt can store 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 execute {{{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 as much as possible before yielding and switching to another cooperative thread. In order to make it work 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 constructions 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 concurrently and their results 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 exceptions 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 might appreciate 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 don't 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 only depend 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 concurrently, 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 element. 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 touched only for new elements 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 iterate two times over a stream, you may consider ``clonning'' it, with {{{Lwt_stream.clone}}}. Cloned stream will return 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 contain 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}}} dependent 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}}} allows you to register a finaliser that returns a thread. At the end of the program, {{{Lwt}}} will wait for all the finaliser to terminate. === 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 supports logging to a file, a channel, or to the syslog daemon. You can also define 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 checks the log level before calling the logging function, so the arguments are not computed if not needed * debugging logs can be removed at parsing time By default, the syntax extension removes 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 provides 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 functionalities 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) from occuring (resp. changing) 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 (deprecated) == **WARNING:** the {{{lwt.text}}} library is deprecated. It has been replaced by the {{{lambda-term}}} library which is more complete and more portable. It is available here: http://lambda-term.forge.ocamlcore.org/. 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 with 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 fail 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//, meaning that input is not buffered and character are returned as the user types them. For example, you can read a key with: <> The second main feature of {{{Lwt_term}}} is the ability to print 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 instance. 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 pool 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. If you have to run {{{Lwt}}} code in another thread, you must use the function {{{Lwt_preemptive.run_in_main}}}: < 'a Lwt.t) -> 'a >> It works as follow: * it sends the function to the main thread and wait * the main thread execute the function * when it terminates the main thread sends back the result * the result is returned Note that you cannot call {{{Lwt_main.run}}} in another system thread, so you must use this function. === SSL support === The package {{{lwt.ssl}}} provides the module {{{Lwt_ssl}}} which allow to use SSL asynchronously === Glib integration === The {{{lwt.glib}}} embeds the {{{glib}}} main loop into the {{{Lwt}}} one. This allows 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}}}). Notifications 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 three functions: * A stub function to create the job. It musts allocate a new job structure and fill its [worker] and [result] fields. This function is executed in the main thread. The return type for the OCaml external must be of the form {{{'a job}}}. * A function which executes the job. This one may be executed asynchronously in another thread. This function must not: ** access or allocate OCaml block values (tuples, strings, ...), ** call OCaml code. * A function which reads the result of the job, free resources and return the result as an OCaml value. This function is executed in the main thread. With {{{Lwt < 2.3.3}}}, 4 functions (including 3 stubs) were required. It is still possible to use this mode but it is deprecated. We show as example the implementation of {{{Lwt_unix.mkdir}}}. On the C side we have: <result = mkdir(job->path, job->mode); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_mkdir(struct job_mkdir* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "mkdir", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_mkdir_job(value path, value mode) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_mkdir* job = (struct job_mkdir*)lwt_unix_new_plus(struct job_mkdir, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initialize function fields. */ job->job.worker = (lwt_unix_job_worker)worker_mkdir; job->job.result = (lwt_unix_job_result)result_mkdir; /* Copy the mode parameter. */ job->mode = Int_val(mode); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } >> and on the ocaml side: < int -> unit job = "lwt_unix_mkdir_job" (* The ocaml function. *) let mkdir name perms = Lwt_unix.run_job (mkdir_job name perms) >> lwt-2.4.3/manual/manual.tex0000644000000000000000000000235412067037505014001 0ustar0000000000000000\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 % Remove the \chapter introduced by latex_of_wiki \newcommand{\chapter}[1]{} \include{manual-wiki} \end{document} lwt-2.4.3/manual/Makefile0000644000000000000000000000074512067037505013444 0ustar0000000000000000# 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 lwt-manual < manual.wiki > manual-wiki.tex.tmp mv manual-wiki.tex.tmp 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 manual-wiki.tex.tmp lwt-2.4.3/examples/0000755000000000000000000000000012067037505012337 5ustar0000000000000000lwt-2.4.3/examples/unix/0000755000000000000000000000000012067037505013322 5ustar0000000000000000lwt-2.4.3/examples/unix/relay.ml0000644000000000000000000001242012067037505014767 0ustar0000000000000000(* 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 lwt-2.4.3/examples/unix/parallelize.ml0000644000000000000000000000357612067037505016173 0ustar0000000000000000(* 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 lwt-2.4.3/examples/unix/logging.ml0000644000000000000000000000446012067037505015306 0ustar0000000000000000(* 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" lwt-2.4.3/examples/gtk/0000755000000000000000000000000012067037505013124 5ustar0000000000000000lwt-2.4.3/examples/gtk/connect.ml0000644000000000000000000002024212067037505015107 0ustar0000000000000000(* 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 lwt-2.4.3/examples/gtk/Makefile0000644000000000000000000000020412067037505014560 0ustar0000000000000000all: ocamlbuild -use-ocamlfind -classic-display -tag 'syntax(camlp4o)' -package lwt.unix,lwt.glib,lwt.syntax,lablgtk2 connect.byte