From c303ea9d172ffb0e768f1d7300cb637098b563bc Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 5 May 2012 18:18:23 -0400 Subject: [PATCH] Initial pass at Lwt conversion. --- .gitignore | 6 + Makefile | 35 +- _tags | 5 +- connections.ml | 85 +- directnode.ml | 78 +- factory.ml | 46 +- fanoutnode.ml | 37 +- hop_server.ml | 40 +- log.ml | 16 +- net.ml | 15 +- node.ml | 91 +- queuenode.ml | 116 +- relay.ml | 69 +- server_control.ml | 33 +- sexp.ml | 131 +- squeue.ml => squeue_linked.ml | 0 status.ml | 8 +- subscription.ml | 25 +- thirdparty/lwt-2.3.2/CHANGES | 198 + thirdparty/lwt-2.3.2/CHANGES.darcs | 2248 ++++++ thirdparty/lwt-2.3.2/COPYING | 552 ++ thirdparty/lwt-2.3.2/LICENSE | 4 + thirdparty/lwt-2.3.2/Makefile | 38 + thirdparty/lwt-2.3.2/README | 74 + thirdparty/lwt-2.3.2/_oasis | 383 + thirdparty/lwt-2.3.2/_tags | 223 + thirdparty/lwt-2.3.2/apiref-intro | 109 + thirdparty/lwt-2.3.2/configure | 8 + thirdparty/lwt-2.3.2/discover.ml | 294 + thirdparty/lwt-2.3.2/examples/gtk/Makefile | 2 + thirdparty/lwt-2.3.2/examples/gtk/connect.ml | 218 + thirdparty/lwt-2.3.2/examples/unix/logging.ml | 62 + .../lwt-2.3.2/examples/unix/parallelize.ml | 57 + thirdparty/lwt-2.3.2/examples/unix/relay.ml | 156 + thirdparty/lwt-2.3.2/lwt-api.odocl | 40 + thirdparty/lwt-2.3.2/manual/Makefile | 20 + thirdparty/lwt-2.3.2/manual/manual-wiki.tex | 1359 ++++ thirdparty/lwt-2.3.2/manual/manual.pdf | Bin 0 -> 239218 bytes thirdparty/lwt-2.3.2/manual/manual.tex | 52 + thirdparty/lwt-2.3.2/manual/manual.wiki | 1028 +++ thirdparty/lwt-2.3.2/manual/menu.wiki | 2 + thirdparty/lwt-2.3.2/myocamlbuild.ml | 771 ++ thirdparty/lwt-2.3.2/setup.ml | 6552 +++++++++++++++++ thirdparty/lwt-2.3.2/src/core/META | 115 + thirdparty/lwt-2.3.2/src/core/lwt.ml | 1060 +++ thirdparty/lwt-2.3.2/src/core/lwt.mli | 396 + thirdparty/lwt-2.3.2/src/core/lwt.mllib | 14 + .../lwt-2.3.2/src/core/lwt_condition.ml | 63 + .../lwt-2.3.2/src/core/lwt_condition.mli | 65 + thirdparty/lwt-2.3.2/src/core/lwt_list.ml | 189 + thirdparty/lwt-2.3.2/src/core/lwt_list.mli | 59 + thirdparty/lwt-2.3.2/src/core/lwt_mutex.ml | 60 + thirdparty/lwt-2.3.2/src/core/lwt_mutex.mli | 62 + thirdparty/lwt-2.3.2/src/core/lwt_mvar.ml | 87 + thirdparty/lwt-2.3.2/src/core/lwt_mvar.mli | 63 + thirdparty/lwt-2.3.2/src/core/lwt_pool.ml | 93 + thirdparty/lwt-2.3.2/src/core/lwt_pool.mli | 40 + thirdparty/lwt-2.3.2/src/core/lwt_pqueue.ml | 108 + thirdparty/lwt-2.3.2/src/core/lwt_pqueue.mli | 44 + thirdparty/lwt-2.3.2/src/core/lwt_sequence.ml | 209 + .../lwt-2.3.2/src/core/lwt_sequence.mli | 137 + thirdparty/lwt-2.3.2/src/core/lwt_stream.ml | 759 ++ thirdparty/lwt-2.3.2/src/core/lwt_stream.mli | 242 + thirdparty/lwt-2.3.2/src/core/lwt_switch.ml | 73 + thirdparty/lwt-2.3.2/src/core/lwt_switch.mli | 111 + thirdparty/lwt-2.3.2/src/core/lwt_util.ml | 117 + thirdparty/lwt-2.3.2/src/core/lwt_util.mli | 80 + .../lwt-2.3.2/src/extra/lwt-extra.mllib | 4 + thirdparty/lwt-2.3.2/src/extra/lwt_lib.ml | 134 + thirdparty/lwt-2.3.2/src/extra/lwt_lib.mli | 44 + .../lwt-2.3.2/src/glib/liblwt-glib.clib | 4 + thirdparty/lwt-2.3.2/src/glib/lwt-glib.mllib | 4 + thirdparty/lwt-2.3.2/src/glib/lwt_glib.ml | 132 + thirdparty/lwt-2.3.2/src/glib/lwt_glib.mli | 103 + .../lwt-2.3.2/src/glib/lwt_glib_stubs.c | 275 + .../src/preemptive/lwt-preemptive.mllib | 4 + .../src/preemptive/lwt_preemptive.ml | 195 + .../src/preemptive/lwt_preemptive.mli | 70 + .../lwt-2.3.2/src/react/lwt-react.mllib | 6 + thirdparty/lwt-2.3.2/src/react/lwt_event.ml | 54 + thirdparty/lwt-2.3.2/src/react/lwt_event.mli | 58 + thirdparty/lwt-2.3.2/src/react/lwt_react.ml | 461 ++ thirdparty/lwt-2.3.2/src/react/lwt_react.mli | 166 + thirdparty/lwt-2.3.2/src/react/lwt_signal.ml | 175 + thirdparty/lwt-2.3.2/src/react/lwt_signal.mli | 57 + .../src/simple_top/lwt-simple-top.mllib | 4 + .../src/simple_top/lwt_simple_top.ml | 47 + thirdparty/lwt-2.3.2/src/ssl/lwt-ssl.mllib | 4 + thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.ml | 175 + thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.mli | 58 + .../lwt-2.3.2/src/text/liblwt-text.clib | 4 + thirdparty/lwt-2.3.2/src/text/lwt-text.mllib | 6 + .../lwt-2.3.2/src/text/lwt_read_line.ml | 1639 +++++ .../lwt-2.3.2/src/text/lwt_read_line.mli | 453 ++ thirdparty/lwt-2.3.2/src/text/lwt_term.ml | 847 +++ thirdparty/lwt-2.3.2/src/text/lwt_term.mli | 393 + thirdparty/lwt-2.3.2/src/text/lwt_text.ml | 337 + thirdparty/lwt-2.3.2/src/text/lwt_text.mli | 128 + .../lwt-2.3.2/src/text/lwt_text_stubs.c | 84 + thirdparty/lwt-2.3.2/src/top/lwt-top.mllib | 5 + .../src/top/lwt_ocaml_completion.mll | 194 + thirdparty/lwt-2.3.2/src/top/lwt_top.ml | 141 + thirdparty/lwt-2.3.2/src/top/lwt_top.mli | 29 + thirdparty/lwt-2.3.2/src/top/toplevel.ml | 131 + .../lwt-2.3.2/src/top/toplevel_temp.mltop | 3 + .../lwt-2.3.2/src/unix/liblwt-unix.clib | 5 + thirdparty/lwt-2.3.2/src/unix/lwt-unix.mllib | 17 + thirdparty/lwt-2.3.2/src/unix/lwt_bytes.ml | 344 + thirdparty/lwt-2.3.2/src/unix/lwt_bytes.mli | 176 + thirdparty/lwt-2.3.2/src/unix/lwt_chan.ml | 86 + thirdparty/lwt-2.3.2/src/unix/lwt_chan.mli | 75 + thirdparty/lwt-2.3.2/src/unix/lwt_daemon.ml | 89 + thirdparty/lwt-2.3.2/src/unix/lwt_daemon.mli | 81 + thirdparty/lwt-2.3.2/src/unix/lwt_engine.ml | 421 ++ thirdparty/lwt-2.3.2/src/unix/lwt_engine.mli | 194 + thirdparty/lwt-2.3.2/src/unix/lwt_gc.ml | 62 + thirdparty/lwt-2.3.2/src/unix/lwt_gc.mli | 36 + thirdparty/lwt-2.3.2/src/unix/lwt_io.ml | 1501 ++++ thirdparty/lwt-2.3.2/src/unix/lwt_io.mli | 522 ++ .../lwt-2.3.2/src/unix/lwt_libev_stubs.c | 211 + thirdparty/lwt-2.3.2/src/unix/lwt_log.ml | 559 ++ thirdparty/lwt-2.3.2/src/unix/lwt_log.mli | 316 + .../lwt-2.3.2/src/unix/lwt_log_rules.mli | 27 + .../lwt-2.3.2/src/unix/lwt_log_rules.mll | 49 + thirdparty/lwt-2.3.2/src/unix/lwt_main.ml | 74 + thirdparty/lwt-2.3.2/src/unix/lwt_main.mli | 61 + thirdparty/lwt-2.3.2/src/unix/lwt_process.ml | 328 + thirdparty/lwt-2.3.2/src/unix/lwt_process.mli | 296 + thirdparty/lwt-2.3.2/src/unix/lwt_sys.ml | 63 + thirdparty/lwt-2.3.2/src/unix/lwt_sys.mli | 55 + thirdparty/lwt-2.3.2/src/unix/lwt_throttle.ml | 133 + .../lwt-2.3.2/src/unix/lwt_throttle.mli | 47 + thirdparty/lwt-2.3.2/src/unix/lwt_timeout.ml | 127 + thirdparty/lwt-2.3.2/src/unix/lwt_timeout.mli | 47 + thirdparty/lwt-2.3.2/src/unix/lwt_unix.h | 218 + thirdparty/lwt-2.3.2/src/unix/lwt_unix.ml | 2681 +++++++ thirdparty/lwt-2.3.2/src/unix/lwt_unix.mli | 1131 +++ .../lwt-2.3.2/src/unix/lwt_unix_stubs.c | 1377 ++++ thirdparty/lwt-2.3.2/src/unix/lwt_unix_unix.c | 3864 ++++++++++ .../lwt-2.3.2/src/unix/lwt_unix_windows.c | 484 ++ thirdparty/lwt-2.3.2/syntax/META | 10 + .../lwt-2.3.2/syntax/lwt-syntax-log.mllib | 4 + .../lwt-2.3.2/syntax/lwt-syntax-options.mllib | 4 + thirdparty/lwt-2.3.2/syntax/lwt-syntax.mllib | 4 + thirdparty/lwt-2.3.2/syntax/optcomp.mllib | 4 + thirdparty/lwt-2.3.2/syntax/pa_lwt.ml | 236 + thirdparty/lwt-2.3.2/syntax/pa_lwt.mli | 175 + thirdparty/lwt-2.3.2/syntax/pa_lwt_log.ml | 127 + thirdparty/lwt-2.3.2/syntax/pa_lwt_log.mli | 47 + thirdparty/lwt-2.3.2/syntax/pa_lwt_options.ml | 31 + thirdparty/lwt-2.3.2/syntax/pa_optcomp.ml | 709 ++ thirdparty/lwt-2.3.2/tests/META | 9 + thirdparty/lwt-2.3.2/tests/core/main.ml | 27 + thirdparty/lwt-2.3.2/tests/core/test_lwt.ml | 552 ++ .../lwt-2.3.2/tests/core/test_lwt_stream.ml | 221 + .../lwt-2.3.2/tests/core/test_lwt_util.ml | 226 + thirdparty/lwt-2.3.2/tests/react/main.ml | 26 + .../lwt-2.3.2/tests/react/test_lwt_event.ml | 75 + .../lwt-2.3.2/tests/react/test_lwt_signal.ml | 27 + thirdparty/lwt-2.3.2/tests/test.ml | 78 + thirdparty/lwt-2.3.2/tests/test.mli | 40 + thirdparty/lwt-2.3.2/tests/test.mllib | 4 + thirdparty/lwt-2.3.2/tests/unix/main.ml | 26 + .../lwt-2.3.2/tests/unix/test_lwt_io.ml | 62 + .../tests/unix/test_lwt_io_non_block.ml | 66 + thirdparty/lwt-2.3.2/utils/ocamlinit | 38 + thirdparty/lwt-2.3.2/utils/style.css | 171 + thirdparty/lwt-2.3.2/utils/tuareg.patch | 377 + util.ml | 30 +- 169 files changed, 44917 insertions(+), 406 deletions(-) rename squeue.ml => squeue_linked.ml (100%) create mode 100644 thirdparty/lwt-2.3.2/CHANGES create mode 100644 thirdparty/lwt-2.3.2/CHANGES.darcs create mode 100644 thirdparty/lwt-2.3.2/COPYING create mode 100644 thirdparty/lwt-2.3.2/LICENSE create mode 100644 thirdparty/lwt-2.3.2/Makefile create mode 100644 thirdparty/lwt-2.3.2/README create mode 100644 thirdparty/lwt-2.3.2/_oasis create mode 100644 thirdparty/lwt-2.3.2/_tags create mode 100644 thirdparty/lwt-2.3.2/apiref-intro create mode 100755 thirdparty/lwt-2.3.2/configure create mode 100644 thirdparty/lwt-2.3.2/discover.ml create mode 100644 thirdparty/lwt-2.3.2/examples/gtk/Makefile create mode 100644 thirdparty/lwt-2.3.2/examples/gtk/connect.ml create mode 100644 thirdparty/lwt-2.3.2/examples/unix/logging.ml create mode 100644 thirdparty/lwt-2.3.2/examples/unix/parallelize.ml create mode 100644 thirdparty/lwt-2.3.2/examples/unix/relay.ml create mode 100644 thirdparty/lwt-2.3.2/lwt-api.odocl create mode 100644 thirdparty/lwt-2.3.2/manual/Makefile create mode 100644 thirdparty/lwt-2.3.2/manual/manual-wiki.tex create mode 100644 thirdparty/lwt-2.3.2/manual/manual.pdf create mode 100644 thirdparty/lwt-2.3.2/manual/manual.tex create mode 100644 thirdparty/lwt-2.3.2/manual/manual.wiki create mode 100644 thirdparty/lwt-2.3.2/manual/menu.wiki create mode 100644 thirdparty/lwt-2.3.2/myocamlbuild.ml create mode 100644 thirdparty/lwt-2.3.2/setup.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/META create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt.mli create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt.mllib create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_condition.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_condition.mli create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_list.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_list.mli create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_mutex.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_mutex.mli create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_mvar.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_mvar.mli create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_pool.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_pool.mli create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_pqueue.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_pqueue.mli create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_sequence.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_sequence.mli create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_stream.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_stream.mli create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_switch.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_switch.mli create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_util.ml create mode 100644 thirdparty/lwt-2.3.2/src/core/lwt_util.mli create mode 100644 thirdparty/lwt-2.3.2/src/extra/lwt-extra.mllib create mode 100644 thirdparty/lwt-2.3.2/src/extra/lwt_lib.ml create mode 100644 thirdparty/lwt-2.3.2/src/extra/lwt_lib.mli create mode 100644 thirdparty/lwt-2.3.2/src/glib/liblwt-glib.clib create mode 100644 thirdparty/lwt-2.3.2/src/glib/lwt-glib.mllib create mode 100644 thirdparty/lwt-2.3.2/src/glib/lwt_glib.ml create mode 100644 thirdparty/lwt-2.3.2/src/glib/lwt_glib.mli create mode 100644 thirdparty/lwt-2.3.2/src/glib/lwt_glib_stubs.c create mode 100644 thirdparty/lwt-2.3.2/src/preemptive/lwt-preemptive.mllib create mode 100644 thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.ml create mode 100644 thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.mli create mode 100644 thirdparty/lwt-2.3.2/src/react/lwt-react.mllib create mode 100644 thirdparty/lwt-2.3.2/src/react/lwt_event.ml create mode 100644 thirdparty/lwt-2.3.2/src/react/lwt_event.mli create mode 100644 thirdparty/lwt-2.3.2/src/react/lwt_react.ml create mode 100644 thirdparty/lwt-2.3.2/src/react/lwt_react.mli create mode 100644 thirdparty/lwt-2.3.2/src/react/lwt_signal.ml create mode 100644 thirdparty/lwt-2.3.2/src/react/lwt_signal.mli create mode 100644 thirdparty/lwt-2.3.2/src/simple_top/lwt-simple-top.mllib create mode 100644 thirdparty/lwt-2.3.2/src/simple_top/lwt_simple_top.ml create mode 100644 thirdparty/lwt-2.3.2/src/ssl/lwt-ssl.mllib create mode 100644 thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.ml create mode 100644 thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.mli create mode 100644 thirdparty/lwt-2.3.2/src/text/liblwt-text.clib create mode 100644 thirdparty/lwt-2.3.2/src/text/lwt-text.mllib create mode 100644 thirdparty/lwt-2.3.2/src/text/lwt_read_line.ml create mode 100644 thirdparty/lwt-2.3.2/src/text/lwt_read_line.mli create mode 100644 thirdparty/lwt-2.3.2/src/text/lwt_term.ml create mode 100644 thirdparty/lwt-2.3.2/src/text/lwt_term.mli create mode 100644 thirdparty/lwt-2.3.2/src/text/lwt_text.ml create mode 100644 thirdparty/lwt-2.3.2/src/text/lwt_text.mli create mode 100644 thirdparty/lwt-2.3.2/src/text/lwt_text_stubs.c create mode 100644 thirdparty/lwt-2.3.2/src/top/lwt-top.mllib create mode 100644 thirdparty/lwt-2.3.2/src/top/lwt_ocaml_completion.mll create mode 100644 thirdparty/lwt-2.3.2/src/top/lwt_top.ml create mode 100644 thirdparty/lwt-2.3.2/src/top/lwt_top.mli create mode 100644 thirdparty/lwt-2.3.2/src/top/toplevel.ml create mode 100644 thirdparty/lwt-2.3.2/src/top/toplevel_temp.mltop create mode 100644 thirdparty/lwt-2.3.2/src/unix/liblwt-unix.clib create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt-unix.mllib create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_bytes.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_bytes.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_chan.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_chan.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_daemon.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_daemon.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_engine.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_engine.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_gc.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_gc.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_io.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_io.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_libev_stubs.c create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_log.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_log.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mll create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_main.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_main.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_process.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_process.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_sys.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_sys.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_throttle.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_throttle.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_timeout.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_timeout.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_unix.h create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_unix.ml create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_unix.mli create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_unix_stubs.c create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_unix_unix.c create mode 100644 thirdparty/lwt-2.3.2/src/unix/lwt_unix_windows.c create mode 100644 thirdparty/lwt-2.3.2/syntax/META create mode 100644 thirdparty/lwt-2.3.2/syntax/lwt-syntax-log.mllib create mode 100644 thirdparty/lwt-2.3.2/syntax/lwt-syntax-options.mllib create mode 100644 thirdparty/lwt-2.3.2/syntax/lwt-syntax.mllib create mode 100644 thirdparty/lwt-2.3.2/syntax/optcomp.mllib create mode 100644 thirdparty/lwt-2.3.2/syntax/pa_lwt.ml create mode 100644 thirdparty/lwt-2.3.2/syntax/pa_lwt.mli create mode 100644 thirdparty/lwt-2.3.2/syntax/pa_lwt_log.ml create mode 100644 thirdparty/lwt-2.3.2/syntax/pa_lwt_log.mli create mode 100644 thirdparty/lwt-2.3.2/syntax/pa_lwt_options.ml create mode 100644 thirdparty/lwt-2.3.2/syntax/pa_optcomp.ml create mode 100644 thirdparty/lwt-2.3.2/tests/META create mode 100644 thirdparty/lwt-2.3.2/tests/core/main.ml create mode 100644 thirdparty/lwt-2.3.2/tests/core/test_lwt.ml create mode 100644 thirdparty/lwt-2.3.2/tests/core/test_lwt_stream.ml create mode 100644 thirdparty/lwt-2.3.2/tests/core/test_lwt_util.ml create mode 100644 thirdparty/lwt-2.3.2/tests/react/main.ml create mode 100644 thirdparty/lwt-2.3.2/tests/react/test_lwt_event.ml create mode 100644 thirdparty/lwt-2.3.2/tests/react/test_lwt_signal.ml create mode 100644 thirdparty/lwt-2.3.2/tests/test.ml create mode 100644 thirdparty/lwt-2.3.2/tests/test.mli create mode 100644 thirdparty/lwt-2.3.2/tests/test.mllib create mode 100644 thirdparty/lwt-2.3.2/tests/unix/main.ml create mode 100644 thirdparty/lwt-2.3.2/tests/unix/test_lwt_io.ml create mode 100644 thirdparty/lwt-2.3.2/tests/unix/test_lwt_io_non_block.ml create mode 100644 thirdparty/lwt-2.3.2/utils/ocamlinit create mode 100644 thirdparty/lwt-2.3.2/utils/style.css create mode 100644 thirdparty/lwt-2.3.2/utils/tuareg.patch diff --git a/.gitignore b/.gitignore index d4fe983..2d8bc85 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,9 @@ _build/ *.native message.ml amqp_spec.ml + +thirdparty/_dist +thirdparty/lwt-2.3.2/setup.data +thirdparty/lwt-2.3.2/setup.log +thirdparty/lwt-2.3.2/src/unix/lwt_config.h +thirdparty/lwt-2.3.2/src/unix/lwt_config.ml diff --git a/Makefile b/Makefile index fa16799..3dcc5b3 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,28 @@ APP=hop_server TEMPLATES=$(wildcard web/bootstrap/templates/*.xml) HTML=$(subst web/bootstrap/templates/,web/,$(subst .xml,.html,$(TEMPLATES))) -all: message.ml amqp_spec.ml $(APP).native web/bootstrap/css/bootstrap.css webpages +# Augment the path ocamlfind uses to discover installed packages. +OCAMLPATH=$(CURDIR)/thirdparty/_dist +export OCAMLPATH + +LWT_SRC_DIR=thirdparty/lwt-2.3.2 + +all: \ + thirdparty/_dist \ + message.ml amqp_spec.ml \ + $(APP).native \ + web/bootstrap/css/bootstrap.css \ + webpages + +thirdparty/_dist: + mkdir -p $@ + (mkdir $@/lwt && \ + (cd $(LWT_SRC_DIR) && \ + ./configure --disable-libev && \ + make && \ + OCAMLFIND_LDCONF=ignore \ + OCAMLFIND_DESTDIR="$(CURDIR)/$@" \ + make install)) webpages: $(HTML) @@ -26,11 +47,19 @@ clean: webclean rm -f message.ml rm -f amqp_spec.ml -veryclean: clean +thirdpartyclean: + rm -rf thirdparty/_dist + rm -rf $(LWT_SRC_DIR)/_build + rm -f $(LWT_SRC_DIR)/setup.data + rm -f $(LWT_SRC_DIR)/setup.log + rm -f $(LWT_SRC_DIR)/src/unix/lwt_config.h + rm -f $(LWT_SRC_DIR)/src/unix/lwt_config.ml + +veryclean: clean thirdpartyclean rm -f web/bootstrap/css/bootstrap.css $(APP).native: $(wildcard *.ml) - ocamlbuild $@ + ocamlbuild -use-ocamlfind -X thirdparty $@ run: all ./$(APP).native diff --git a/_tags b/_tags index f7a5408..129d262 100644 --- a/_tags +++ b/_tags @@ -1,3 +1,4 @@ -true: use_unix +true: package(lwt.unix) +true: package(lwt.syntax) +true: syntax(camlp4o) true: use_str -true: thread diff --git a/connections.ml b/connections.ml index 78773e6..a20d089 100644 --- a/connections.ml +++ b/connections.ml @@ -15,12 +15,11 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Unix open Printf -open Thread open Sexp -let connection_mtx = Mutex.create () let connection_count = ref 0 let endpoint_name n = @@ -28,49 +27,53 @@ let endpoint_name n = | ADDR_INET (host, port) -> sprintf "%s:%d" (string_of_inet_addr host) port | _ -> "??unknown??" -let flush_output mtx flush_control cout = - let rec loop () = - match Event.poll (Event.receive flush_control) with - | Some () -> () - | None -> - let ok = Util.with_mutex0 mtx (fun () -> try flush cout; true with _ -> false) in - if ok then (Thread.delay 0.1; loop ()) else () - in loop () +let flush_output flush_control cout = + let keep_running = ref true in + Lwt.pick [ + Lwt_stream.next flush_control; + while_lwt !keep_running do + try_lwt + lwt () = Lwt_io.flush cout in + Lwt_unix.sleep 0.1 + with _ -> + keep_running := false; + return () + done + ] let connection_main class_name peername cin cout issue_banner boot_fn node_fn mainloop = - Log.info ("Accepted "^class_name) [Str (endpoint_name peername)]; - if issue_banner cin cout - then - let mtx = Mutex.create () in - let flush_control = Event.new_channel () in - ignore (Util.create_thread (endpoint_name peername ^ " flush") None - (flush_output mtx flush_control) cout); - let shared_state = boot_fn (peername, mtx, cin, cout) in - let n = Node.make class_name (node_fn shared_state) in - (try - mainloop shared_state n - with - | End_of_file -> - Log.info ("Disconnecting "^class_name^" normally") [Str (endpoint_name peername)] - | Sys_error message -> - Log.warn ("Disconnected "^class_name^" by Sys_error") - [Str (endpoint_name peername); Str message] - | exn -> - Log.error ("Uncaught exception in "^class_name) [Str (Printexc.to_string exn)] - ); - Node.unbind_all n; - Event.sync (Event.send flush_control ()) - else - Log.error ("Disconnected "^class_name^" by failed initial handshake") [] + ignore (Log.info ("Accepted "^class_name) [Str (endpoint_name peername)]); + match_lwt issue_banner cin cout with + | true -> + let (flush_control, flush_stop) = Lwt_stream.create () in + ignore (flush_output flush_control cout); + lwt shared_state = boot_fn (peername, cin, cout) in + let n = Node.make class_name (node_fn shared_state) in + lwt () = + (try_lwt + mainloop shared_state n + with + | End_of_file -> + Log.info ("Disconnecting "^class_name^" normally") [Str (endpoint_name peername)] + | Sys_error message -> + Log.warn ("Disconnected "^class_name^" by Sys_error") + [Str (endpoint_name peername); Str message] + | exn -> + Log.error ("Uncaught exception in "^class_name) [Str (Printexc.to_string exn)]) + in + flush_stop None; + Node.unbind_all n + | false -> + Log.error ("Disconnected "^class_name^" by failed initial handshake") [] let start_connection' class_name issue_banner boot_fn node_fn mainloop (s, peername) = - let cin = in_channel_of_descr s in - let cout = out_channel_of_descr s in - Util.with_mutex0 connection_mtx (fun () -> connection_count := !connection_count + 1); - connection_main class_name peername cin cout issue_banner boot_fn node_fn mainloop; - Util.with_mutex0 connection_mtx (fun () -> connection_count := !connection_count - 1); - (try flush cout with _ -> ()); - close s + let cin = Lwt_io.of_fd Lwt_io.input s in + let cout = Lwt_io.of_fd Lwt_io.output s in + connection_count := !connection_count + 1; + lwt () = connection_main class_name peername cin cout issue_banner boot_fn node_fn mainloop in + connection_count := !connection_count - 1; + lwt () = (try_lwt Lwt_io.flush cout with _ -> return ()) in + Lwt_unix.close s let start_connection class_name issue_banner boot_fn node_fn mainloop (s, peername) = Util.create_thread diff --git a/directnode.ml b/directnode.ml index d34f514..6594f0c 100644 --- a/directnode.ml +++ b/directnode.ml @@ -15,6 +15,7 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Sexp open Datastructures open Status @@ -22,72 +23,69 @@ open Status type t = { name: Node.name; subscriptions: Subscription.set_t; - mtx: Mutex.t; mutable routing_table: UuidSet.t StringMap.t; } let classname = "direct" let unsubscribe info uuid = - Util.with_mutex0 info.mtx - (fun () -> - match Subscription.delete info.name info.subscriptions uuid with - | Some sub -> - (match sub.Subscription.filter with - | Str binding_key -> - (try - let old_set = StringMap.find binding_key info.routing_table in - let new_set = UuidSet.remove sub.Subscription.uuid old_set in - if UuidSet.is_empty new_set - then info.routing_table <- StringMap.remove binding_key info.routing_table - else info.routing_table <- StringMap.add binding_key new_set info.routing_table - with Not_found -> - ()) - | _ -> ()) - | None -> ()) + match_lwt Subscription.delete info.name info.subscriptions uuid with + | Some sub -> + (match sub.Subscription.filter with + | Str binding_key -> + (try + let old_set = StringMap.find binding_key info.routing_table in + let new_set = UuidSet.remove sub.Subscription.uuid old_set in + if UuidSet.is_empty new_set + then info.routing_table <- StringMap.remove binding_key info.routing_table + else info.routing_table <- StringMap.add binding_key new_set info.routing_table + with Not_found -> + ()); + return () + | _ -> return ()) + | None -> return () let route_message info n sexp = match Message.message_of_sexp sexp with - | Message.Post (Str name, body, token) -> + | Message.Post (Str name, body, token) -> let routing_snapshot = info.routing_table in let matching = (try StringMap.find name routing_snapshot with Not_found -> UuidSet.empty) in - UuidSet.iter + Lwt_list.iter_s (fun (uuid) -> match Subscription.lookup info.subscriptions uuid with - | Some sub -> - ignore (Subscription.send_to_subscription' sub body (unsubscribe info)) - | None -> - ()) - matching - | Message.Subscribe (Str binding_key as filter, Str sink, name, Str reply_sink, reply_name) -> - Util.with_mutex0 info.mtx - (fun () -> - let sub = - Subscription.create - info.name info.subscriptions filter sink name reply_sink reply_name in - let old_set = - (try StringMap.find binding_key info.routing_table with Not_found -> UuidSet.empty) in - let new_set = UuidSet.add sub.Subscription.uuid old_set in - info.routing_table <- StringMap.add binding_key new_set info.routing_table) - | Message.Unsubscribe (Str token) -> + | Some sub -> + lwt _ = Subscription.send_to_subscription' sub body (unsubscribe info) in + return () + | None -> + return ()) + (UuidSet.elements matching) + | Message.Subscribe (Str binding_key as filter, Str sink, name, Str reply_sink, reply_name) -> + lwt sub = + Subscription.create + info.name info.subscriptions filter sink name reply_sink reply_name in + let old_set = + (try StringMap.find binding_key info.routing_table with Not_found -> UuidSet.empty) in + let new_set = UuidSet.add sub.Subscription.uuid old_set in + info.routing_table <- StringMap.add binding_key new_set info.routing_table; + return () + | Message.Unsubscribe (Str token) -> unsubscribe info token - | m -> + | m -> Util.message_not_understood classname m let factory arg = match arg with - | (Arr [Str name_str]) -> + | (Arr [Str name_str]) -> let info = { name = Node.name_of_string name_str; subscriptions = Subscription.new_set (); - mtx = Mutex.create (); routing_table = StringMap.empty; } in replace_ok (Node.make_idempotent_named classname info.name (route_message info)) (Str name_str) - | _ -> - Problem (Str "bad-arg") + | _ -> + return (Problem (Str "bad-arg")) let init () = Factory.register_class classname factory diff --git a/factory.ml b/factory.ml index 5afbd33..133f78c 100644 --- a/factory.ml +++ b/factory.ml @@ -15,23 +15,23 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Printf open Sexp open Datastructures -type factory_t = Sexp.t -> (Sexp.t, Sexp.t) Status.t +type factory_t = Sexp.t -> (Sexp.t, Sexp.t) Status.t Lwt.t -let mutex = Mutex.create () let classes = ref StringMap.empty let register_class name factory = - Util.with_mutex0 mutex - (fun () -> - if StringMap.mem name !classes - then (Log.error "Duplicate node class name" [Str name]; - exit 1) - else (Log.info "Registered node class" [Str name]; - classes := StringMap.add name factory !classes)) + if StringMap.mem name !classes + then (ignore (Log.error "Duplicate node class name" [Str name]); + Server_control.shutdown_now [Str "Duplicate node class name"; Str name]; + Lwt_unix.yield ()) + else (ignore (Log.info "Registered node class" [Str name]); + classes := StringMap.add name factory !classes; + return ()) let all_class_names () = Datastructures.string_map_keys !classes @@ -43,21 +43,21 @@ let lookup_class name = let factory_handler n sexp = match Message.message_of_sexp sexp with | Message.Create (Str classname, arg, Str reply_sink, Str reply_name) -> - let reply = + lwt reply = match lookup_class classname with - | Some factory -> - (match factory arg with - | Status.Ok info -> - Log.info "Node create ok" - [Str classname; arg; Str reply_sink; Str reply_name; info]; - Message.create_ok info - | Status.Problem explanation -> - Log.info "Node create failed" - [Str classname; arg; Str reply_sink; Str reply_name; explanation]; - Message.create_failed (Arr [Str "constructor"; explanation])) - | None -> - Log.warn "Node class not found" [Str classname]; - Message.create_failed (Arr [Str "factory"; Str "class-not-found"]) + | Some factory -> + (match_lwt factory arg with + | Status.Ok info -> + ignore (Log.info "Node create ok" + [Str classname; arg; Str reply_sink; Str reply_name; info]); + return (Message.create_ok info) + | Status.Problem explanation -> + ignore (Log.info "Node create failed" + [Str classname; arg; Str reply_sink; Str reply_name; explanation]); + return (Message.create_failed (Arr [Str "constructor"; explanation]))) + | None -> + ignore (Log.warn "Node class not found" [Str classname]); + return (Message.create_failed (Arr [Str "factory"; Str "class-not-found"])) in Node.post_ignore' reply_sink (Str reply_name) reply (Str "") | m -> diff --git a/fanoutnode.ml b/fanoutnode.ml index b25abdd..f788b3e 100644 --- a/fanoutnode.ml +++ b/fanoutnode.ml @@ -15,6 +15,7 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Sexp open Datastructures open Status @@ -22,46 +23,42 @@ open Status type t = { name: Node.name; subscriptions: Subscription.set_t; - mtx: Mutex.t; } let classname = "fanout" let unsubscribe info uuid = - Util.with_mutex0 info.mtx - (fun () -> ignore (Subscription.delete info.name info.subscriptions uuid)) + lwt _ = Subscription.delete info.name info.subscriptions uuid in return () let route_message info n sexp = match Message.message_of_sexp sexp with - | Message.Post (Str name, body, token) -> + | Message.Post (Str name, body, token) -> let snapshot = !(info.subscriptions) in - StringMap.iter - (fun uuid sub -> - ignore (Subscription.send_to_subscription' sub body (unsubscribe info))) - snapshot - | Message.Subscribe (Str binding_key as filter, Str sink, name, Str reply_sink, reply_name) -> - Util.with_mutex0 info.mtx - (fun () -> - ignore (Subscription.create - info.name info.subscriptions filter sink name reply_sink reply_name)) - | Message.Unsubscribe (Str token) -> + Lwt_list.iter_s + (fun (uuid, sub) -> + lwt _ = Subscription.send_to_subscription' sub body (unsubscribe info) in return ()) + (StringMap.bindings snapshot) + | Message.Subscribe (Str binding_key as filter, Str sink, name, Str reply_sink, reply_name) -> + lwt _ = (Subscription.create + info.name info.subscriptions filter sink name reply_sink reply_name) in + return () + | Message.Unsubscribe (Str token) -> unsubscribe info token - | m -> + | m -> Util.message_not_understood classname m let factory arg = match arg with - | (Arr [Str name_str]) -> + | (Arr [Str name_str]) -> let info = { name = Node.name_of_string name_str; - subscriptions = Subscription.new_set (); - mtx = Mutex.create (); + subscriptions = Subscription.new_set () } in replace_ok (Node.make_idempotent_named classname info.name (route_message info)) (Str name_str) - | _ -> - Problem (Str "bad-arg") + | _ -> + return (Problem (Str "bad-arg")) let init () = Factory.register_class classname factory diff --git a/hop_server.ml b/hop_server.ml index 7a50779..298cd59 100644 --- a/hop_server.ml +++ b/hop_server.ml @@ -15,6 +15,8 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt + let n_system_log = Node.name_of_string "system.log" let hook_log () = @@ -27,33 +29,33 @@ let hook_log () = let create_ready_file () = match Config.get "ready-file" with - | Some ready_file_path -> - Log.info "Creating ready file" [Sexp.Str ready_file_path]; - close_out (open_out ready_file_path) - | None -> - () + | Some ready_file_path -> + ignore (Log.info "Creating ready file" [Sexp.Str ready_file_path]); + return (close_out (open_out ready_file_path)) + | None -> + return () -let _ = +lwt _ = Printf.printf "%s %s, %s\n%s\n%!" App_info.product App_info.version App_info.copyright App_info.licence_blurb; Sys.set_signal Sys.sigpipe Sys.Signal_ignore; Uuid.init (); Config.init (); - Factory.init (); - Queuenode.init (); - Fanoutnode.init (); - Directnode.init (); - Meta.init (); + lwt () = Factory.init () in + lwt () = Queuenode.init () in + lwt () = Fanoutnode.init () in + lwt () = Directnode.init () in + lwt () = Meta.init () in hook_log (); - Amqp_relay.init (); - Ui_main.init (); - Ui_relay.init (); + (* Amqp_relay.init (); + Ui_main.init (); + Ui_relay.init (); *) Relay.init (); - Server_control.run_until "AMQP ready"; - Server_control.run_until "HTTP ready"; - Server_control.run_until "Hop ready"; + (* Server_control.run_until "AMQP ready"; + Server_control.run_until "HTTP ready"; *) + lwt () = Server_control.run_until "Hop ready" in if Server_control.is_running () - then (create_ready_file (); + then (lwt () = create_ready_file () in Server_control.milestone "Server initialized"; Server_control.run_forever ()) - else () + else return () diff --git a/log.ml b/log.ml index ee38313..b9285ab 100644 --- a/log.ml +++ b/log.ml @@ -15,18 +15,16 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Sexp -let mtx = Mutex.create () let write_to_log label body = - Mutex.lock mtx; - (try - print_string label; - print_string ": "; - output_sexp_human stdout body; - print_newline () - with _ -> ()); - Mutex.unlock mtx + try_lwt + lwt () = Lwt_io.print label in + lwt () = Lwt_io.print ": " in + lwt () = output_sexp_human Lwt_io.stdout body in + Lwt_io.printl "" + with _ -> return () let hook = ref write_to_log diff --git a/net.ml b/net.ml index ba42d40..f7b86ae 100644 --- a/net.ml +++ b/net.ml @@ -15,19 +15,20 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) -open Unix +open Lwt_unix let rec accept_loop sock connection_start_fn = - let (s, peername) = accept sock in - setsockopt s TCP_NODELAY true; + lwt (s, peername) = accept sock in + setsockopt s Unix.TCP_NODELAY true; ignore (connection_start_fn (s, peername)); accept_loop sock connection_start_fn let start_net protocol_name port_number connection_start_fn = - let sock = socket PF_INET SOCK_STREAM 0 in - setsockopt sock SO_REUSEADDR true; - bind sock (ADDR_INET (inet_addr_of_string "0.0.0.0", port_number)); + let sock = socket Unix.PF_INET Unix.SOCK_STREAM 0 in + setsockopt sock Unix.SO_REUSEADDR true; + bind sock (Unix.ADDR_INET (Unix.inet_addr_any, port_number)); listen sock 5; Server_control.milestone (protocol_name ^ " ready"); - Log.info "Accepting connections" [Sexp.Str protocol_name; Sexp.Str (string_of_int port_number)]; + ignore (Log.info "Accepting connections" + [Sexp.Str protocol_name; Sexp.Str (string_of_int port_number)]); accept_loop sock connection_start_fn diff --git a/node.ml b/node.ml index e62f7b5..d1f0de9 100644 --- a/node.ml +++ b/node.ml @@ -15,11 +15,12 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Printf open Datastructures open Status -type handle_message_t = t -> Sexp.t -> unit +type handle_message_t = t -> Sexp.t -> unit Lwt.t and t = { mutable names: StringSet.t; class_name: string; @@ -40,14 +41,12 @@ module NameSet = Set.Make(struct let compare a b = String.compare a.label b.label end) -let mutex = Mutex.create () let name_table = NameTable.create 100 let directory = ref NameSet.empty let name_of_string str = - Util.with_mutex0 mutex (fun () -> - let template = {label = str; binding = None} in - NameTable.merge name_table template) + let template = {label = str; binding = None} in + NameTable.merge name_table template let local_container_name () = "server" @@ -70,57 +69,66 @@ let approx_exists name = let bind (filter, node) = if filter.label = "" - then (Log.warn "Binding to empty name forbidden" []; false) + then (ignore (Log.warn "Binding to empty name forbidden" []); return false) else - Util.with_mutex0 mutex (fun () -> - filter.binding <- Some node; - directory := NameSet.add filter !directory; - node.names <- StringSet.add filter.label node.names; - Log.info "Node bound" [Sexp.Str filter.label; Sexp.Str node.class_name]; - true) + (filter.binding <- Some node; + directory := NameSet.add filter !directory; + node.names <- StringSet.add filter.label node.names; + ignore (Log.info "Node bound" [Sexp.Str filter.label; Sexp.Str node.class_name]); + return true) (* For use in factory constructor functions, hence the odd return type and values *) let make_named class_name node_name handler = let node = make class_name handler in - if bind (node_name, node) then Ok node else Problem (Sexp.Str "bind-failed") + match_lwt bind (node_name, node) with + | true -> return (Ok node) + | false -> return (Problem (Sexp.Str "bind-failed")) (* For use in factory constructor functions, hence the odd return type and values *) let make_idempotent_named class_name node_name handler = match lookup node_name with | Some n -> - if n.class_name = class_name + return (if n.class_name = class_name then Ok n - else Problem (Sexp.Str "class-mismatch") + else Problem (Sexp.Str "class-mismatch")) | None -> let node = make class_name handler in - if bind (node_name, node) then Ok node else Problem (Sexp.Str "bind-failed") + match_lwt bind (node_name, node) with + | true -> return (Ok node) + | false -> return (Problem (Sexp.Str "bind-failed")) let unbind name = - Util.with_mutex0 mutex (fun () -> - match lookup name with + match lookup name with | Some n -> - Log.info "Node unbound" [Sexp.Str name.label; Sexp.Str n.class_name]; - n.names <- StringSet.remove name.label n.names; - name.binding <- None; - directory := NameSet.remove name !directory; - true + ignore (Log.info "Node unbound" [Sexp.Str name.label; Sexp.Str n.class_name]); + n.names <- StringSet.remove name.label n.names; + name.binding <- None; + directory := NameSet.remove name !directory; + return true | None -> - false) + return false let unbind_all n = - StringSet.iter (fun name -> ignore (unbind (name_of_string name))) n.names; - n.names <- StringSet.empty + lwt () = + Lwt_list.iter_s + (fun name -> lwt _ = unbind (name_of_string name) in return ()) + (StringSet.elements n.names) + in + n.names <- StringSet.empty; + return () let send name body = match lookup name with - | Some n -> - (try n.handle_message n body - with e -> - Log.warn "Node message handler raised exception" - [Sexp.Str name.label; - Sexp.Str (Printexc.to_string e)]); - true - | None -> false + | Some n -> + ignore + (try_lwt n.handle_message n body + with e -> + Log.warn "Node message handler raised exception" + [Sexp.Str name.label; + Sexp.Str (Printexc.to_string e)]); + return true + | None -> + return false let send' str body = send (name_of_string str) body @@ -130,14 +138,17 @@ let post name label body token = let post' str label body token = post (name_of_string str) label body token let bind_ignore (filter, node) = - if bind (filter, node) - then () - else Log.warn "Duplicate binding" [Sexp.Str filter.label] + match_lwt bind (filter, node) with + | true -> return () + | false -> Log.warn "Duplicate binding" [Sexp.Str filter.label] let send_ignore name body = - if send name body || name.label = "" - then () - else Log.warn "send to missing node" [Sexp.Str name.label; body] + match_lwt send name body with + | true -> return () + | false -> + if name.label = "" + then return () + else Log.warn "send to missing node" [Sexp.Str name.label; body] let send_ignore' str body = send_ignore (name_of_string str) body diff --git a/queuenode.ml b/queuenode.ml index 6206892..4ea7f14 100644 --- a/queuenode.ml +++ b/queuenode.ml @@ -15,87 +15,87 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Sexp open Status +(* TODO: on unsubscribe, wake up the shoveller to make it clean out its waiters queue *) + type t = { - name: Node.name; - subscriptions: Subscription.set_t; - ch: Message.t Squeue.t; - mutable backlog: Sexp.t Queue.t; - mutable waiters: Subscription.t Queue.t; - } + name: Node.name; + subscriptions: Subscription.set_t; + backlog_in: Sexp.t Lwt_stream.t; + backlog_out: Sexp.t option -> unit; + waiters_in: Subscription.t Lwt_stream.t; + waiters_out: Subscription.t option -> unit; + mutable backlog: int; + mutable waiters: int; +} let classname = "queue" let report info n = - Log.info (Printf.sprintf "do_burst %d capacity, %d backlog, %d waiters, %d ticks left\n%!" - (Squeue.approx_capacity info.ch) - (Queue.length info.backlog) - (Queue.length info.waiters) + Log.info (Printf.sprintf "do_burst %d backlog, %d waiters, %d ticks left\n%!" + info.backlog + info.waiters n) [] -let rec do_burst info n = - (* report info n; *) - if Queue.is_empty info.backlog then false - else - if Queue.is_empty info.waiters then false - else - if n = 0 then true (* maybe more work available, but should poll for outside events *) - else - let body = Queue.peek info.backlog in - let sub = Queue.pop info.waiters in - if Subscription.send_to_subscription info.name info.subscriptions sub body - then - (Queue.push sub info.waiters; - ignore (Queue.pop info.backlog); - do_burst info (n - 1)) - else - do_burst info n - -let rec process_and_wait info = - if not (do_burst info 1000) - then Squeue.pop info.ch - else - match Squeue.peek info.ch with - | Some m -> m - | None -> process_and_wait info - let shoveller info = - let rec loop () = - match process_and_wait info with + let rec message_loop () = + lwt body = Lwt_stream.next info.backlog_in in + let rec waiter_loop () = + lwt sub = Lwt_stream.next info.waiters_in in + match_lwt Subscription.send_to_subscription info.name info.subscriptions sub body with + | true -> + info.backlog <- info.backlog - 1; + info.waiters_out (Some sub); + message_loop () + | false -> + waiter_loop () + in waiter_loop () + in message_loop () + +let queue_handler info n sexp = + match Message.message_of_sexp sexp with | Message.Post (name, body, token) -> - Queue.push body info.backlog; - loop () + info.backlog <- info.backlog + 1; + info.backlog_out (Some body); + return () | Message.Subscribe (filter, Str sink, name, Str reply_sink, reply_name) -> - let sub = - Subscription.create - info.name info.subscriptions filter sink name reply_sink reply_name in - Queue.push sub info.waiters; - loop () + lwt sub = + Subscription.create + info.name info.subscriptions filter sink name reply_sink reply_name in + info.waiters <- info.waiters + 1; + info.waiters_out (Some sub); + return () | Message.Unsubscribe (Str token) -> - ignore (Subscription.delete info.name info.subscriptions token); - loop () + ignore (Subscription.delete info.name info.subscriptions token); + info.waiters <- info.waiters - 1; + return () | m -> - Util.message_not_understood "queue" m; - loop () - in loop () + Util.message_not_understood "queue" m let queue_factory arg = match arg with - | (Arr [Str name_str]) -> + | (Arr [Str name_str]) -> + let (bin, bout) = Lwt_stream.create () in + let (win, wout) = Lwt_stream.create () in let info = { name = Node.name_of_string name_str; subscriptions = Subscription.new_set (); - ch = Squeue.create 1000; - backlog = Queue.create (); - waiters = Queue.create () + backlog_in = bin; + backlog_out = bout; + waiters_in = win; + waiters_out = wout; + backlog = 0; + waiters = 0 } in ignore (Util.create_thread name_str None shoveller info); - let queue_handler n sexp = Squeue.add (Message.message_of_sexp sexp) info.ch in - replace_ok (Node.make_idempotent_named classname info.name queue_handler) (Str name_str) - | _ -> - Problem (Str "bad-arg") + replace_ok + (Node.make_idempotent_named classname info.name (queue_handler info)) + (Str name_str) + | _ -> + return (Problem (Str "bad-arg")) let init () = Factory.register_class classname queue_factory diff --git a/relay.ml b/relay.ml index 4e87d9c..339d82e 100644 --- a/relay.ml +++ b/relay.ml @@ -15,14 +15,14 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Unix open Printf -open Thread open Sexp let send_error ch message details = let m = Message.error (Str message, details) in - Log.warn "Sending error" [m]; + ignore (Log.warn "Sending error" [m]); ch m let send_sexp_syntax_error ch explanation = @@ -30,48 +30,51 @@ let send_sexp_syntax_error ch explanation = let dispatch_message n ch m = match m with - | Message.Post (Str name, body, token) -> + | Message.Post (Str name, body, token) -> Node.send_ignore' name body - | Message.Subscribe (Str filter, sink, name, Str reply_sink, Str reply_name) -> - if Node.bind (Node.name_of_string filter, n) - then Node.post_ignore' - reply_sink - (Str reply_name) - (Message.subscribe_ok (Str filter)) - (Str "") - else Log.warn "Bind failed" [Str filter] - | Message.Unsubscribe (Str token) -> - if Node.unbind (Node.name_of_string token) - then () - else Log.warn "Unbind failed" [Str token] - | _ -> + | Message.Subscribe (Str filter, sink, name, Str reply_sink, Str reply_name) -> + (match_lwt Node.bind (Node.name_of_string filter, n) with + | true -> + Node.post_ignore' + reply_sink + (Str reply_name) + (Message.subscribe_ok (Str filter)) + (Str "") + | false -> + Log.warn "Bind failed" [Str filter]) + | Message.Unsubscribe (Str token) -> + (match_lwt Node.unbind (Node.name_of_string token) with + | true -> return () + | false -> Log.warn "Unbind failed" [Str token]) + | _ -> send_error ch "Message not understood" (Message.sexp_of_message m) let issue_banner cin cout = - output_sexp_and_flush cout (Arr [Str "hop"; Str ""]); - output_sexp_and_flush cout - (Message.subscribe (Str (Node.local_container_name()), - Str "", Str "", - Str "", Str "")); - true + lwt () = output_sexp_and_flush cout (Arr [Str "hop"; Str ""]) in + lwt () = + output_sexp_and_flush cout + (Message.subscribe (Str (Node.local_container_name()), + Str "", Str "", + Str "", Str "")) in + return true -let relay_boot (peername, mtx, cin, cout) = (peername, mtx, cin, cout) +let relay_boot (peername, cin, cout) = return (peername, Lwt_mutex.create (), cin, cout) let relay_handler (_, mtx, _, cout) _ m = - Util.with_mutex mtx (output_sexp_and_flush cout) m + Lwt_mutex.with_lock mtx (fun () -> output_sexp_and_flush cout m) let relay_mainloop (peername, mtx, cin, cout) n = - let write_sexp = Util.with_mutex mtx (output_sexp cout) in - (try - while true do - dispatch_message n write_sexp (Message.message_of_sexp (Sexp.input_sexp cin)) - done - with - | Sexp.Syntax_error explanation -> - (send_sexp_syntax_error write_sexp explanation; + let write_sexp sexp = Lwt_mutex.with_lock mtx (fun () -> output_sexp cout sexp) in + (try_lwt + while_lwt true do + lwt message_sexp = Sexp.input_sexp cin in + dispatch_message n write_sexp (Message.message_of_sexp message_sexp) + done + with + | Sexp.Syntax_error explanation -> + lwt () = send_sexp_syntax_error write_sexp explanation in Log.info "Disconnected relay for syntax error" [Str (Connections.endpoint_name peername); Str explanation]) - ) let start (s, peername) = Connections.start_connection "relay" issue_banner diff --git a/server_control.ml b/server_control.ml index ec2aca7..3ebb3b5 100644 --- a/server_control.ml +++ b/server_control.ml @@ -15,18 +15,17 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Datastructures let continue_running = ref true -let control_queue = Squeue.create 1 +let (cq_in, cq_out) = Lwt_stream.create () let achieved_milestones = ref StringSet.empty -let milestone name = - Squeue.add (`Milestone name) control_queue +let milestone name = cq_out (Some (`Milestone name)) -let shutdown_now details = - Squeue.add (`Shutdown details) control_queue +let shutdown_now details = cq_out (Some (`Shutdown details)) let is_milestone_achieved m = match m with @@ -37,16 +36,16 @@ let is_milestone_achieved m = let rec run' until_milestone = match is_milestone_achieved until_milestone with - | true -> - () - | false -> - (match Squeue.pop control_queue with - | `Shutdown details -> - Log.error "Shutting down server" details; + | true -> + return () + | false -> + (match_lwt Lwt_stream.next cq_in with + | `Shutdown details -> + ignore (Log.error "Shutting down server" details); continue_running := false; - () - | `Milestone name -> - Log.info "Achieved milestone" [Sexp.Str name]; + return () + | `Milestone name -> + ignore (Log.info "Achieved milestone" [Sexp.Str name]); achieved_milestones := StringSet.add name !achieved_milestones; run' until_milestone) @@ -54,11 +53,11 @@ let is_running () = !continue_running let run_until milestone = if !continue_running - then (Log.info "Waiting for milestone" [Sexp.Str milestone]; + then (ignore (Log.info "Waiting for milestone" [Sexp.Str milestone]); run' (Some milestone)) - else () + else return () let run_forever () = if !continue_running then run' None - else () + else return () diff --git a/sexp.ml b/sexp.ml index 9eb2179..039b588 100644 --- a/sexp.ml +++ b/sexp.ml @@ -17,6 +17,9 @@ (* SPKI SEXP *) +open Lwt +open Lwt_io + exception Syntax_error of string type display_hint_t = {hint : t; body : t} @@ -26,23 +29,23 @@ and t = | Arr of t list let _output_str ch s = - output_string ch (string_of_int (String.length s)); - output_char ch ':'; - output_string ch s + lwt () = write ch (string_of_int (String.length s)) in + lwt () = write_char ch ':' in + write ch s let rec output_sexp ch x = match x with - | Str s -> + | Str s -> _output_str ch s - | Hint {hint = h; body = b} -> - output_char ch '['; - output_sexp ch h; - output_char ch ']'; + | Hint {hint = h; body = b} -> + lwt () = write_char ch '[' in + lwt () = output_sexp ch h in + lwt () = write_char ch ']' in output_sexp ch b - | Arr xs -> - output_char ch '('; - List.iter (output_sexp ch) xs; - output_char ch ')' + | Arr xs -> + lwt () = write_char ch '(' in + lwt () = Lwt_list.iter_s (output_sexp ch) xs in + write_char ch ')' let rec stream_of_sexp x = Stringstream.make (fun () -> @@ -58,34 +61,39 @@ let rec stream_of_sexp x = Some ("(", false, Stringstream.seq (Stringstream.map stream_of_sexp xs) (Stringstream.const ")"))) -let output_char_escaped ch c = +let write_char_escaped ch c = if c = '\"' - then output_string ch "\\\"" - else output_char ch c + then write ch "\\\"" + else write_char ch c let rec output_sexp_human ch x = match x with - | Str s -> - output_char ch '\"'; - String.iter (output_char_escaped ch) s; - output_char ch '\"' - | Hint {hint = h; body = b} -> - output_char ch '['; - output_sexp_human ch h; - output_char ch ']'; + | Str s -> + lwt () = write_char ch '\"' in + lwt () = write ch (String.escaped s) in + write_char ch '\"' + | Hint {hint = h; body = b} -> + lwt () = write_char ch '[' in + lwt () = output_sexp_human ch h in + lwt () = write_char ch ']' in output_sexp_human ch b - | Arr xs -> - output_char ch '('; - (match xs with - | [] -> () - | [x] -> output_sexp_human ch x - | (x :: xs') -> - output_sexp_human ch x; - List.iter (fun x -> output_char ch ' '; output_sexp_human ch x) xs'); - output_char ch ')' + | Arr xs -> + lwt () = write_char ch '(' in + lwt () = + (match xs with + | [] -> return () + | [x] -> output_sexp_human ch x + | (x :: xs') -> + lwt () = output_sexp_human ch x in + Lwt_list.iter_s + (fun x -> + lwt () = write_char ch ' ' in + output_sexp_human ch x) + xs') in + write_char ch ')' let output_sexp_and_flush ch x = - output_sexp ch x; + lwt () = output_sexp ch x in flush ch let char_numeric c = '0' <= c && c <= '9' @@ -95,47 +103,50 @@ let digit_val c = (int_of_char c) - (int_of_char '0') let input_bytes ch count = let buf = String.create count in (* mutable strings?!?! *) - really_input ch buf 0 count; - buf + lwt () = read_into_exactly ch buf 0 count in + return buf -let syntax_error explanation = raise (Syntax_error explanation) +let syntax_error explanation = raise_lwt (Syntax_error explanation) let input_sexp_outer input_char input_bytes = let rec input_simple_string len = - match input_char () with - | ':' -> Str (input_bytes len) - | b when char_numeric b -> input_simple_string (len * 10 + digit_val b) - | _ -> syntax_error "Bad simple-string length character" + match_lwt input_char () with + | ':' -> lwt bs = input_bytes len in return (Str bs) + | b when char_numeric b -> input_simple_string (len * 10 + digit_val b) + | _ -> syntax_error "Bad simple-string length character" in let rec input_sexp_list () = let rec collect acc = - match input_sexp_inner () with - | None -> Arr (List.rev acc) - | Some v -> collect (v :: acc) + match_lwt input_sexp_inner () with + | None -> return (Arr (List.rev acc)) + | Some v -> collect (v :: acc) in collect [] and input_sexp_inner () = - match input_char () with - | '(' -> Some (input_sexp_list ()) - | ')' -> None - | '[' -> - let hint = input_simple_string 0 in - (match input_char () with - | ']' -> Some (Hint {hint = hint; body = input_simple_string 0}) - | _ -> syntax_error "Missing close-bracket in display hint") - | b when char_numeric b -> - Some (input_simple_string (digit_val b)) - | b when char_whitespace b -> + match_lwt input_char () with + | '(' -> lwt xs = input_sexp_list () in return (Some xs) + | ')' -> return None + | '[' -> + lwt hint = input_simple_string 0 in + (match_lwt input_char () with + | ']' -> lwt b = input_simple_string 0 in return (Some (Hint {hint = hint; body = b})) + | _ -> syntax_error "Missing close-bracket in display hint") + | b when char_numeric b -> + lwt s = input_simple_string (digit_val b) in return (Some s) + | b when char_whitespace b -> (* Convenience for testing *) input_sexp_inner () - | _ -> + | _ -> syntax_error "Bad SEXP input character" in - match input_sexp_inner () with - | None -> syntax_error "Unexpected end of list" - | Some v -> v + match_lwt input_sexp_inner () with + | None -> syntax_error "Unexpected end of list" + | Some v -> return v -let input_sexp ch = input_sexp_outer (fun () -> input_char ch) (input_bytes ch) -let parse b = input_sexp_outer (fun () -> Ibuffer.next_char b) (Ibuffer.next_chars b) +let input_sexp ch = input_sexp_outer (fun () -> read_char ch) (input_bytes ch) +let parse b = + input_sexp_outer + (fun () -> return (Ibuffer.next_char b)) + (fun count -> return (Ibuffer.next_chars b count)) let sexp_of_string s = parse (Ibuffer.of_string s) let string_of_sexp x = Stringstream.to_string (stream_of_sexp x) diff --git a/squeue.ml b/squeue_linked.ml similarity index 100% rename from squeue.ml rename to squeue_linked.ml diff --git a/status.ml b/status.ml index f106269..dffa013 100644 --- a/status.ml +++ b/status.ml @@ -15,6 +15,8 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt + type ('success, 'failure) t = | Ok of 'success | Problem of 'failure @@ -38,9 +40,9 @@ let is_transient x = let is_permanent x = not (is_transient x) let replace_ok x info = - match x with - | Ok _ -> Ok info - | Problem p -> Problem p + match_lwt x with + | Ok _ -> return (Ok info) + | Problem p -> return (Problem p) let replace_ok' x info_fn = match x with diff --git a/subscription.ml b/subscription.ml index c590e86..ed88f01 100644 --- a/subscription.ml +++ b/subscription.ml @@ -15,6 +15,7 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Datastructures type t = { @@ -42,19 +43,21 @@ let create source subs filter sink_str name reply_sink reply_name = name = name } in subs := StringMap.add uuid sub !subs; - Meta.announce_subscription source filter sink_str name true; - Node.post_ignore' reply_sink reply_name (Message.subscribe_ok (Sexp.Str uuid)) (Sexp.Str ""); - sub + lwt () = Lwt.join [ + Meta.announce_subscription source filter sink_str name true; + Node.post_ignore' reply_sink reply_name (Message.subscribe_ok (Sexp.Str uuid)) (Sexp.Str "") + ] in + return sub let delete source subs uuid = - try + try_lwt let sub = StringMap.find uuid !subs in sub.live <- false; subs := StringMap.remove uuid !subs; - Meta.announce_subscription source sub.filter sub.sink.Node.label sub.name false; - Some sub + lwt () = Meta.announce_subscription source sub.filter sub.sink.Node.label sub.name false in + return (Some sub) with Not_found -> - None + return None let lookup subs uuid = try Some (StringMap.find uuid !subs) @@ -62,11 +65,11 @@ let lookup subs uuid = let send_to_subscription' sub body delete_action = if not sub.live - then false + then return false else - if Node.post sub.sink sub.name body (Sexp.Str sub.uuid) - then true - else (delete_action sub.uuid; false) + match_lwt Node.post sub.sink sub.name body (Sexp.Str sub.uuid) with + | true -> return true + | false -> (lwt _ = delete_action sub.uuid in return false) let send_to_subscription source subs sub body = send_to_subscription' sub body (fun (uuid) -> delete source subs uuid) diff --git a/thirdparty/lwt-2.3.2/CHANGES b/thirdparty/lwt-2.3.2/CHANGES new file mode 100644 index 0000000..72a9c36 --- /dev/null +++ b/thirdparty/lwt-2.3.2/CHANGES @@ -0,0 +1,198 @@ +===== 2.3.2 (2011-11-04) ===== + + * Add location informations in logs: + ** allow loggers to get the current location through local storage + ** pass current location to logging functions + ** pass the current location with the syntax extension + * Add Lwt.on_termination + * Add Lwt_unix.reinstall_signal_handler + * Add Lwt_io.flush_all + * Add assert_lwt keyword to the syntax extension + * Add Lwt.wrap + * Add Lwt_glib.iter and Lwt_glib.wakeup + * ocaml 3.13 ready + * Allow to compile without libev support + * Fix bugs in Lwt_io + * Better handling of forks + * Fix many problems on Windows + +===== 2.3.1 (2011-07-13) ===== + + * Fix building of documentation when using the tarball + * Add Lwt_unix.fsync and Lwt_unix.fdatasync + * Fix the stubs for Lwt_unix.send_msg when fd-passing is not + available + * Add -lwt-sequence-strict option to the syntax extension + * Use a custom PRNG state for Lwt.choose and Lwt.pick + * Fix a display glitch when starting the toplevel + * Add Lwt_unix.fork which should now be used when one want to use + Lwt in the child process + * Better implementation of Lwt_unix.readlink and + Lwt_unix.gethostbyname, which fixes compilation on Hurd + * Add Lwt.wakeup_later and Lwt.wakeup_later_exn to be used when one + need to do lot of nested wakeup, which fixes a buffer overflow in + Lwt_mutex + * Fix Lwt_unix.abort and Lwt_unix.close (threads was never wakeup) + * Fix Lwt_throttle for correct timings + * Fix subtle use of cancel + +===== 2.3.0 (2011-04-12) ===== + + * Add an extensible system of engines to: + ** allow the user to replace libev by another event system, such + as select + ** allow easier integration of external libraries supporting + asynchronous operations + * Lots of improvements for windows: + ** use the ocaml select instead of libev by default on windows + ** make asynchronous operations on non-socket file descriptors + such as pipes to work + ** make glib integration to work + * Better use of engines in Lwt_unix: now events are cached to minimize + the amount of calls to epoll_ctl + * Use an eventfd when possible for notifications for faster delivery + * Add modules: + ** Lwt_sys: allow to test availability of extra features + ** Lwt_react: replace Lwt_event and Lwt_signal + * Allow to configure logging rules at runtime in Lwt_log + * Add match_lwt and while_lwt to the syntax extension + * Fixes: + ** syntax extension: handle "lwt ... = ... in ..." at toplevel + ** make the notification system fork-proof + ** fix an issue with stubs not raising correctly exceptions + +===== 2.2.1 (2011-01-26) ===== + + * Better interaction with Js_of_ocaml. + * Add functions {{{Lwt.register_pause_notifier}}} and {{{Lwt.paused_count}}}. + +===== 2.2.0 (2010-12-13) ===== + + * Bugfixes: + ** Fix a bug with cancellable threads causing {{{Canceled}}} + exceptions to be raised randomly + ** Fix a fd-leak in Lwt_io.open_connection + * {{{Lwt_unix}}} now use libev instead of select + * Add thread local storage support to {{{Lwt}}} + * Add backtrace support to {{{Lwt}}}. Now {{{Lwt}}} exceptions can + be recored by using the syntax extension with the {{{-lwt-debug}}} + command line switch. + * Allow blocking system calls to be executed in parallels + * Change the type of many functions of {{{Lwt_unix}}}, which now + return a {{{Lwt}}} thread + * Add functions {{{Lwt_unix.readable}}} and {{{Lwt_unix.writable}}} + * Add function {{{Lwt_io.is_busy}}} + * Add functions {{{Lwt_event.delay}}} and {{{Lwt_signal.delay}}} + * Add function {{{Lwt_term.render_update}}} + * Add function {{{Lwt_ssl.embed_socket}}} + * Add module {{{Lwt_bytes}}} defining operations on bigarrays + instead of strings + * Use bigarrays in Lwt_io instead of strings for the internal buffer. + Lwt_io.make now takes a function that uses a bigarray. + * Add module {{{Lwt_switch}}} + +===== 2.1.1 (2010-06-13) ===== + + * Many bugfixes, including: + ** buggy behaviour of cancellable threads + ** file descriptor leakage in {{{Lwt_unix.accept_n}}} + * Add {{{Lwt.nchoose}}} and {{{Lwt.npick}}} + * Use {{{set_close_on_exec}}} for fds created by {{{Lwt_log}}} + * Better implementation of lwtized react functions + +===== 2.1.0 (2010-04-19) ===== + + * Rename {{{Lwt.select}}} to {{{Lwt.pick}}} + * Removing module {{{Lwt_monitor}}} in favour of {{{Lwt_mutex}}} and + new module {{{Lwt_condition}}} + * More react helpers: + ** {{{Lwt_event.next}}} + ** {{{Lwt_event.limit}}} and {{{Lwt_signal.limit}}} + ** {{{Lwt_event.from}}} + * Adding function {{{Lwt_main.fast_yield}}} + * Adding unit tests + * Optimisation of {{{Lwt}}} + * Adding module {{{Lwt_log}}} for logging + * Adding a camlp4 filter for remmoving logging statement or inlining + tests + * Adding module {{{Lwt_daemon}}} + * Adding function {{{Lwt_unix.recv_msg}}} and {{{Lwt_unix.send_msg}}} + * Adding function {{{Lwt_unix.wait4}}} + * Adding function {{{Lwt_io.establish_server}}} + * Adding module {{{Lwt_list}}} + * Enhancement in {{{Lwt_process}}}, it now support redirections and + timeouts + * Allow to use {{{select}}} on arbitrary high file descriptors + * More commands and features in {{{Lwt_read_line}}}: + ** Handle "undo" command + ** New controlable read-lines instances + ** More edition commands + ** Completion as you type + ** Backward search + * Enhancement in {{{Lwt_term}}}: more drawing functions and allow to + put the terminal into drawing mode + * Optimisation of {{{Lwt_stream}}} + * Optimisation of {{{Lwt_io.write_char}}} and {{{Lwt_io.read_char}}} + * Bugfix of {{{Lwt_stream}}}: two parallel {{{Lwt_stream.get}}} + returned the same value + * Bugfix in {{{Lwt_unix.connect}}}: it returned immediatly on EINPROGRESS + * Bugfixes in {{{Lwt_glib}}}: file descriptors were not monitored correctly + +===== 2.0.0 (2009-10-15) ===== + + * Adding modules: + ** {{{Lwt_stream}}}: lwt-aware version of the {{{Stream}}} module + ** {{{Lwt_gc}}} for using {{{finalise}}} without + {{{Lwt_unix.run}}} + ** {{{Lwt_io}}}: a new implementation of buffered channels with + more features and better handling of concurrent access + ** {{{Lwt_text}}}: implementation of text channels + ** {{{Lwt_process}}}: helpers to spawn processes and communicate + with them + ** {{{Lwt_main}}} for abstracting the main loop and allowing + replacement by a custom main loop + ** {{{Lwt_glib}}} for integration into the glib main event loop + ** {{{Lwt_term}}} for interaction with the terminal + ** {{{Lwt_read_line}}} for interactive user input + ** {{{Lwt_monitor}}}, {{{Lwt_mvar}}}: combined locks for + synchronization with conditional variables for notification + ** {{{Lwt_throttle}}} for limiting rate of execution + (e.g. for authentication procedure) + ** {{{Lwt_sequence}}}: mutable sequence of elements + ** {{{Lwt_event}}}, {{{Lwt_signal}}}: helpers for reactive + programming with lwt + * Adding a syntax extension {{{pa_lwt}}}: + ** handles anonymous bind {{{a >> b}}} + ** adds syntactic sugar for catching errors (ticket #6) + ** adds syntactic sugar for parallel let-binding construction + ** adds syntactic sugar for for-like loops + * Top-level integration: + ** threads can runs while reading user input + ** line editing support + * New enhanced OCaml toplevel with some basic completion features + * Adding C stubs to reimplement {{{Unix.read}}} and {{{Unix.write}}} + with assumption of non-blocking behaviour + * Adding more functions/helpers in {{{Lwt}}} + * Fixing memory leaks in {{{Lwt.choose}}} + * Bugfix in {{{Lwt_chan.close_*}}} (ticket #66) + * Separate the type of threads (covariant) from the type of thread + wakeners (contravariant); the type of many functions related to + {{{Lwt.wait}}} has been changed + * Add cancelable threads + * Unix-dependent part is now put in its own archive and findlib + package. + +===== 1.1.0 (2008-06-25) ===== + + * Adding module {{{Lwt_pool}}} for creating pools (for example pools + of connections) + * Adding a few functions in {{{Lwt_chan}}} + * Fixing bugs in {{{Lwt_util.map_serial}}} and + {{{Lwt_util.iter_serial}}} + * Putting {{{Lwt_preemptive}}}, {{{Lwt_lib}}} and {{{Lwt_ssl}}} in + separate libraries and findlib subpackages so that lwt.cma depends + only on unix.cma. + +===== 1.0.0 (and before) ===== + + * See Ocsigen changelog diff --git a/thirdparty/lwt-2.3.2/CHANGES.darcs b/thirdparty/lwt-2.3.2/CHANGES.darcs new file mode 100644 index 0000000..6f05076 --- /dev/null +++ b/thirdparty/lwt-2.3.2/CHANGES.darcs @@ -0,0 +1,2248 @@ +Fri Nov 4 14:52:56 CET 2011 chambart@crans.org + tagged 2.3.2 + +Fri Nov 4 14:52:20 CET 2011 chambart@crans.org + * Update CHANGES and version + +Fri Oct 28 23:29:41 CEST 2011 Jeremie Dimino + * explain that one need to call Lwt_main.run in a Lwt program in the manual + +Mon Oct 10 17:22:32 CEST 2011 gregoire.henry@pps.jussieu.fr + * Doc: add menu.wiki + +Thu Sep 22 14:33:38 CEST 2011 Jeremie Dimino + * use a monospace font in the gtk example + +Thu Sep 22 14:28:18 CEST 2011 Jeremie Dimino + * add a gtk example + +Thu Sep 22 12:57:56 CEST 2011 Jeremie Dimino + * make the documentation of Lwt_glib more explicit + +Wed Sep 21 14:26:02 CEST 2011 Jeremie Dimino + * add Lwt_glib.wakeup + +Wed Sep 21 02:05:29 CEST 2011 Jeremie Dimino + * acquire the context in Lwt_glib.iter + +Wed Sep 21 01:04:31 CEST 2011 Jeremie Dimino + * fix compilation of lwt.glib with msvc + +Tue Sep 20 23:43:07 CEST 2011 Jeremie Dimino + * fix compilation of lwt.glib on windows + +Tue Sep 20 23:22:49 CEST 2011 Jeremie Dimino + * add Lwt_glib.iter + +Mon Sep 19 23:29:12 CEST 2011 Jeremie Dimino + * fix Lwt_unix.connect on Windows + +Mon Sep 19 23:26:13 CEST 2011 Jeremie Dimino + * fix the use of socket on Windows + + Testing whether a file descriptor is a socket with Unix.fstat does not + work on Windows: + + # let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0;; + val sock : Unix.file_descr = + # Unix.fstat sock;; + val Unix.stats = { Unix.st_kind = Unix.S_REG; ... + +Mon Sep 19 21:49:48 CEST 2011 Jeremie Dimino + * cleanup examples + +Mon Sep 19 19:27:42 CEST 2011 Jeremie Dimino + * do not use pthread on windows + +Mon Sep 19 16:12:18 CEST 2011 Jeremie Dimino + * fix compilation with msvc tools + + The Microsoft compiler does not allow to mix variable definition and + code. + +Mon Sep 19 15:48:11 CEST 2011 Jeremie Dimino + * handle compilers that prints things on stdout in discover.ml + +Thu Sep 15 15:28:05 CEST 2011 Jeremie Dimino + * add Lwt.wrap + +Thu Sep 15 14:23:35 CEST 2011 Jeremie Dimino + * make assert_lwt to work + +Thu Sep 15 14:14:48 CEST 2011 Jeremie Dimino + * add the assert_lwt keyword in pa_lwt + +Wed Sep 7 13:46:26 CEST 2011 Jeremie Dimino + * remove ev.h from glib stubs (not used) + +Wed Sep 7 13:29:17 CEST 2011 Jeremie Dimino + * allow to compile without libev support + +Mon Aug 22 21:49:31 CEST 2011 Jeremie Dimino + * add a note for compiling the toplevel + +Mon Aug 22 21:25:23 CEST 2011 Jeremie Dimino + * fix compilation of lwt.text with ocaml >= 3.13 + +Mon Aug 15 22:44:08 CEST 2011 Jeremie Dimino + * add type annotations in Lwt_io for ocaml 3.13 + +Mon Aug 15 17:16:42 CEST 2011 Jeremie Dimino + * reset the job system after a fork + +Mon Aug 15 16:10:28 CEST 2011 Jeremie Dimino + * cancel jobs after a fork + +Mon Aug 15 10:31:16 CEST 2011 Jeremie Dimino + * add Lwt_io.flush_all + +Mon Aug 15 10:31:00 CEST 2011 Jeremie Dimino + * add Lwt.on_termination + +Fri Aug 12 16:29:29 CEST 2011 Jeremie Dimino + * add Lwt_unix.reinstall_signal_handler + +Wed Aug 10 19:06:06 CEST 2011 Jeremie Dimino + * fix ticket #169 + +Thu Aug 4 11:03:48 CEST 2011 Jeremie Dimino + * enable location in logs + + - allow loggers to get the current location through local storage + - pass current location to logging functions + - pass the current location with the syntax extension + +Wed Aug 3 20:20:20 CEST 2011 Jeremie Dimino + * use a GADT for the type of channels with ocaml 3.13 + +Thu Jul 28 22:48:06 CEST 2011 Stephane Glondu + * Avoid unused-but-set-variable GCC warning + +Thu Jul 28 11:52:12 CEST 2011 chambart@crans.org + * fix data corruption in Lwt_io. + +Mon Jul 18 16:57:31 CEST 2011 Jeremie Dimino + * fix a race condition in Lwt_io + +Wed Jul 13 19:05:38 CEST 2011 chambart@crans.org + tagged 2.3.1 + +Wed Jul 13 19:03:50 CEST 2011 chambart@crans.org + * update licence file (add text of BSD license) + +Wed Jul 13 18:40:59 CEST 2011 chambart@crans.org + * version 2.3.1 + +Wed Jul 13 18:38:40 CEST 2011 chambart@crans.org + * update CHANGES + +Wed Jul 13 18:30:27 CEST 2011 michaell.laporte@gmail.com + * Add license in test/core files + +Wed Jul 13 11:36:31 CEST 2011 Jeremie Dimino + * typo in the doc + +Tue Jul 12 18:24:01 CEST 2011 Jeremie Dimino + * add a cancel test + +Tue Jul 12 18:21:57 CEST 2011 Jeremie Dimino + * make Lwt.get_cancel tail-recursive + +Tue Jul 12 16:39:02 CEST 2011 Jeremie Dimino + * implement union-find for cancel functions + +Tue Jul 12 13:41:25 CEST 2011 Jeremie Dimino + * fix a recursive call in Lwt.cancel_and_nth_ready + +Sat Jul 2 21:05:40 CEST 2011 Jeremie Dimino + * simplify setup.ml + +Sat Jul 2 12:43:45 CEST 2011 Jeremie Dimino + * keep setup.ml for the customization + +Thu Jun 30 16:43:24 CEST 2011 Jeremie Dimino + * update CHANGES + +Thu Jun 9 13:25:57 CEST 2011 chambart@crans.org + * rewrite Lwt_throttle + +Thu Jun 30 15:58:44 CEST 2011 Jeremie Dimino + * do not use Lwt_engine.fake_io anymore in Lwt_unix + +Thu Jun 30 15:54:02 CEST 2011 Jeremie Dimino + * fix Lwt_unix.abort + +Fri Jun 24 21:06:12 CEST 2011 Jeremie Dimino + * use more Lwt.wakeup_later + +Sat Jun 18 18:36:24 CEST 2011 Jeremie Dimino + * remove oasis files from the repository + +Sat Jun 18 16:36:31 CEST 2011 Jeremie Dimino + * change the implementation of Lwt.wakeup_later{,_exn} + +Sat Jun 18 16:17:56 CEST 2011 Jeremie Dimino + * add Lwt.wakeup_later{,_exn} and use it in Lwt_mutex + +Wed Jun 15 10:31:03 CEST 2011 Stephane Glondu + * Fix link order in library detection test + + The wrong link order was causing a build failure on Ubuntu, where the + linker is stricter. + +Fri Jun 10 19:08:01 CEST 2011 Jeremie Dimino + * fix some size_t problems + +Fri Jun 10 13:53:22 CEST 2011 Nicolas Dandrimont + * Use a dynamically-allocated buffer for readlink and gethostname + + This allows the use of readlink and gethostname on systems without a + size limit on their return values (e.g. Hurd). + +Tue May 31 20:18:09 CEST 2011 Jeremie Dimino + * use Lwt_unix.fork in Lwt_process and Lwt_daemon + +Tue May 31 20:13:15 CEST 2011 Jeremie Dimino + * do not run exit hooks in the parent process when daemonizing + +Mon May 30 16:48:16 CEST 2011 Jeremie Dimino + * add Lwt_unix.fork + +Mon May 30 14:04:11 CEST 2011 Jeremie Dimino + * use oasis 0.2.1 + +Mon May 30 14:02:49 CEST 2011 Jeremie Dimino + * handle EINTR in the notification system + +Fri May 27 09:45:37 CEST 2011 Jeremie Dimino + * fix compilation on hurd + +Tue May 17 18:24:03 CEST 2011 Jeremie Dimino + * flush after displaying the message in the toplevel + +Fri May 13 20:29:21 CEST 2011 Jeremie Dimino + * use a custom PRNG state for Lwt.choose and Lwt.pick + +Thu May 5 18:19:10 CEST 2011 raphael proust + * Added -lwt-sequence-strict option to syntax extension + +Wed May 4 10:38:57 CEST 2011 raphael proust + * typo in Lwt_log doc + +Thu May 5 16:54:51 CEST 2011 Jeremie Dimino + * typo in the stubs for Lwt_unix.send_msg + + n_fds was not initialized correctly. + +Mon Apr 25 20:12:42 CEST 2011 Jeremie Dimino + * allow to compile without fdatasync + +Fri Apr 22 13:54:52 CEST 2011 Jeremie Dimino + * add Lwt_unix.{fsync,fdatasync} + +Thu Apr 21 10:39:49 CEST 2011 Jeremie Dimino + * ensure that all events are cleared before closing a file descriptor + +Wed Apr 20 08:46:54 CEST 2011 Jeremie Dimino + * 'make clean' in manual/ remove manual-wiki.tex + +Mon Apr 18 21:38:26 CEST 2011 Jeremie Dimino + * do not remove manual-wiki.tex from the tarball + +Tue Apr 12 17:03:02 CEST 2011 chambart@crans.org + * Add link to download the pdf manual in the doc + +Tue Apr 12 16:34:19 CEST 2011 chambart@crans.org + * lift apiref-intro headers levels + +Tue Apr 12 15:53:39 CEST 2011 Jeremie Dimino + tagged 2.3.0 + +Tue Apr 12 15:53:23 CEST 2011 Jeremie Dimino + * version 2.3.0 + +Tue Apr 12 15:43:18 CEST 2011 Jeremie Dimino + * typo + +Tue Apr 12 15:37:43 CEST 2011 Jeremie Dimino + * update CHANGES + +Sun Apr 10 18:51:47 CEST 2011 Jeremie Dimino + * fix ocamldoc comment + +Sat Apr 9 14:36:35 CEST 2011 Jeremie Dimino + * add match_lwt and while_lwt to the manual + +Sat Apr 9 13:42:29 CEST 2011 Jeremie Dimino + * allow to add rules for logging levels in Lwt_log + +Thu Apr 7 18:12:59 CEST 2011 Jeremie Dimino + * handle the case when eventfd is present at compilation time but not supported by the system + +Thu Apr 7 17:32:50 CEST 2011 Jeremie Dimino + * register a printer for unix errors + +Wed Apr 6 18:08:31 CEST 2011 Jeremie Dimino + * include Lwt_io.{LE/BE} into Lwt_io according to the system byte order + +Sun Apr 3 00:37:37 CEST 2011 Jeremie Dimino + * add Lwt.nchoose_split + +Sat Apr 2 23:16:23 CEST 2011 Jeremie Dimino + * cleanup events when they are no more used in Lwt_unix + +Sat Apr 2 18:01:55 CEST 2011 Jeremie Dimino + * handle "lwt ... = ... in ..." at toplevel in the syntax extension + +Thu Mar 31 15:34:35 CEST 2011 Jeremie Dimino + * try to minimize the amount of calls to epoll_ctl by caching engine events + +Thu Mar 31 12:10:41 CEST 2011 Jeremie Dimino + * make the notification system fork-proof + +Tue Mar 29 15:54:53 CEST 2011 Jeremie Dimino + * add the >= 3.12 constraint in _oasis + +Tue Mar 29 11:37:57 CEST 2011 Jeremie Dimino + * fix the syntax extension for while_lwt and match_lwt + +Mon Mar 28 21:37:45 CEST 2011 Jeremie Dimino + * allow to omit the pattern in logging rules + + So we can write LWT_LOG=debug instead of LWT_LOG='* -> debug' + +Fri Mar 25 09:17:24 CET 2011 Jeremie Dimino + * build and install cmxs + +Tue Mar 22 16:00:57 CET 2011 Jeremie Dimino + * copy Unix types into Lwt_unix + + This is for better detection of changes in Unix types since bindings + depends on their representations. + +Tue Mar 22 08:47:37 CET 2011 Jeremie Dimino + * make the "push and GC" test to work in bytecode + +Mon Mar 21 13:34:35 CET 2011 Jeremie Dimino + * typo in the external for sendto + +Wed Mar 16 11:44:20 CET 2011 Jeremie Dimino + * add reporting functions + +Tue Mar 15 17:14:25 CET 2011 Jeremie Dimino + * replace Lwt_react.{E,S}.notify* by Lwt_react.{E,S}.keep + +Fri Mar 11 11:18:15 CET 2011 Jeremie Dimino + * add match_lwt and while_lwt to the syntax extension + +Fri Mar 11 10:55:43 CET 2011 Jeremie Dimino + * update the manual about lwt.react + +Fri Mar 11 10:49:28 CET 2011 Jeremie Dimino + * add lwt.syntax and lwt.syntax.log the the API documentation + +Fri Mar 11 10:45:41 CET 2011 Jeremie Dimino + * update apiref-intro for lwt.react + +Thu Mar 10 17:54:52 CET 2011 Jeremie Dimino + * reimplement Lwt_{event,signal} on top of Lwt_react + +Thu Mar 10 16:21:53 CET 2011 Jeremie Dimino + * add module Lwt_react + + - Reimplements React's Lwtised primitives in a simpler way. + - Changes the API of signals, now map_s and co returns a thread instead + of taking an initial value. The experience shows that it is more + suitable. + - Removes notify* functions and replaces them by always_notify* functions. + Id are useless, it is sufficient to use directly signals and events instead. + +Thu Mar 10 12:02:34 CET 2011 Jeremie Dimino + * add Lwt.on_{success,failure} + +Thu Mar 10 11:57:00 CET 2011 Jeremie Dimino + * fix local storage handling in Lwt.on_cancel + +Thu Mar 3 21:59:43 CET 2011 Jeremie Dimino + * remove "noalloc" from stubs that may raise exceptions + +Tue Feb 22 22:09:11 CET 2011 Jeremie Dimino + * fix the unix job for Lwt_bytes.{read,write} on windows + +Wed Feb 16 16:22:03 CET 2011 chambart@crans.org + * add getsockname getpeername to Lwt_ssl + +Fri Feb 11 14:25:30 CET 2011 chambart@crans.org + * Lwt_stream: avoid memory leak from create + in let push,stream = create () + push no longer keep a reference to data in the stream + + +Mon Feb 14 20:21:54 CET 2011 Jeremie Dimino + * remove all exit hooks when an execvp fails + +Mon Feb 14 11:52:31 CET 2011 Jeremie Dimino + * add manual build files to the boring file + +Mon Feb 14 11:44:16 CET 2011 Jeremie Dimino + * add a boring file + +Sun Feb 13 19:00:25 CET 2011 Jeremie Dimino + * put text stubs into src/text + +Sun Feb 13 00:35:53 CET 2011 Jeremie Dimino + * fix Lwt_unix.get_cpu + +Sun Feb 13 00:33:28 CET 2011 Jeremie Dimino + * allow to integrate lwt into glib instead of glib of lwt + + Because glib into lwt does not works under windows + +Sat Feb 12 23:17:39 CET 2011 Jeremie Dimino + * add Lwt_sys to apiref-intro + +Sat Feb 12 18:07:23 CET 2011 Jeremie Dimino + * use optcomp + +Sat Feb 12 16:01:47 CET 2011 Jeremie Dimino + * add module Lwt_sys + +Fri Feb 11 23:40:09 CET 2011 Jeremie Dimino + * typos + +Fri Feb 11 22:09:33 CET 2011 Jeremie Dimino + * add Lwt_unix.have + +Fri Feb 11 14:34:31 CET 2011 Jeremie Dimino + * use the code plugin in the manual and add colors + +Fri Feb 11 09:10:28 CET 2011 Jeremie Dimino + * typo + +Fri Feb 11 09:01:59 CET 2011 Jeremie Dimino + * remove obsolete doc about C stubs + +Fri Feb 11 08:56:32 CET 2011 Jeremie Dimino + * use code plugins in the manual + +Fri Feb 11 08:19:45 CET 2011 Jeremie Dimino + * use rubber for creating the pdf + +Fri Feb 11 00:51:02 CET 2011 Jeremie Dimino + * convert the doc to wikicreole + +Thu Feb 10 21:35:41 CET 2011 Jeremie Dimino + * ensure that glib main loop functions are called in the right order + +Thu Feb 10 17:55:16 CET 2011 Jeremie Dimino + * lwt.glib enhancement + +Thu Feb 10 14:49:46 CET 2011 Jeremie Dimino + * add -L/-I flags also for lwt.glib + +Thu Feb 10 14:33:08 CET 2011 Jeremie Dimino + * use a pair of socket for notifications on windows + +Thu Feb 10 14:14:54 CET 2011 Jeremie Dimino + * fix windows stubs + +Thu Feb 10 13:54:03 CET 2011 Jeremie Dimino + * better fd blocking detection on windows + +Thu Feb 10 12:52:35 CET 2011 Jeremie Dimino + * implement more stubs on windows + +Thu Feb 10 11:54:06 CET 2011 Jeremie Dimino + * use a byte plugin for compilling examples + + For better portability + +Thu Feb 10 11:50:36 CET 2011 Jeremie Dimino + * search for headers in a list of predefined directories + + It is for better integration with Windows and MacOS + +Thu Feb 10 10:10:05 CET 2011 Jeremie Dimino + * enhancement in the notification system + + - support unbounded number of simultaneous notifications + - send only one byte for simultaneous notifications + +Wed Feb 9 22:39:34 CET 2011 Jeremie Dimino + * use eventfd when available for notifications + +Tue Feb 8 17:24:52 CET 2011 Jeremie Dimino + * fix engines transfers + +Tue Feb 8 15:31:34 CET 2011 Jeremie Dimino + * typo + +Tue Feb 8 15:11:17 CET 2011 Jeremie Dimino + * stop all events before destroying an engine + +Tue Feb 8 15:05:27 CET 2011 Jeremie Dimino + * reimplement fd aborting + +Tue Feb 8 14:54:40 CET 2011 Jeremie Dimino + * implement engine copying + +Tue Feb 8 14:04:34 CET 2011 Jeremie Dimino + * fix the main loop + + I don't really know why it fixes tests... + +Mon Feb 7 23:28:07 CET 2011 Jeremie Dimino + * refactoring + use an engine based on select for windows + +Mon Feb 7 15:06:30 CET 2011 Jeremie Dimino + * fix examples + +Mon Feb 7 15:04:01 CET 2011 Jeremie Dimino + * reimplement lwt.glib with the new engine system + +Sun Feb 6 23:46:24 CET 2011 Jeremie Dimino + * allow to replace libev by another engine + +Wed Jan 26 14:19:37 CET 2011 chambart@crans.org + tagged 2.2.1 + +Wed Jan 26 14:17:37 CET 2011 chambart@crans.org + * update changelog and version number + +Mon Jan 24 21:55:14 CET 2011 Jeremie Dimino + * better way of copying/emptying the list of threads paused/yielded + +Mon Jan 24 16:29:08 CET 2011 Jeremie Dimino + * add a counter for paused threads and do not call wakeup_paused recursively + +Fri Jan 14 17:44:48 CET 2011 chambart@crans.org + * add a hook for Lwt.pause + +Fri Jan 14 17:33:36 CET 2011 chambart@crans.org + * circumvent an js_of_ocaml bug + +Tue Jan 4 14:19:50 CET 2011 Jeremie Dimino + * remove tests using finalisers + + Tests may fail because it is not ensured that finalisers will be + called. + +Fri Dec 17 16:58:14 CET 2010 Jeremie Dimino + * check for C libraries at configure time + +Thu Dec 16 17:46:19 CET 2010 Jeremie Dimino + * add libev to the README + +Mon Dec 13 15:37:20 CET 2010 Jeremie Dimino + tagged 2.2.0 + +Mon Dec 13 15:37:05 CET 2010 Jeremie Dimino + * version 2.2.0 + +Mon Dec 13 15:36:03 CET 2010 Jeremie Dimino + * add Lwt_bytes to apiref-intro + +Mon Dec 13 14:36:56 CET 2010 Jeremie Dimino + * update CHANGES + +Mon Dec 13 14:15:22 CET 2010 Jeremie Dimino + tagged 2.2 + +Mon Dec 13 14:15:02 CET 2010 Jeremie Dimino + * version 2.2 + +Sun Dec 12 18:49:31 CET 2010 balat at univ-paris-diderot.fr + * Adding wiki documentation + +Thu Dec 9 15:35:42 CET 2010 Jeremie Dimino + * install lwt_unix.h + +Wed Dec 8 17:25:21 CET 2010 Jeremie Dimino + * add Lwt.waiter_of_wakener + +Sat Dec 4 18:06:03 CET 2010 Jeremie Dimino + * remove Lwt.block and Lwt.no_cancel + +Sat Dec 4 11:58:40 CET 2010 Jeremie Dimino + * update CHANGES + +Sat Dec 4 11:38:25 CET 2010 Jeremie Dimino + * update the manual + +Sat Dec 4 10:42:14 CET 2010 Jeremie Dimino + * add Lwt.block and Lwt.no_cancel + +Thu Dec 2 17:44:26 CET 2010 Jeremie Dimino + * add Lwt_ssl.embed_socket + +Wed Dec 1 18:19:28 CET 2010 Jeremie Dimino + * fix a fd leak in Lwt_io.open_connection + +Sun Nov 28 18:24:47 CET 2010 Jeremie Dimino + * do not call pkg-config if not building lwt.glib + +Sat Nov 27 01:36:36 CET 2010 Jeremie Dimino + * update tests for local storage + +Fri Nov 26 21:24:31 CET 2010 Jeremie Dimino + * change the implementation of local storage + +Fri Nov 26 11:15:46 CET 2010 Jeremie Dimino + * discover available features at compile time + +Fri Nov 26 03:10:09 CET 2010 Jeremie Dimino + * fix compilation on opensolaris + +Thu Nov 25 17:11:20 CET 2010 Jeremie Dimino + * add more functions to Lwt_bytes + +Thu Nov 25 16:45:26 CET 2010 Jeremie Dimino + * do not wait if not needed in Lwt_bytes.wait_mincore + +Thu Nov 25 11:32:44 CET 2010 Jeremie Dimino + * put mmap stuff into Lwt_bytes + +Wed Nov 24 23:44:10 CET 2010 Jeremie Dimino + * add Lwt_bytes.{recvfrom,sendto} + +Wed Nov 24 20:52:13 CET 2010 Jeremie Dimino + * add Lwt_bytes.{recv,send}_msg + +Wed Nov 24 17:14:49 CET 2010 Jeremie Dimino + * replace strings by bigarrays in Lwt_io + +Tue Nov 23 21:24:24 CET 2010 Jeremie Dimino + * add Lwt_bytes to do IOs on bigarrays + +Wed Nov 24 07:52:06 CET 2010 Jeremie Dimino + * handle errors in lwt_unix_write_result + +Tue Nov 23 23:46:07 CET 2010 Jeremie Dimino + * fix compilation on FreeBSD + +Tue Nov 23 20:06:06 CET 2010 Jeremie Dimino + * do not create the notification if not needed in Lwt_unix.execute_job + +Tue Nov 23 16:11:06 CET 2010 Jeremie Dimino + * use a custom hashtbl for storing notifiers + +Tue Nov 23 15:32:44 CET 2010 Jeremie Dimino + * fix the stubs for stat + +Tue Nov 23 15:29:25 CET 2010 Jeremie Dimino + * fix compilation on windows + +Tue Nov 23 03:22:05 CET 2010 Jeremie Dimino + * use realtime signals instead of SIGUSR1 + +Tue Nov 23 02:38:45 CET 2010 Jeremie Dimino + * add functions to get/set the affinity + +Tue Nov 23 02:05:29 CET 2010 Jeremie Dimino + * do not include (not used) + +Mon Nov 22 23:30:36 CET 2010 Jeremie Dimino + * fix a memory leak in Lwt_unix.set_notification + + Use Hashtbl.replace instead of Hashtbl.add + +Mon Nov 22 23:22:30 CET 2010 Jeremie Dimino + * remove global roots when the watcher is stopped in libev stubs + +Mon Nov 22 22:42:18 CET 2010 Jeremie Dimino + * fix a typo in lwt_unix_send_notification_stub + +Mon Nov 22 21:08:00 CET 2010 Jeremie Dimino + * do not wait if not needed in Lwt_unix.execute_job + +Mon Nov 22 14:39:04 CET 2010 Jeremie Dimino + * delete the mutex associated to a job when it terminates + +Sun Nov 21 19:27:11 CET 2010 Jeremie Dimino + * fix cancellation of blocking calls + +Sun Nov 21 18:18:37 CET 2010 Jeremie Dimino + * add functions to control the pool of threads + +Sun Nov 21 16:37:23 CET 2010 Jeremie Dimino + * add Lwt_unix.readdir_n and Lwt_unix.files_of_directory + +Sun Nov 21 13:54:25 CET 2010 Jeremie Dimino + * use a hash table for storing notifications + +Sun Nov 21 12:26:49 CET 2010 Jeremie Dimino + * fix examples + +Sun Nov 21 11:58:05 CET 2010 Jeremie Dimino + * fix a bug in stubs for the switch async method + +Sat Nov 20 17:29:20 CET 2010 Jeremie Dimino + * set the [set_flags] field in [Lwt_unix.set_blocking] + +Sat Nov 20 13:37:13 CET 2010 Jeremie Dimino + * guess the blocking mode when not specified + +Fri Nov 19 22:54:36 CET 2010 Jeremie Dimino + * implement the switch async method + +Thu Nov 18 21:54:06 CET 2010 Jeremie Dimino + * add mmap oasis files + +Thu Nov 18 16:46:11 CET 2010 Jeremie Dimino + * create the sub-library lwt.mmap + +Thu Nov 18 10:51:38 CET 2010 Jeremie Dimino + * handle exceptions raised during the execution of libev_loop + + In particular handle SIGINT in the toplevel. + +Thu Nov 18 10:25:03 CET 2010 Jeremie Dimino + * reimplement Lwt_unix.abort with libev + +Thu Nov 18 04:09:12 CET 2010 Jeremie Dimino + * implement lwtized unix functions + +Wed Nov 17 21:04:54 CET 2010 Jeremie Dimino + * add prototype of all lwtised unix functions + +Wed Nov 17 17:54:11 CET 2010 Jeremie Dimino + * expose Lwt_unix.{readable,writable} + +Wed Nov 17 17:36:31 CET 2010 Jeremie Dimino + * add Lwt_io.is_busy + +Wed Nov 17 16:38:31 CET 2010 Jeremie Dimino + * add constants for the switch async method + +Wed Nov 17 15:45:49 CET 2010 Jeremie Dimino + * execute synchronous job in a blocking section + +Wed Nov 17 13:19:30 CET 2010 Jeremie Dimino + * add Lwt.with_value + +Wed Nov 17 08:35:13 CET 2010 Jeremie Dimino + * implement async version of Lwt_unix.close + +Wed Nov 17 01:15:25 CET 2010 Jeremie Dimino + * fix lwt_unix_send_notification + +Wed Nov 17 00:11:10 CET 2010 Jeremie Dimino + * add a mechanisms for running blocking system calls in parallels + +Wed Nov 10 15:37:17 CET 2010 Jeremie Dimino + * put Lwt_mmap into public modules + +Mon Nov 8 17:25:26 CET 2010 Jeremie Dimino + * put code examples into boxes in the manual + +Sun Nov 7 21:51:53 CET 2010 Jeremie Dimino + * make glib stubs to work on windows + +Fri Nov 5 18:11:45 CET 2010 Jeremie Dimino + * add a macro to acquire the runtime system lock from libev callbacks + +Tue Nov 2 23:12:07 CET 2010 Jeremie Dimino + * add doc for threads local storage + +Tue Nov 2 22:38:39 CET 2010 chambart@crans.org + * tests for Lwt_mmap + +Tue Nov 2 22:35:07 CET 2010 chambart@crans.org + * Lwt_mmap bugfixes + +Tue Nov 2 16:20:33 CET 2010 Jeremie Dimino + * add files generated by 'oasis setup' + + So users can compile the development version without installing oasis. + +Mon Nov 1 17:58:35 CET 2010 Jeremie Dimino + * fix a bug in read_notification + +Mon Nov 1 17:30:46 CET 2010 Jeremie Dimino + * fix a bug in send_notification + +Fri Oct 29 21:51:48 CEST 2010 Jeremie Dimino + * fix several wrong recursive calls in Lwt_list + +Fri Oct 29 18:36:13 CEST 2010 Jeremie Dimino + * use Lwt.task instead of Lwt.wait in Lwt_condition and Lwt_pool + +Fri Oct 29 17:50:50 CEST 2010 Jeremie Dimino + * better completion on modules contents + + Now completion works with modules defined in the toplevel. + +Thu Oct 28 12:37:42 CEST 2010 Jeremie Dimino + * handle Lwt_unix.yield without libev + +Wed Oct 27 22:55:49 CEST 2010 Jeremie Dimino + * fix the name of the stubs for glib in _tags + +Tue Oct 26 10:28:00 CEST 2010 Jeremie Dimino + * remove child watchers from libev stubs (not used) + +Tue Oct 26 01:28:50 CEST 2010 Jeremie Dimino + * fix compilation on windows + +Tue Oct 26 01:07:29 CEST 2010 Jeremie Dimino + * add support for windows threads + +Tue Oct 26 00:41:48 CEST 2010 Jeremie Dimino + * use libev instead of select + +Sat Oct 23 01:57:44 CEST 2010 Jeremie Dimino + * add oasis files to the repository + +Sat Oct 23 01:19:23 CEST 2010 Jeremie Dimino + * fix a typo in predist + +Sat Oct 23 01:00:47 CEST 2010 Jeremie Dimino + * update oasis stuff to oasis 0.2 + +Mon Oct 18 17:34:51 CEST 2010 Jeremie Dimino + * update the manual + +Tue Oct 12 18:35:28 CEST 2010 Jeremie Dimino + * add the inputenc package for the manual + +Fri Oct 8 17:31:53 CEST 2010 Jeremie Dimino + * add a "milliseconds" variable to Lwt_log + +Tue Oct 5 00:38:05 CEST 2010 Jeremie Dimino + * rename Makefile to make-dist.sh + +Tue Oct 5 00:29:12 CEST 2010 Jeremie Dimino + * remove colors in the manual + +Fri Sep 24 11:57:08 CEST 2010 Jeremie Dimino + * add Lwt_term.render_update + +Fri Sep 10 15:27:41 CEST 2010 Jeremie Dimino + * update the manual + +Fri Sep 10 10:37:22 CEST 2010 Stephane Glondu + * lwt_read_line: more usual behaviour for ^D + +Sun Jun 13 11:30:34 CEST 2010 Stephane Glondu + * Fix wiki syntax typo in CHANGES + +Wed Sep 8 07:41:49 CEST 2010 Jeremie Dimino + * Convert the manual to melt + +Sun Sep 5 22:17:19 CEST 2010 Jeremie Dimino + * add tests to _oasis + +Sun Sep 5 20:15:10 CEST 2010 Jeremie Dimino + * switch to OASIS + +Sun Sep 5 16:59:36 CEST 2010 Jeremie Dimino + * add an _oasis file (not yet usable) + +Sun Sep 5 10:29:35 CEST 2010 Jeremie Dimino + * add Lwt_switch to apiref-intro + +Sat Sep 4 11:46:34 CEST 2010 Jeremie Dimino + * add lwt_unix.h + +Sat Sep 4 11:46:12 CEST 2010 Jeremie Dimino + * use raise_lwt instead of fail + +Sat Sep 4 11:16:22 CEST 2010 Jeremie Dimino + * add backtrace support + +Wed Sep 1 15:24:50 CEST 2010 Jeremie Dimino + * factorize pipes internally used by lwt into a single one + +Tue Aug 31 15:59:25 CEST 2010 Jeremie Dimino + * merge optimisations for Lwt.pick and Lwt.choose + +Tue Aug 31 11:56:26 CEST 2010 chambart@crans.org + * Lwt_mmap reuse already mmaped file + +Tue Aug 31 10:49:04 CEST 2010 chambart@crans.org + * make Lwt_mmap sleeps sometimes to launch fewer threads + +Mon Aug 30 18:00:04 CEST 2010 chambart@crans.org + * allow Lwt_mmap functions to read more than one page per syscall + +Mon Aug 30 14:50:30 CEST 2010 chambart@crans.org + * optimisation of Lwt.pick + + Usualy there is only one thread ready to pick. + In this case we don't call Random.int since it is quite expensive, + even with 1 as parameter. + + +Tue Aug 31 13:13:29 CEST 2010 Jeremie Dimino + * fix local storage bugs + add tests + +Mon Aug 30 11:47:35 CEST 2010 Jeremie Dimino + * typo + + Pattern not recognized by ocaml 3.11 + +Sun Aug 29 11:34:39 CEST 2010 Jeremie Dimino + * add LWt_switch.add_hook_or_exec + +Sun Aug 29 10:55:58 CEST 2010 Jeremie Dimino + * modify Lwt_switch.add_hook and add Lwt_switch.check + +Fri Aug 27 14:28:02 CEST 2010 chambart@crans.org + * use Lwt_mmap when possible in Lwt_io + +Thu Aug 26 18:02:00 CEST 2010 chambart@crans.org + * really non blocking disk input using mmap/mincore + +Thu Aug 26 10:08:24 CEST 2010 Jeremie Dimino + * add module Lwt_switch + +Wed Aug 25 13:26:33 CEST 2010 Jeremie Dimino + * fixes to really make it works with ocaml 3.11 + +Wed Aug 25 12:48:45 CEST 2010 Jeremie Dimino + * no ocaml 3.12 features for now + +Tue Aug 24 22:34:39 CEST 2010 Jeremie Dimino + * make Lwt.join to wait for all threads to terminate, even if one fails + +Tue Aug 24 22:12:12 CEST 2010 Jeremie Dimino + * add thread local storage + +Mon Jul 5 09:15:20 CEST 2010 Jeremie Dimino + * fixes signal handling + +Fri Jul 2 11:06:52 CEST 2010 Jeremie Dimino + * make signal handling thread-safe + +Thu Jun 24 13:10:54 CEST 2010 Jeremie Dimino + * replace Lwt.select by Lwt.pick in Lwt_unix's doc + +Sun Jun 20 19:24:15 CEST 2010 Jeremie Dimino + * Do not share the reference to the cancel function in threads created with Lwt.wait + +Fri Jun 18 19:03:52 CEST 2010 Jeremie Dimino + * fix a race condition in Lwt_{event,signal}.delay + +Thu Jun 17 09:55:22 CEST 2010 Jeremie Dimino + * added Lwt_{signal,event}.delay + +Sun Jun 13 10:49:33 CEST 2010 Stephane Glondu + tagged 2.1.1 + +Sun Jun 13 10:48:02 CEST 2010 Stephane Glondu + * Prepare release 2.1.1 + +Sat Jun 12 09:00:21 CEST 2010 Jeremie Dimino + * better implementation of lwtized react functions + + Now, given [e' = operation_{s,p} f e ...], if the function [f] returns + immediatly, [e'] behaves has [operation f e], and if not it is updated + in a disjoint update cycle. + +Fri Jun 4 17:09:36 CEST 2010 Stephane Glondu + * Update CHANGES + +Sat May 29 23:05:34 CEST 2010 Jeremie Dimino + * use set_close_on_exec for fds created by Lwt_log + +Fri May 28 08:54:10 CEST 2010 Jeremie Dimino + * minor fix in Lwt.map + + It was possible that [res] was connected two times, thus raising an + exception. + +Tue May 25 12:34:31 CEST 2010 Jeremie Dimino + * change the welcome message of the toplevel + +Tue May 25 01:45:05 CEST 2010 Jeremie Dimino + * fix a fd leak in Lwt_unix.accept_n + + Now, if an error happen after connections have been accepted, they are + returned with the error. + +Fri May 21 16:48:50 CEST 2010 Jeremie Dimino + * add a patch to support the lwt syntax extension in the tuareg mode + +Mon May 10 18:51:19 CEST 2010 Jeremie Dimino + * fix a bug in Lwt.cancel + + Prevent threads from cancelling themselves recursively + +Fri May 7 10:32:26 CEST 2010 Jeremie Dimino + * make Lwt_main.call_hooks tail recursive + +Thu May 6 18:46:36 CEST 2010 Jeremie Dimino + * fix updating of the cancel function + +Thu May 6 11:15:25 CEST 2010 Jeremie Dimino + * add Lwt.nchoose and Lwt.npick + +Tue May 4 17:57:22 CEST 2010 Jeremie Dimino + * never fail when cancelling a thread + +Tue May 4 15:36:33 CEST 2010 Jeremie Dimino + * call Lwt.wakeup_paused before polling the thread in Lwt_main.run + + Otherwise, if the thread terminates in wakeup_paused, the scheduler + may wait indefinitly for nothing. + +Mon Apr 19 20:47:32 CEST 2010 Stephane Glondu + tagged 2.1.0 + +Mon Apr 19 20:47:19 CEST 2010 Stephane Glondu + * Prepare release 2.1.0 + +Sun Apr 18 08:39:18 CEST 2010 Jeremie Dimino + * do not expunge everything + +Sat Apr 17 15:30:24 CEST 2010 Jeremie Dimino + * expunge the toplevel + +Thu Apr 15 23:31:43 CEST 2010 Jeremie Dimino + * fix the logging example + +Wed Apr 14 22:19:27 CEST 2010 Stephane Glondu + * apiref-intro: increment all header levels by 1 + + ...to match the current way of handling doc on the website. + +Wed Apr 14 14:59:02 CEST 2010 Stephane Glondu + * Add possibility to override ocamldoc + +Mon Apr 12 10:01:16 CEST 2010 jerome.vouillon@pps.jussieu.fr + * Made Lwt_util.iter tail recursive + fixed bug in Lwt_util.run_in_region + +Thu Apr 1 02:04:42 CEST 2010 Jeremie Dimino + * add hacks for windows in Lwt_unix + +Mon Mar 29 14:38:10 CEST 2010 Jeremie Dimino + * add missing dependency lwt.react --> lwt + +Sun Mar 28 15:14:10 CEST 2010 Jeremie Dimino + * fix compilation of simple_top + + Remove the wrong dependency to ocaml-text + +Sun Mar 28 01:30:59 CET 2010 Jeremie Dimino + * install dlls on windows + +Sat Mar 27 15:54:13 CET 2010 Jeremie Dimino + * fix compilation under mingw32 + +Thu Mar 25 18:04:21 CET 2010 Jeremie Dimino + * css: fix copying to the documentation directory + +Thu Mar 25 11:24:36 CET 2010 Jeremie Dimino + * add/fix documentation + +Thu Mar 25 08:00:32 CET 2010 Jeremie Dimino + * css: fix color of keyword symbols + +Thu Mar 25 00:34:30 CET 2010 Jeremie Dimino + * css: highlight definitions + +Wed Mar 24 22:35:43 CET 2010 Stephane Glondu + * Minor typos in doc + +Wed Mar 24 20:38:11 CET 2010 Jeremie Dimino + * fix doc css + +Wed Mar 24 15:59:54 CET 2010 Jeremie Dimino + * a bit more doc for Lwt + +Wed Mar 24 15:59:40 CET 2010 Jeremie Dimino + * fix doc of Lwt_stream + +Wed Mar 24 11:38:06 CET 2010 Jeremie Dimino + * add category descriptions + +Wed Mar 24 11:11:14 CET 2010 Jeremie Dimino + * add a custom css + +Tue Mar 23 00:26:53 CET 2010 Jeremie Dimino + * add Lwt_signal.{bind,return} + +Mon Mar 22 20:36:48 CET 2010 Stephane Glondu + * Better titles for modules in apiref index + +Mon Mar 22 20:05:53 CET 2010 Stephane Glondu + * Categorize ocamldoc-generated API reference + +Mon Mar 22 19:27:31 CET 2010 Jeremie Dimino + * add the backlog argument to Lwt_io.establish_server + +Sun Mar 21 22:17:12 CET 2010 Stephane Glondu + * Minor fixes with doc generation + +Sun Mar 21 19:59:33 CET 2010 Stephane Glondu + * Remove Lwt_monitor + +Sun Mar 21 19:46:45 CET 2010 Jeremie Dimino + * rename lwt_core.cma to lwt.cma + + Otherwise it breaks to much things. + +Sun Mar 21 18:14:19 CET 2010 Jeremie Dimino + * add Lwt_io.system_byte_order + +Sun Mar 21 17:59:34 CET 2010 Jeremie Dimino + * logging: allow to dispatch logs according to their sections + +Sun Mar 21 01:01:14 CET 2010 Stephane Glondu + * Changelog trivia + +Sun Mar 21 00:35:56 CET 2010 Stephane Glondu + * Add module Lwt_condition + + This module promotes Lwt_monitor's conditions. Lwt_monitor now + duplicates mutexes and condition, and will most likely be removed + soon. + + +Sun Mar 21 00:35:32 CET 2010 Stephane Glondu + * Formatting changelog + +Sat Mar 20 08:48:45 CET 2010 Jeremie Dimino + * more signal helpers + +Fri Mar 19 19:13:04 CET 2010 Jeremie Dimino + * rename Lwt.select to Lwt.pick + +Wed Mar 17 08:56:07 CET 2010 Jeremie Dimino + * more event functions + +Tue Mar 16 20:54:24 CET 2010 Jeremie Dimino + * fix doc generation + +Tue Mar 16 20:31:18 CET 2010 Jeremie Dimino + * replace Lwt_main.fast_yield by Lwt.pause + +Tue Mar 16 18:28:50 CET 2010 Jeremie Dimino + * typo + +Tue Mar 16 18:24:52 CET 2010 Jeremie Dimino + * add the possibility to finalise an event/signal + +Tue Mar 16 17:07:07 CET 2010 Jeremie Dimino + * more readable ouput of tests + +Tue Mar 16 15:04:31 CET 2010 Jeremie Dimino + * add mapping functions for events and signals + +Tue Mar 16 13:42:35 CET 2010 Jeremie Dimino + * allow to cancel a [get] on a stream created with Lwt_stream.create or Lwt_event.to_stream + +Mon Mar 15 21:39:12 CET 2010 Jeremie Dimino + * replace Lwt_stream.push_stream by Lwt_stream.create + +Wed Mar 10 09:56:15 CET 2010 chambart@crans.org + * add Lwt_term.clear_line + +Sun Mar 14 22:04:07 CET 2010 Jeremie Dimino + * Various manual fixes + + Thanks to Xavier Lagorce for the tips. + +Sun Mar 14 12:01:57 CET 2010 Jeremie Dimino + * fix: inverse arguments of Unix.kill in Lwt_process + +Sat Mar 13 10:27:53 CET 2010 Jeremie Dimino + * fix tests + +Sat Mar 13 09:10:45 CET 2010 Jeremie Dimino + * add wrappers for all unix functions using file descriptors + +Fri Mar 12 21:36:08 CET 2010 Jeremie Dimino + * add wrappers for Unix.send, Unix.sendto, Unix.recv and Unix.recvfrom + +Fri Mar 12 19:40:16 CET 2010 Jeremie Dimino + * add more unix functions + +Fri Mar 12 18:10:49 CET 2010 Jeremie Dimino + * split sources into sub-directories + +Fri Mar 12 16:43:28 CET 2010 Jeremie Dimino + * put react stuff into a new sub-library named "lwt.react" + +Fri Mar 12 10:57:14 CET 2010 Jeremie Dimino + * Add a note in the manual telling it is not yet finished + +Thu Mar 11 18:53:26 CET 2010 Jeremie Dimino + * update CHANGES + +Thu Mar 11 16:58:06 CET 2010 Jeremie Dimino + * Optimisations in the Lwt module + +Thu Mar 11 00:24:56 CET 2010 Jeremie Dimino + * Better representation of removable waiters + + We do not keep a reference to the waiter function, so it can be + garbage collected before the tree is cleaned-up. + +Sat Mar 6 01:50:47 CET 2010 Jeremie Dimino + * fix connection order in Lwt.connect + +Wed Mar 3 22:26:26 CET 2010 Jeremie Dimino + * finish the first section of the manual + +Wed Mar 3 15:18:37 CET 2010 Jeremie Dimino + * add Lwt_main.at_exit + +Tue Mar 2 10:18:01 CET 2010 chambart@crans.org + * more tests of module Lwt + +Tue Mar 2 10:17:18 CET 2010 chambart@crans.org + * typos in comments + +Tue Mar 2 00:45:02 CET 2010 Jeremie Dimino + * reorganise sections of the manual + +Fri Feb 26 02:49:48 CET 2010 Jeremie Dimino + * better performances of the Lwt module + + Instead of using doubly linked lists, we use a tree and garbage + collect disabled waiters when their number reach a limit. + +Thu Feb 25 17:30:01 CET 2010 Jeremie Dimino + * add Lwt_stream.last_new + +Wed Feb 24 14:20:59 CET 2010 Jeremie Dimino + * remove the fifo hack from Lwt_io.open_file + +Wed Feb 24 11:40:13 CET 2010 Jeremie Dimino + * allow to cancel a server created with Lwt_io.establish_server + +Sun Feb 21 14:12:19 CET 2010 Jeremie Dimino + * rename Lwt_term.{save,restore}_stato to Lwt_term.{enter,leave}_drawing_mode + +Sat Feb 20 18:38:42 CET 2010 Jeremie Dimino + * add Lwt_main.fast_yield + +Fri Feb 19 11:28:11 CET 2010 Jeremie Dimino + * simplify the syntax extension for logs + + Now the lwt.syntax.log syntax extension is not required. Adding it is + just a matter of performance. + +Thu Feb 18 20:04:46 CET 2010 Jeremie Dimino + * allow to wait for log completion + +Thu Feb 18 12:53:45 CET 2010 Jeremie Dimino + * fix Lwt_{event,signal}.limit + +Thu Feb 18 08:39:52 CET 2010 Jeremie Dimino + * add Lwt_{event,signal}.limit + +Thu Feb 18 00:52:12 CET 2010 Jeremie Dimino + * Bugfix for cloned streams + +Wed Feb 17 19:34:29 CET 2010 chambart@crans.org + * add more tests for Lwt_stream.clone ( and expose a bug ) + +Wed Feb 17 18:27:01 CET 2010 chambart@crans.org + * add Lwt_stream.filter_map test + +Wed Feb 17 18:24:25 CET 2010 chambart@crans.org + * add Lwt_stream.filter test + +Wed Feb 17 18:15:28 CET 2010 chambart@crans.org + * remove old test from Makefile + +Wed Feb 17 10:11:15 CET 2010 Jeremie Dimino + * add Lwt.protected + +Tue Feb 16 16:26:05 CET 2010 Jeremie Dimino + * Add support for redirections in Lwt_process + +Tue Feb 16 15:09:15 CET 2010 Jeremie Dimino + * doc typos + +Tue Feb 16 13:56:06 CET 2010 Jeremie Dimino + * Add Lwt_daemon + +Fri Feb 12 14:01:05 CET 2010 Jeremie Dimino + * Add Lwt_io.of_string + +Fri Feb 12 13:05:29 CET 2010 Jeremie Dimino + * Do not wrap Unix_error into Sys_error + + Unix_error are more precise that Sys_error. + +Wed Feb 10 18:10:31 CET 2010 Jeremie Dimino + * caching of completion + +Wed Feb 10 17:27:47 CET 2010 Jeremie Dimino + * move Lwt_ocaml_completion and Toplevel to src/private + +Wed Feb 10 10:17:15 CET 2010 Jeremie Dimino + * make Lwt_io.pipe raise Sys_error + +Mon Feb 8 17:47:11 CET 2010 Jeremie Dimino + * automatic closing of anonymous channels + +Fri Feb 5 15:39:01 CET 2010 Jeremie Dimino + * add Lwt_term.{save,restore}_state + +Fri Feb 5 15:11:51 CET 2010 Jeremie Dimino + * better printing in Lwt_read_line + + Do not add spaces to erase text. + +Fri Feb 5 11:08:03 CET 2010 Jeremie Dimino + * close fds used for signals on exec + +Wed Feb 3 07:29:51 CET 2010 Jeremie Dimino + * add control of the internal buffer size in Lwt_io + +Wed Feb 3 07:06:50 CET 2010 Jeremie Dimino + * typo in lwt_unix_stubs.c + +Tue Feb 2 15:17:39 CET 2010 Jeremie Dimino + * fix Lwt_read_line.complete + + The suffix was ignored + +Mon Feb 1 22:08:03 CET 2010 Jeremie Dimino + * drawing helpers + +Sun Jan 31 20:30:39 CET 2010 Jeremie Dimino + * add Lwt_mutex.{is_locked,is_empty} + +Sun Jan 31 13:38:41 CET 2010 Jeremie Dimino + * add the log level "notice" + +Fri Jan 29 20:56:26 CET 2010 Jeremie Dimino + * fix Lwt_stream.get_while + +Fri Jan 29 19:56:42 CET 2010 Jeremie Dimino + * corrrectly count the number of failure in tests + +Thu Jan 28 18:55:42 CET 2010 Jeremie Dimino + * allow std* to be closed + +Thu Jan 28 18:33:44 CET 2010 Jeremie Dimino + * simpler creation of Lwt_io.std* + +Thu Jan 28 18:20:13 CET 2010 Jeremie Dimino + * do not closes channels on exit + +Sat Jan 23 22:19:20 CET 2010 Jeremie Dimino + * more doc + +Sat Jan 23 17:07:02 CET 2010 Jeremie Dimino + * doc: finish the doc of the core library + +Sat Jan 23 16:43:25 CET 2010 Jeremie Dimino + * doc: intro + core concepts + +Sat Jan 23 13:56:13 CET 2010 Jeremie Dimino + * doc for the syntax extension + +Sat Jan 23 12:22:02 CET 2010 Jeremie Dimino + * user manual skeleton + +Thu Jan 21 18:49:26 CET 2010 Jeremie Dimino + * fix Undo when the cache of previous states is too big + +Wed Jan 20 22:13:02 CET 2010 Jeremie Dimino + * add Undo command to read-line + +Mon Jan 18 16:04:03 CET 2010 Jeremie Dimino + * tests for Lwt_io + +Mon Jan 18 15:45:42 CET 2010 Jeremie Dimino + * allow auto-flushing in atomics + +Mon Jan 18 14:58:24 CET 2010 Jeremie Dimino + * Lwt_io: do not yield in the auto-flusher if the channel is busy + +Sun Jan 17 17:25:10 CET 2010 Jeremie Dimino + * add -I src/stubs for building toplevel.top + +Sun Jan 17 13:57:34 CET 2010 Jeremie Dimino + * fix backward search in read_line + +Sun Jan 17 01:12:47 CET 2010 Jeremie Dimino + * more completion in the toplevel + +Sat Jan 16 20:17:37 CET 2010 Jeremie Dimino + * enhancement of history loading/saving + + When saving the history, it is merged with the on disk history. + +Sat Jan 16 18:52:15 CET 2010 Jeremie Dimino + * udpate CHANGES + +Sat Jan 16 18:09:52 CET 2010 Jeremie Dimino + * handle {Backward,Forward}_delete_word + +Sat Jan 16 18:00:36 CET 2010 Jeremie Dimino + * use Key_control for all control keys + +Thu Jan 14 13:32:54 CET 2010 Jeremie Dimino + * uses unix file-descriptors instead of lwt ones for {recv,send}_msg + + Passed file descriptors may fails to be put in non-blocking mode, so + we let the user do the convertion if he wants to. + +Thu Jan 14 10:29:35 CET 2010 Jeremie Dimino + * move stubs into a subdirectory + +Thu Jan 14 01:39:51 CET 2010 Jeremie Dimino + * add Lwt_unix.get_credentials + +Thu Jan 14 01:39:28 CET 2010 Jeremie Dimino + * add Lwt_unix.{recv,send}_msg + +Wed Jan 13 14:57:15 CET 2010 Jeremie Dimino + * fix backward-search in read-line + +Tue Jan 12 22:39:45 CET 2010 Jeremie Dimino + * enable {forward/backward}-word in selection mode + +Tue Jan 12 19:48:04 CET 2010 Jeremie Dimino + * add Lwt_read_line.Command.Backward_kill_line + +Tue Jan 12 19:46:05 CET 2010 Jeremie Dimino + * add Lwt_read_line.Command.of_string + +Tue Jan 12 09:49:15 CET 2010 Jeremie Dimino + * deprecates module Lwt_util + +Tue Jan 12 09:46:40 CET 2010 Jeremie Dimino + * add module Lwt_list + +Mon Jan 11 22:11:32 CET 2010 Jeremie Dimino + * merge + +Mon Jan 11 08:13:51 CET 2010 chambart@crans.org + * add quite complete test for Lwt and partial test for Lwt_util + +Mon Jan 11 21:52:43 CET 2010 Jeremie Dimino + * start of unit tests + +Sat Jan 9 10:29:38 CET 2010 Jeremie Dimino + * optimisation on cancellable threads + + Use directly the list of threads to cancel with the [Temp] + constructor. + +Sat Jan 9 10:56:25 CET 2010 Jeremie Dimino + * do not launch a new thread for completion in `real_time mode + +Sat Jan 9 00:00:35 CET 2010 Jeremie Dimino + * read-line animation + +Fri Jan 8 19:07:55 CET 2010 Jeremie Dimino + * read-line fixes + +Fri Jan 8 08:56:26 CET 2010 Jeremie Dimino + * launch the auto-flusher in the optimized write_char + +Thu Jan 7 23:35:33 CET 2010 Jeremie Dimino + * fix Lwt_stream.of_event + +Thu Jan 7 18:53:08 CET 2010 Jeremie Dimino + * rewrite all read-line functions + +Thu Jan 7 16:07:34 CET 2010 Jeremie Dimino + * Lwt_stream enhancement + +Wed Jan 6 17:11:51 CET 2010 Jeremie Dimino + * handle prompt visibility in Lwt_read_line + +Wed Jan 6 14:49:53 CET 2010 Jeremie Dimino + * rewrite of the read-line engine + +Wed Jan 6 14:19:13 CET 2010 Jeremie Dimino + * include signal.h in lwt_unix_stubs.c (for SIGWINCH) + +Wed Jan 6 11:34:43 CET 2010 Jeremie Dimino + * optimize character reading/writing in Lwt_io + + Bypass the locking/unlocking phase if we can. + +Tue Jan 5 14:43:31 CET 2010 Jeremie Dimino + * change the interface of Lwt_directory + +Mon Jan 4 18:24:09 CET 2010 Jeremie Dimino + * fix Lwt_event.from + +Mon Jan 4 11:53:57 CET 2010 Jeremie Dimino + * add Lwt_event.from + +Sun Jan 3 21:58:36 CET 2010 Jeremie Dimino + * add Lwt_read_line.Terminal.erase + +Sat Jan 2 15:46:36 CET 2010 Jeremie Dimino + * fix building of documentation + +Tue Dec 29 23:39:57 CET 2009 Jeremie Dimino + * added Lwt_event.next + +Tue Dec 29 23:16:34 CET 2009 Jeremie Dimino + * typo in _tags: use_C_glic instead of use_C_glib + +Wed Dec 23 20:03:25 CET 2009 Jeremie Dimino + * bypass the FD_SETSIZE limitation of the libc + +Wed Dec 23 19:39:20 CET 2009 Jeremie Dimino + * fix examples/logging.ml + +Tue Dec 22 10:15:02 CET 2009 Jeremie Dimino + * better implementation of Lwt_unix.daemonize + +Mon Dec 21 23:18:37 CET 2009 Jeremie Dimino + * simplify the Lwt_log module + +Sat Dec 19 13:12:27 CET 2009 Jeremie Dimino + * add Lwt_io.establish_server + +Thu Dec 17 18:40:17 CET 2009 Jeremie Dimino + * exit with code 0 in Lwt_unix.daemoniaz + +Wed Dec 16 17:13:22 CET 2009 Jeremie Dimino + * force cooperation for file descriptors that do not support non-blocking I/Os + +Wed Dec 16 17:03:32 CET 2009 Jeremie Dimino + * Lwt_io.of_fd takes now a optionnal close function + + It allow to handle the case where we want that closing the channel + keep the file descriptor open. Now we can do: + + Lwt_io.of_fd ~close:Lwt.return ~mode:... + + +Wed Dec 16 17:02:14 CET 2009 Jeremie Dimino + * add module Lwt_directory + +Wed Dec 16 17:00:32 CET 2009 Jeremie Dimino + * add Lwt_unix.auto_yield + + Its goal is to force cooperation when it is not possible to have + non-blocking I/O. + +Wed Nov 25 19:26:30 CET 2009 Jeremie Dimino + * fix the example of use of "... >> ..." + +Sat Nov 21 23:19:50 CET 2009 Jeremie Dimino + * replace some ">... >> ..." by "lwt _ = ... in ..." + + It is much readable with the second construction than with the first + one. + +Sat Nov 21 00:13:49 CET 2009 Jeremie Dimino + * fix a fd leak in Lwt_io.open_connection + +Tue Nov 17 18:50:15 CET 2009 Jeremie Dimino + * removes the use of signalfd + + It is too much complicated to detect when it is really available and + working, and is linux-specific. We use now the classical hack which + consist on writing to a pipe when a signal come. + +Mon Nov 16 14:37:38 CET 2009 Jeremie Dimino + * add functions to navigate in the completion bar + +Mon Nov 16 11:24:55 CET 2009 Jeremie Dimino + * put completions into a table + + This remove ambiguity when a commpletion contains spaces. + +Mon Nov 16 10:11:11 CET 2009 Jeremie Dimino + * export helpers for drawing engine state on the terminal + +Mon Nov 16 09:26:50 CET 2009 Jeremie Dimino + * add comments in examples + +Mon Nov 16 10:37:45 CET 2009 chambart@crans.org + * stream functions (mapping and peeking) + +Mon Nov 16 10:06:13 CET 2009 chambart@crans.org + * pushable streams + +Sun Nov 15 21:41:20 CET 2009 Jeremie Dimino + * add two examples + +Sun Nov 15 21:10:23 CET 2009 Jeremie Dimino + * Refactoring of Lwt_read_lnie + + More code sharing between the read-line functions.. + +Sun Nov 15 12:21:29 CET 2009 Jeremie Dimino + * use sets instead of list for completion + +Fri Nov 13 21:35:02 CET 2009 Jeremie Dimino + * fix completion printing + +Fri Nov 13 18:59:37 CET 2009 Jeremie Dimino + * fix completion printing + +Fri Nov 13 18:06:49 CET 2009 Jeremie Dimino + * allow the prompt in read-line to be a signal + + This can be used to recompute the prompt when the terminal sizes + change. + +Fri Nov 13 17:39:42 CET 2009 Jeremie Dimino + * implement reverse search in read-line + +Fri Nov 13 09:34:09 CET 2009 Jeremie Dimino + * reset attributes before printing the prompt + +Fri Nov 13 08:40:25 CET 2009 Jeremie Dimino + * better completion on directives + +Thu Nov 12 22:27:26 CET 2009 Jeremie Dimino + * write naviguation inside completion + +Thu Nov 12 17:54:40 CET 2009 Jeremie Dimino + * rewrite Lwt_read_line.read_keyword + +Thu Nov 12 16:33:50 CET 2009 Jeremie Dimino + * rewrite of Lwt_read_line.read_line with reactive programming + +Thu Nov 12 09:24:12 CET 2009 Jeremie Dimino + * plop + +Wed Nov 11 21:18:27 CET 2009 Jeremie Dimino + * allow moves in the completion bar + +Wed Nov 11 17:51:39 CET 2009 Jeremie Dimino + * new completion type + +Tue Nov 10 14:21:40 CET 2009 Jeremie Dimino + * style + + Replace some "a >> b" by "lwt () = a in b" + +Tue Nov 10 08:44:37 CET 2009 Jeremie Dimino + * typo + +Tue Nov 10 08:24:48 CET 2009 Jeremie Dimino + * drop debugging messages by default + +Tue Nov 10 08:21:00 CET 2009 Jeremie Dimino + * logging enhancement + +Tue Nov 10 08:39:07 CET 2009 Jeremie Dimino + * fix generated code when debugging messages are disabled + +Tue Nov 10 08:01:12 CET 2009 Jeremie Dimino + * fix order of arguments in pa_log + +Mon Nov 9 20:36:05 CET 2009 Jeremie Dimino + * logging enhancement + +Mon Nov 9 20:27:31 CET 2009 Jeremie Dimino + * put daemonize in Lwt_unix + + Lwt_util is in the "lwt" package, so it should not depends on Unix. + +Sun Nov 8 08:01:34 CET 2009 Jeremie Dimino + * typo in myocamlbuild.ml + + The "dep" function expect a list of tags, not filenames + +Sat Nov 7 10:28:44 CET 2009 Jeremie Dimino + * add module name in logged messages + +Sat Nov 7 09:04:43 CET 2009 Jeremie Dimino + * added pa_log for logging messages + +Sat Nov 7 06:22:05 CET 2009 Jeremie Dimino + * typo + + lwt_clear_all_fs -> lwt_close_all_fds + +Fri Nov 6 23:33:18 CET 2009 Jeremie Dimino + * Adding function Lwt_util.daemonize + +Fri Nov 6 23:29:25 CET 2009 Jeremie Dimino + * Adding module Lwt_log + +Sun Nov 1 12:22:05 CET 2009 Jeremie Dimino + * adding module Lwt_log + + Lwt_log allows to log messages through syslog in cooperative way. + +Sun Oct 25 06:02:40 CET 2009 Jeremie Dimino + * enhancement in Lwt_process + + - add timeouts + - add more functions to the default process class + +Sun Oct 25 05:15:07 CET 2009 Jeremie Dimino + * replaces run_and_read in myocamlbuild.ml + +Sun Oct 25 05:03:44 CET 2009 Jeremie Dimino + * add Lwt_unix.wait4 + + Thanks to Mauricio Fernandez for the patch. + +Tue Oct 20 12:38:11 CEST 2009 Jeremie Dimino + * bugfix in Lwt_unix.connect + + Raises [Retry] on EINPROGRESS error. + +Sun Oct 18 07:28:09 CEST 2009 Jeremie Dimino + * update changes + +Fri Oct 16 09:40:25 CEST 2009 Jeremie Dimino + * bugfixes in lwt.glib + + - POLLIN, POLLOUT and POLLERR were not initialised correctly + - returned events were not set correctly (a Val_int was missing) + - the result of the poll function was incorrect + +Fri Oct 16 09:40:15 CEST 2009 Jeremie Dimino + * fix the "all" target in examples' Makefile + +Thu Oct 15 23:02:57 CEST 2009 Stephane Glondu + tagged 2.0.0 + +Thu Oct 15 23:02:21 CEST 2009 Stephane Glondu + * Prepare release 2.0.0 + +Mon Oct 12 12:13:20 CEST 2009 Jeremie Dimino + * Allow the "lwt x1 = e1 and x2 = e2 ..." construction at the toplevel + + Translate "lwt x1 = e1" to "let x1 = Lwt_main.run e1" and so. Very + usefull in the toplevel. + +Sat Oct 10 20:00:16 CEST 2009 Jeremie Dimino + * add events and signals utilities + +Sat Oct 3 16:01:13 CEST 2009 Jeremie Dimino + * more read-line functions + +Sat Oct 3 16:38:05 CEST 2009 Jeremie Dimino + * fix: close also stderr in Lwt_process.process_full#close + +Sat Oct 3 04:45:59 CEST 2009 Jeremie Dimino + * add lwt.unix to examples' myocamlbuild.ml + +Fri Oct 2 23:49:16 CEST 2009 Stephane Glondu + * Documentation for Lwt_throttle + +Fri Oct 2 23:39:43 CEST 2009 Stephane Glondu + * Generate documentation for lwt_unix + +Tue Sep 29 15:36:34 CEST 2009 Stephane Glondu + * Fix dependencies in META.in + +Sat Sep 26 01:13:20 CEST 2009 Stephane Glondu + tagged 2.0.0+rc1 + +Fri Sep 25 22:20:24 CEST 2009 Stephane Glondu + * Prepare release candidate + +Fri Sep 25 22:18:40 CEST 2009 Stephane Glondu + * Update CHANGES + +Fri Sep 25 20:21:53 CEST 2009 Jeremie Dimino + * remove lwt->unix dependency from META.in + +Fri Sep 25 11:45:14 CEST 2009 Jeremie Dimino + * remove lwt.withoutunix and add lwt.unix + + Remove unix dependencies from the main lwt and put them into a + subpackage lwt.unix. + +Wed Sep 23 18:44:58 CEST 2009 Jeremie Dimino + * use CAML* macro in C bindings + +Wed Sep 23 11:05:48 CEST 2009 Stephane Glondu + * Update CHANGES and README + +Fri Sep 11 22:19:49 CEST 2009 Jeremie Dimino + * include missing header in lwt_unix_stubs.c + +Sun Aug 30 19:31:51 CEST 2009 Stephane Glondu + * Fix META.in so that lwt exists on bytecode architectures + +Thu Aug 20 16:47:14 CEST 2009 Stephane Glondu + * Fix build on bytecode architectures + +Wed Aug 5 17:55:18 CEST 2009 balat at pps.jussieu.fr + * Adding missing mllib + +Tue Aug 4 19:32:20 CEST 2009 balat at pps.jussieu.fr + * Creating a cma without unix + plus small typos corrected + +Fri Jul 24 15:58:06 CEST 2009 Jeremie Dimino + * better catching of errors for the creation of the signal file descriptor + +Tue Jul 21 14:00:40 CEST 2009 Jeremie Dimino + * fix linking of the enhanced toplevel + +Mon Jul 20 12:13:57 CEST 2009 Jeremie Dimino + * fix the for_lwt syntax extension + +Sat Jul 18 18:45:48 CEST 2009 Jeremie Dimino + * do not fail if signalfd fails + +Thu Jul 9 14:47:30 CEST 2009 Jeremie Dimino + * do not allocate resources for sigchld handling lazilly + +Tue Jul 7 22:50:27 CEST 2009 Jeremie Dimino + * new toplevel with completion on identifiers + completion on directories and files + +Tue Jul 7 19:13:38 CEST 2009 Jeremie Dimino + * completion on findlib packages + +Tue Jul 7 19:13:17 CEST 2009 Jeremie Dimino + * syntax extension for 'for' blocks with lwt + +Tue Jul 7 19:12:38 CEST 2009 Jeremie Dimino + * readline display fixes and enhancement + +Mon Jun 15 02:19:27 CEST 2009 Jeremie Dimino + * changes the build system + + Put all rules into the ocamlbuild plugin and test for the presence of signalfd. + +Wed Jun 10 15:11:30 CEST 2009 vouillon at pps.jussieu.fr + * Separate the type of threads (covariant) from the type of thread wakeners (contravariant) + +Sun Jun 7 00:54:24 CEST 2009 Jeremie Dimino + * typos + +Sun Jun 7 00:34:28 CEST 2009 Jeremie Dimino + * handle signals with react + +Thu Jun 4 02:50:19 CEST 2009 Jeremie Dimino + * fix in Lwt_preemptive and Lwt_sequence + +Mon Jun 1 19:53:42 CEST 2009 Jeremie Dimino + * typo + +Mon Jun 1 16:57:48 CEST 2009 Jeremie Dimino + * Better reimplementation of Lwt_dlist and use it wherever cancellable tasks are possible + +Mon Jun 1 16:51:25 CEST 2009 Jeremie Dimino + * allow to switch between blocking and nonblocking mode for a file descriptor + +Thu May 28 09:40:21 CEST 2009 Jeremie Dimino + * allow file descriptors to be used in blocking mode + +Wed May 27 18:38:11 CEST 2009 balat at pps.jussieu.fr + * Lwt_pool: fixing race condition in create_member + +Wed May 27 16:16:37 CEST 2009 vouillon at pps.jussieu.fr + * Fixed MVar implementation: writers were never awaken + +Wed May 27 15:07:03 CEST 2009 vouillon at pps.jussieu.fr + * Put standard file descriptors in non-blocking mode only if really required + +Wed May 27 10:19:23 CEST 2009 Jeremie Dimino + * handling of FIFOs in Lwt_io + +Wed May 27 10:19:09 CEST 2009 Jeremie Dimino + * small fix in [try_lwt] syntax extension + +Tue May 26 16:58:02 CEST 2009 vouillon at pps.jussieu.fr + * Fixed binary int endianness in lwt_chan.ml + +Mon May 25 14:43:41 CEST 2009 Jeremie Dimino + * generalizes hexdump + +Mon May 25 13:28:56 CEST 2009 Jeremie Dimino + * bugfix in Lwt_unix.sleep + + Thanks to Pierre Chambart for the report + +Mon May 25 11:20:37 CEST 2009 Jeremie Dimino + * documentation for Lwt_unix + +Mon May 25 10:20:54 CEST 2009 Jeremie Dimino + * Lwt_io maps all Unix_error into Sys_error like the standard library + +Mon May 25 01:24:42 CEST 2009 Jeremie Dimino + * rename private modules to avoid name clashes with other libraries + +Mon May 25 01:10:49 CEST 2009 Jeremie Dimino + * implement the normal semantic for mailbox variables + +Mon May 25 00:52:01 CEST 2009 Jeremie Dimino + * put conditions into Lwt_monitor and fix some bugs + + Lwt_condition is not useful on its own + +Mon May 25 00:39:31 CEST 2009 Jeremie Dimino + * remove Lwt_queue + + Not well tested nor really useful + +Mon May 25 00:36:44 CEST 2009 Jeremie Dimino + * cancelable threads + +Sun May 24 18:49:25 CEST 2009 Jeremie Dimino + * do not use stubs on non-unix system + +Fri May 22 21:19:18 CEST 2009 Jeremie Dimino + * do not add duplicated lines in history + +Wed May 20 22:23:51 CEST 2009 Jeremie Dimino + * save/load history in the toplevel + +Wed May 20 22:16:43 CEST 2009 Jeremie Dimino + * added toplevel integration for when ocaml-text is missing + +Tue May 19 17:01:30 CEST 2009 Stephane Glondu + * Fix compilation when ocamlopt is missing + +Tue May 19 15:29:51 CEST 2009 Jeremie Dimino + * update CHANGES + +Tue May 19 15:27:49 CEST 2009 Jeremie Dimino + * add license wherever missing + +Tue May 19 15:21:22 CEST 2009 Jeremie Dimino + * Lwt_preemptive: refactoring + simplify its use + +Tue May 19 00:26:22 CEST 2009 Jeremie Dimino + * better mutexes + + Do not wakeup everybody on unlock, only the first waiter. + +Mon May 18 21:21:20 CEST 2009 Jeremie Dimino + * fix a bug in Lwt_io.read_all + +Mon May 18 20:47:49 CEST 2009 Jeremie Dimino + * Lwt_io.hexdump + +Mon May 18 17:13:57 CEST 2009 Jeremie Dimino + * remove Lwt_term.write_sequence + + Useless since the last flush bugfix. + +Mon May 18 16:55:18 CEST 2009 Jeremie Dimino + * fix a bug in Lwt_io.perform_io + + on partial flush, remaining data where not shifted. + +Mon May 18 16:29:57 CEST 2009 Jeremie Dimino + * makes *.open_* raise Sys_error instead of Unix_error + +Mon May 18 14:24:39 CEST 2009 Jeremie Dimino + * fix a bug in *.read_line + + empty lines were not returned correctly. + +Mon May 18 14:01:28 CEST 2009 Jeremie Dimino + * fix _tags + + put pkg_text only for modules needing it. + +Mon May 18 13:56:02 CEST 2009 Jeremie Dimino + * New sub-package lwt.text + + put all ocaml-text dependent modules into a separate package. + +Sun May 17 23:31:00 CEST 2009 Jeremie Dimino + * typo + +Sun May 17 22:46:13 CEST 2009 Jeremie Dimino + * split byte channels and text channels + +Sun May 17 17:15:04 CEST 2009 Jeremie Dimino + * move Pqueue into src/private + +Thu May 14 01:04:11 CEST 2009 Jeremie Dimino + * do not fail whan standard(s) in/output(s) are closed + +Wed May 13 19:19:21 CEST 2009 Jeremie Dimino + * prevent Lwt_preemptive.dispatch from failing when the pipe is closed + +Wed May 13 15:24:05 CEST 2009 Stephane Glondu + * Convert README to UTF-8 and add Warren Harris to authors + +Wed May 13 15:19:20 CEST 2009 Stephane Glondu + * Add exists_if to META file to allow partial installation + +Wed May 13 15:18:39 CEST 2009 Stephane Glondu + * Fix ocamldoc comments in Metaweb's files + +Wed May 13 14:55:09 CEST 2009 Stephane Glondu + * CHANGES formatting + +Tue May 12 23:27:28 CEST 2009 Jeremie Dimino + * add META to byte and native targets + +Tue May 12 22:13:56 CEST 2009 Jeremie Dimino + * add Lwt_mutex.with_mutex + + Thanks to Warren Harris for the patch + +Tue May 12 22:05:07 CEST 2009 Jeremie Dimino + * documentation for Lwt_{condition,mvar,monitor} + + Thanks to Warren Harris for the patch + +Tue May 12 10:28:11 CEST 2009 Jeremie Dimino + * added Warren Harris synchronisation modules' + +Tue May 12 09:34:33 CEST 2009 Jeremie Dimino + * better terminal rendering + +Tue May 12 07:52:11 CEST 2009 Jeremie Dimino + * Apply Warren Harris patch to handle pool member creation failure + +Tue May 12 00:30:41 CEST 2009 Jeremie Dimino + * use iconv transliteration features + +Mon May 11 17:53:06 CEST 2009 Jeremie Dimino + * fix Lwt_term.render + + workaround + +Mon May 11 14:37:46 CEST 2009 Jeremie Dimino + * remove Lwt_io.force_flush + +Mon May 11 13:57:49 CEST 2009 Jeremie Dimino + * fix documentation generation + + (temporary) workaround... + +Mon May 11 13:14:43 CEST 2009 Jeremie Dimino + * add light colors + +Mon May 11 02:15:52 CEST 2009 Jeremie Dimino + * inplementation of lwt_unix_term_size for windows + +Sun May 10 20:55:18 CEST 2009 Jeremie Dimino + * new example parallelize + +Sun May 10 20:52:48 CEST 2009 Jeremie Dimino + * build process enhancement + + * the makefile check for installed libraries + and activate the compilation of sub-packages + according to the result + * examples are compiled using ocamlbuild + +Thu May 7 23:51:28 CEST 2009 Jeremie Dimino + * more documentation + +Thu May 7 21:45:26 CEST 2009 Jeremie Dimino + * fixes in Lwt_unix.accept_n + +Thu May 7 11:21:52 CEST 2009 kerneis@pps.jussieu.fr + * Lwt_unix: accept_n + +Wed May 6 15:28:51 CEST 2009 Jeremie Dimino + * More suitable type for the completion function + + Now it can be aborted. + +Wed May 6 00:33:01 CEST 2009 Jeremie Dimino + * naming convention, small bug fixes and documentation + +Tue May 5 18:50:04 CEST 2009 Jeremie Dimino + * More functions in [Lwt_process] + +Tue May 5 17:52:27 CEST 2009 Jeremie Dimino + * Allow reuse of the readline engine + + Split the implementation into several reusable modules, so if at some + point somebody wants to implement a widget library using Lwt, it can + reuse them. + +Tue May 5 01:56:20 CEST 2009 Jeremie Dimino + * More on read-line + + * support of copy-pasting text + * added variant of read_line (read_password, read_yes_no, ...) + +Mon May 4 13:31:00 CEST 2009 Jeremie Dimino + * package encoding --> package text + +Mon May 4 13:01:54 CEST 2009 Jeremie Dimino + * use [Text.to_ascii] as default fallback function + +Mon May 4 12:27:09 CEST 2009 Jeremie Dimino + * various enhancement + + * better behaviour of *print* functions + * rename Lwt_term.get_key to Lwt_term.read_key since + it is a ``text'' function + * Lwt_read_line.read_line defaults to Lwt_io.read_line + when input is not a tty + * added sample init file utils/ocamlinit + +Mon May 4 09:52:25 CEST 2009 Jeremie Dimino + * better names for printing functions + +Mon May 4 08:55:25 CEST 2009 Jeremie Dimino + * update CHANGES + +Mon May 4 08:43:59 CEST 2009 Jeremie Dimino + * more helpers + +Sun May 3 19:54:47 CEST 2009 Jeremie Dimino + * deal with character encodings at the channel level + +Sun May 3 21:37:10 CEST 2009 balat at pps.jussieu.fr + * (small patch) changing CHANGES format for inclusion in ocsigen.org's wiki + +Sun May 3 10:47:03 CEST 2009 Jeremie Dimino + * new module Lwt_printf + +Sun May 3 10:45:42 CEST 2009 Jeremie Dimino + * readline and line editing support for the toplevel + +Fri May 1 11:49:41 CEST 2009 Jeremie Dimino + * Change the behaviour of ">>" + + Make it behaves as normal operators, otherwise strange things can + happen. + +Thu Apr 30 20:53:33 CEST 2009 Jeremie Dimino + * new module Lwt_stream + +Thu Apr 30 15:47:52 CEST 2009 Jeremie Dimino + * Syntax extension improvement + + It is now easy to migrates to the lwt world! + + a; b --> a >> b + let x = m in e --> lwt x = m in e + try x with ... --> try_lwt x with ... + +Thu Apr 30 14:07:19 CEST 2009 Jeremie Dimino + * integration with the toplevel + +Thu Apr 30 13:35:11 CEST 2009 Jeremie Dimino + * Better implementation of [join] + + When one thread fails, it fails without waiting for the + termination of other threads. + +Wed Apr 29 17:27:34 CEST 2009 Jeremie Dimino + * glib integration + +Tue Apr 28 22:43:42 CEST 2009 Jeremie Dimino + * forein event-loop integration + +Sun Apr 19 23:32:50 CEST 2009 Jeremie Dimino + * use the ``try_lwt'' construction + +Sun Apr 19 20:46:21 CEST 2009 Jeremie Dimino + * allow ``try_lwt'' without ``with'' or ``finally'' + + This just catch normal exception. + +Fri Apr 17 11:32:26 CEST 2009 Jeremie Dimino + * update CHANGES + +Fri Apr 17 11:15:42 CEST 2009 Jeremie Dimino + * -custom is deprecated + +Fri Apr 17 05:11:43 CEST 2009 Jeremie Dimino + * add a syntax extension + +Thu Apr 16 01:06:09 CEST 2009 Jeremie Dimino + * stubs for [read] and [write] + + Simplified and optimised version using the fact that reading/writing + never block. + +Wed Apr 15 23:46:16 CEST 2009 Jeremie Dimino + * add Lwt_process module + +Wed Apr 15 22:55:18 CEST 2009 Jeremie Dimino + * add Lwt_io module + + Lwt_io is a new implementation of buffered channels which replaces + Lwt_chan. The latter is kept for compatibility and not simply replaced + to avoid name clashes: both modules define an [input] and an [output] + field but semantics are different. + +Wed Apr 15 16:06:27 CEST 2009 Jeremie Dimino + * add Lwt_gc and Lwt_exit_hook modules + +Tue Apr 14 20:44:31 CEST 2009 Jeremie Dimino + * add the pa_monad syntax extension + +Tue Apr 14 16:13:29 CEST 2009 Jeremie Dimino + * build process enhancement + + - generate everything with ocamlbuild + - call ocamlbuild only one time in the Makefile + - generate lwt.odocl to avoid duplication of the list of modules + +Mon Apr 13 16:48:51 CEST 2009 Jeremie Dimino + * allow the user to check the state of a thread + +Mon Apr 13 16:42:22 CEST 2009 Jeremie Dimino + * [Lwt.choose] do not leak memory anymore + + When a choose terminates, it removes all unneeded waiters. + +Sun Apr 12 13:24:53 CEST 2009 Jeremie Dimino + * better representation of threads + + [waiters = CNil] iff [state = Sleep]. + +Sat Jan 10 20:14:44 CET 2009 Stephane Glondu + * Add Lwt_throttle module + +Fri Dec 19 16:43:07 CET 2008 balat at pps.jussieu.fr + * Changing the default number of preemptive threads queued + +Wed Dec 3 02:27:19 CET 2008 Jeremie Dimino + * Better implementation of Lwt_chan.output_char + +Tue Jul 15 14:41:39 CEST 2008 Stephane Glondu + * Precisions in source headers + +Wed Jul 9 13:02:00 CEST 2008 Stephane Glondu + * Bugfix in Lwt_chan.close_* (ticket #66) + +Wed Jun 25 17:23:11 CEST 2008 Stephane Glondu + tagged 1.1.0 + +Wed Jun 25 17:23:02 CEST 2008 Stephane Glondu + * Prepare release + +Wed Jun 25 17:20:29 CEST 2008 Stephane Glondu + * changelog.darcs -> CHANGES.darcs + +Sun Jun 22 18:08:37 CEST 2008 Stephane Glondu + * Splitting out Lwt_preemptive and Lwt_ssl + They are put into separate archives and findlib packages so that lwt + depends only on unix (suggestion from Jerome Vouillon). As a side + effect, creation of lwt_extra, which contains only Lwt_lib for now, + because it uses Lwt_preemptive. + +Fri Jun 20 20:11:32 CEST 2008 Stephane Glondu + * Add CHANGES + CHANGES is in Wikicreole syntax and is used to display the changelog + on ocsigen.org. Ship darcs changelog in changelog.darcs. + +Sun Jun 8 22:13:23 CEST 2008 Stephane Glondu + * Exporting open_in_gen and open_out_gen from Lwt_chan + Request from Serge Leblanc + +Mon May 26 11:57:34 CEST 2008 Stephane Glondu + * Add description to META.in + +Sun May 25 13:17:45 CEST 2008 Stephane Glondu + * Move source files to src/ directory + +Sun May 25 13:08:36 CEST 2008 Stephane Glondu + * Set up build system + +Sun May 25 13:03:49 CEST 2008 Stephane Glondu + * Fix relay example + +Sun May 25 12:52:03 CEST 2008 Stephane Glondu + * README, COPYING, LICENSE + +Sun May 25 01:21:45 CEST 2008 Stephane Glondu + * Source file headers + +Sat May 24 20:07:48 CEST 2008 Stephane Glondu + * Initial import from Ocsigen repository diff --git a/thirdparty/lwt-2.3.2/COPYING b/thirdparty/lwt-2.3.2/COPYING new file mode 100644 index 0000000..97f4496 --- /dev/null +++ b/thirdparty/lwt-2.3.2/COPYING @@ -0,0 +1,552 @@ +This program is released under the LGPL version 2.1 (see the text below) with +the additional exemption that compiling, linking, and/or using OpenSSL is +allowed. + +As a special exception to the GNU Library General Public License, you +may also link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute +that executable file under terms of your choice, without any of the +additional requirements listed in clause 6 of the GNU Library General +Public License. By "a publicly distributed version of the Library", +we mean either the unmodified Library, or a +modified version of the Library that is distributed under the +conditions defined in clause 3 of the GNU Library General Public +License. This exception does not however invalidate any other reasons +why the executable file might be covered by the GNU Library General +Public License. + +Some parts, when stated (as licenced under BSD3) are licenced under +3-clauses or Modified BSD License. + + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + +====== BSD3 or Modified BSD License ====== + +Copyright (c) , +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/thirdparty/lwt-2.3.2/LICENSE b/thirdparty/lwt-2.3.2/LICENSE new file mode 100644 index 0000000..0e5e324 --- /dev/null +++ b/thirdparty/lwt-2.3.2/LICENSE @@ -0,0 +1,4 @@ +The Ocsigen application core, and other portions of the official Ocsigen +distribution not explicitly licensed otherwise, are licensed under +the GNU LESSER GENERAL PUBLIC LICENSE with openssl linking exception +-- see the 'COPYING' file in this directory for details. diff --git a/thirdparty/lwt-2.3.2/Makefile b/thirdparty/lwt-2.3.2/Makefile new file mode 100644 index 0000000..68f2e0e --- /dev/null +++ b/thirdparty/lwt-2.3.2/Makefile @@ -0,0 +1,38 @@ +# OASIS_START +# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb) + +SETUP = ocaml setup.ml + +build: setup.data + $(SETUP) -build $(BUILDFLAGS) + +doc: setup.data build + $(SETUP) -doc $(DOCFLAGS) + +test: setup.data build + $(SETUP) -test $(TESTFLAGS) + +all: + $(SETUP) -all $(ALLFLAGS) + +install: setup.data + $(SETUP) -install $(INSTALLFLAGS) + +uninstall: setup.data + $(SETUP) -uninstall $(UNINSTALLFLAGS) + +reinstall: setup.data + $(SETUP) -reinstall $(REINSTALLFLAGS) + +clean: + $(SETUP) -clean $(CLEANFLAGS) + +distclean: + $(SETUP) -distclean $(DISTCLEANFLAGS) + +setup.data: + $(SETUP) -configure $(CONFIGUREFLAGS) + +.PHONY: build doc test all install uninstall reinstall clean distclean configure + +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/README b/thirdparty/lwt-2.3.2/README new file mode 100644 index 0000000..7b64477 --- /dev/null +++ b/thirdparty/lwt-2.3.2/README @@ -0,0 +1,74 @@ +Lwt: lightweight thread library for Objective Caml + +-------------------------------------------------------------------------- + +This library is part of the Ocsigen project. See: + + http://ocsigen.org/lwt + +-------------------------------------------------------------------------- + +Requirements: + + * ocaml with ocamlbuild (>= 3.11.0) + * findlib + * react (from http://erratique.ch/software/react) + * [optionnal] libev (from http://software.schmorp.de/pkg/libev.html) + * [optionnal] ocaml-text (needed for the enhanced toplevel) + * [optionnal] ocamlssl (>= 0.4.0) (ocamlssl needs openssl) (>= 0.4.1 for MacOS) + * [optionnal] glib-2.0 developpement files and pkg-config + +If ocaml/findlib/ocamlssl... are not installed on your computer, you +can use GODI to install them automatically. See: + + http://godi.camlcity.org/godi/index.html + +They might also be available through your distribution. + +-------------------------------------------------------------------------- + +Instructions: + + * run "ocaml setup.ml -configure" to configure sources + You can add '--enable-' to enable compilation of + the sub-library . The flag '--enable-all' will + enable everything. + In order to compile without libev support you must add + '--disable-libev'. + * run "ocaml setup.ml -build" to compile + * run "ocaml setup.ml -install" as root to install compiled libraries + * run "ocaml setup.ml -uninstall" as root to uninstall them + +HTML documentation is generated in _build/lwt.docdir/, but is not +installed by default. + +If you get the development version you need to obtain oasis +(http://oasis.forge.ocamlcore.org/). + +If you want to build the toplevel you have to install compiler +libraries, under debian it is the package +ocaml-compiler-libs. Otherwise you can add a symlink like that: + + $ ln -s $(ocamlc -where)/compiler-libs + +Note that the utop project replaces the Lwt toplevel: + + https://forge.ocamlcore.org/projects/utop/ + +-------------------------------------------------------------------------- + +Authors: + + * Jérôme Vouillon + * Vincent Balat + * Nataliya Guts + * Pierre Clairambault + * Stéphane Glondu + * Jérémie Dimino + * Warren Harris (Metaweb Technologies, Inc.) + * Pierre Chambart + * Mauricio Fernandez + +See each source file for copyright information, and COPYING for license. + +-------------------------------------------------------------------------- diff --git a/thirdparty/lwt-2.3.2/_oasis b/thirdparty/lwt-2.3.2/_oasis new file mode 100644 index 0000000..04c026a --- /dev/null +++ b/thirdparty/lwt-2.3.2/_oasis @@ -0,0 +1,383 @@ +# +-------------------------------------------------------------------+ +# | Package parameters | +# +-------------------------------------------------------------------+ + +OASISFormat: 0.1 +OCamlVersion: >= 3.12 +Name: lwt +Version: 2.3.2 +LicenseFile: COPYING +License: LGPL-2.1 with OCaml linking exception +Authors: + Jérôme Vouillon, + Vincent Balat, + Nataliya Guts, + Pierre Clairambault, + Stéphane Glondu, + Jérémie Dimino, + Warren Harris, + Pierre Chambart, + Mauricio Fernandez +Homepage: http://ocsigen.org/lwt/ +BuildTools: ocamlbuild +Plugins: DevFiles (0.2), META (0.2) +PostConfCommand: ocaml discover.ml -ocamlc $ocamlc -ext-obj $ext_obj -exec-name $default_executable_name -use-libev $libev -os-type $os_type +PostDistCleanCommand: $rm src/unix/lwt_config.h src/unix/lwt_config.ml + +Synopsis: Lightweight thread library for Objective Caml +Description: + Lwt is a library of cooperative threads implemented in monadic + style. With respect to preemptive threads, cooperative threads are + not using a scheduler to distribute processor time between + threads. Instead of this, each thread must tell the others that he + wants to let them work. + +# +-------------------------------------------------------------------+ +# | Flags | +# +-------------------------------------------------------------------+ + +Flag all + Description: build and install everything + Default: false + +Flag unix + Description: Unix support + Default: true + +Flag react + Description: React helpers + Default: false + +Flag glib + Description: Glib integration + Default: false + +Flag ssl + Description: SSL support + Default: false + +Flag text + Description: Text mode utilities + Default: false + +Flag preemptive + Description: Preemptive threads support + Default: true + +Flag extra + Description: Asynchronous unix functions + Default: true + +Flag toplevel + Description: Enhanced toplevel + Default: false + +Flag libev + Description: Compile with libev support + Default$: !os_type(Win32) + +# +-------------------------------------------------------------------+ +# | Libraries | +# +-------------------------------------------------------------------+ + +Library "optcomp" + Install: false + Path: syntax + Modules: Pa_optcomp + BuildDepends: camlp4.lib, camlp4.quotations.o + +Library "lwt" + Path: src/core + Modules: + Lwt_condition, + Lwt_list, + Lwt, + Lwt_mutex, + Lwt_mvar, + Lwt_pool, + Lwt_sequence, + Lwt_stream, + Lwt_switch, + Lwt_util, + Lwt_pqueue + XMETADescription: Lightweight thread library for OCaml (core library) + +Library "lwt-unix" + Build$: flag(unix) || flag(all) + Install$: flag(unix) || flag(all) + FindlibName: unix + FindlibParent: lwt + Path: src/unix + Modules: + Lwt_chan, + Lwt_daemon, + Lwt_gc, + Lwt_io, + Lwt_log, + Lwt_main, + Lwt_process, + Lwt_throttle, + Lwt_timeout, + Lwt_unix, + Lwt_sys, + Lwt_engine, + Lwt_bytes + InternalModules: + Lwt_log_rules + BuildDepends: lwt, unix, bigarray + XMETADescription: Unix support for lwt + CSources: + lwt_config.h, + lwt_unix.h, + lwt_unix_stubs.c, + lwt_libev_stubs.c + if os_type(Win32) + CCLib+: ws2_32.lib + else + CCLib+: -lpthread + if flag(libev) + CCLib+: -lev + +Library "lwt-simple-top" + Build$: flag(unix) || flag(all) + Install$: flag(unix) || flag(all) + FindlibName: simple-top + FindlibParent: lwt + Path: src/simple_top + InternalModules: Lwt_simple_top + BuildDepends: lwt, lwt.unix + XMETADescription: Unix support for lwt + +Library "lwt-react" + Build$: flag(react) || flag(all) + Install$: flag(react) || flag(all) + FindlibName: react + FindlibParent: lwt + Path: src/react + Modules: Lwt_event, Lwt_signal, Lwt_react + BuildDepends: lwt, react + XMETADescription: Reactive programming helpers + +Library "lwt-preemptive" + Build$: flag(preemptive) || flag(all) + Install$: flag(preemptive) || flag(all) + FindlibName: preemptive + FindlibParent: lwt + Path: src/preemptive + Modules: Lwt_preemptive + BuildDepends: lwt, lwt.unix, threads + XMETADescription: Preemptive threads support for Lwt + +Library "lwt-extra" + Build$: flag(extra) || flag(all) + Install$: flag(extra) || flag(all) + FindlibName: extra + FindlibParent: lwt + Path: src/extra + Modules: Lwt_lib + BuildDepends: lwt, lwt.preemptive + XMETADescription: Unix functions for Lwt using Lwt_preemptive + +Library "lwt-glib" + Build$: flag(glib) || flag(all) + Install$: flag(glib) || flag(all) + FindlibName: glib + FindlibParent: lwt + Path: src/glib + Modules: Lwt_glib + CSources: lwt_glib_stubs.c + BuildDepends: lwt, lwt.unix + XMETADescription: Glib integration + +Library "lwt-ssl" + Build$: flag(ssl) || flag(all) + Install$: flag(ssl) || flag(all) + FindlibName: ssl + FindlibParent: lwt + Path: src/ssl + Modules: Lwt_ssl + BuildDepends: ssl, lwt.unix + XMETADescription: SSL support for Lwt + +Library "lwt-text" + Build$: flag(text) || flag(all) + Install$: flag(text) || flag(all) + FindlibName: text + FindlibParent: lwt + Path: src/text + Modules: Lwt_text, Lwt_term, Lwt_read_line + BuildDepends: lwt, lwt.unix, lwt.react, text, text.bigarray + XMETADescription: Text mode utilities + CSources: lwt_text_stubs.c + +Library "lwt-top" + Build$: flag(text) || flag(all) + Install$: flag(text) || flag(all) + FindlibName: top + FindlibParent: lwt + Path: src/top + Modules: Lwt_top + InternalModules: Lwt_ocaml_completion + BuildDepends: lwt, lwt.text, findlib + XMETADescription: Line-editing in the toplevel + +Library "lwt-syntax" + FindlibName: syntax + FindlibParent: lwt + Path: syntax + Modules: Pa_lwt + BuildDepends: camlp4.lib, camlp4.quotations.o, camlp4.extend + XMETAType: syntax + XMETADescription: Syntactic sugars for Lwt + XMETARequires: camlp4, lwt.syntax.options + +Library "lwt-syntax-options" + FindlibName: options + FindlibParent: lwt-syntax + Path: syntax + InternalModules: Pa_lwt_options + BuildDepends: camlp4.lib + XMETAType: syntax + XMETADescription: Options for syntax extensions + XMETARequires: camlp4 + +Library "lwt-syntax-log" + FindlibName: log + FindlibParent: lwt-syntax + Path: syntax + Modules: Pa_lwt_log + BuildDepends: camlp4.lib, camlp4.quotations.o + XMETAType: syntax + XMETADescription: Syntactic sugars for logging + XMETARequires: camlp4, lwt.syntax.options + +# +-------------------------------------------------------------------+ +# | Toplevel | +# +-------------------------------------------------------------------+ + +Executable "lwt-toplevel" + Build$: flag(toplevel) || flag(all) + Install$: flag(toplevel) || flag(all) + Path: src/top + CompiledObject: byte + MainIs: lwt_toplevel.ml + BuildDepends: lwt, lwt.top, lwt.text, lwt.react, text, findlib, unix + +# +-------------------------------------------------------------------+ +# | Doc | +# +-------------------------------------------------------------------+ + +Document "lwt-manual" + Title: Lwt user manual + Type: custom (0.2) + Install: true + XCustom: make -C manual manual.pdf + DataFiles: manual/manual.pdf + InstallDir: $pdfdir + +Document "lwt-api" + Title: API reference for Lwt + Type: ocamlbuild (0.2) + Install: true + InstallDir: $htmldir/api + DataFiles: utils/style.css + BuildTools: ocamldoc + XOCamlbuildPath: ./ + XOCamlbuildLibraries: + lwt, + lwt.extra, + lwt.glib, + lwt.preemptive, + lwt.react, + lwt.ssl, + lwt.text, + lwt.top, + lwt.unix, + lwt.syntax, + lwt.syntax.log + +# +-------------------------------------------------------------------+ +# | Examples | +# +-------------------------------------------------------------------+ + +Executable logging + Path: examples/unix + Build$: flag(unix) + Install: false + MainIs: logging.ml + BuildDepends: lwt.unix, lwt.syntax + CompiledObject: best + +Executable relay + Path: examples/unix + Build$: flag(unix) + Install: false + MainIs: relay.ml + BuildDepends: lwt.unix, lwt.syntax + CompiledObject: best + +Executable parallelize + Path: examples/unix + Build$: flag(unix) + Install: false + MainIs: parallelize.ml + BuildDepends: lwt.unix, lwt.syntax + CompiledObject: best + +# +-------------------------------------------------------------------+ +# | Tests | +# +-------------------------------------------------------------------+ + +Library test + Path: tests + Modules: Test + Install: false + Build$: flag(unix) || flag(all) + +Executable test_core + Path: tests/core + Build$: flag(unix) || flag(all) + Install: false + CompiledObject: best + MainIs: main.ml + BuildDepends: test, lwt, unix, lwt.unix + +Executable test_unix + Path: tests/unix + Build$: flag(unix) || flag(all) + Install: false + CompiledObject: best + MainIs: main.ml + BuildDepends: test, lwt, unix, lwt.unix + +Executable test_react + Path: tests/react + Build$: (flag(unix) && flag(react)) || flag(all) + Install: false + CompiledObject: best + MainIs: main.ml + BuildDepends: test, lwt, unix, lwt.unix, react, lwt.react + +Test core + Command: $test_core + TestTools: test_core + Run$: flag(unix) || flag(all) + +Test unix + Command: $test_unix + TestTools: test_unix + Run$: flag(unix) || flag(all) + +Test react + Command: $test_react + TestTools: test_react + Run$: (flag(unix) && flag(react)) || flag(all) + +# +-------------------------------------------------------------------+ +# | Misc | +# +-------------------------------------------------------------------+ + +SourceRepository head + Type: darcs + Location: http://ocsigen.org/darcs/lwt + Browser: http://ocsigen.org/darcsweb/?r=lwt;a=summary diff --git a/thirdparty/lwt-2.3.2/_tags b/thirdparty/lwt-2.3.2/_tags new file mode 100644 index 0000000..81f7f8e --- /dev/null +++ b/thirdparty/lwt-2.3.2/_tags @@ -0,0 +1,223 @@ +# -*- conf -*- + +<**/*.ml>: syntax_camlp4o, pkg_camlp4 +<**/*.ml>: pa_lwt_options, pa_lwt, pa_lwt_log, pa_optcomp +: -pa_lwt_options, -pa_lwt, -pa_lwt_log, -pa_optcomp + +: use_compiler_libs, pkg_text, pkg_text.bigarray, pkg_findlib, pkg_react, pkg_unix, pkg_bigarray + +: use_stubs + +"src/unix/lwt_io.mli": syntax_camlp4o, pkg_camlp4, pa_optcomp + +# GLib bindings: +: use_C_glib +: use_C_glib +: use_C_glib + +# OASIS_START +# DO NOT EDIT (digest: 1e926c0b1533824658bafa01bc7a4af4) +# Library lwt +"src/core": include +"src/core/lwt.cmxs": use_lwt +# Library lwt-unix +"src/unix": include +"src/unix/lwt-unix.cmxs": use_lwt-unix +: oasis_library_lwt_unix_cclib +"src/unix/liblwt-unix.lib": oasis_library_lwt_unix_cclib +"src/unix/dlllwt-unix.dll": oasis_library_lwt_unix_cclib +"src/unix/liblwt-unix.a": oasis_library_lwt_unix_cclib +"src/unix/dlllwt-unix.so": oasis_library_lwt_unix_cclib +: use_liblwt-unix +: use_lwt +: pkg_unix +: pkg_bigarray +"src/unix/lwt_unix_stubs.c": use_lwt +"src/unix/lwt_unix_stubs.c": pkg_unix +"src/unix/lwt_unix_stubs.c": pkg_bigarray +"src/unix/lwt_libev_stubs.c": use_lwt +"src/unix/lwt_libev_stubs.c": pkg_unix +"src/unix/lwt_libev_stubs.c": pkg_bigarray +# Library lwt-react +"src/react": include +"src/react/lwt-react.cmxs": use_lwt-react +: use_lwt +: pkg_react +# Library test +"tests": include +"tests/test.cmxs": use_test +# Library lwt-text +"src/text": include +"src/text/lwt-text.cmxs": use_lwt-text +: use_liblwt-text +: use_lwt-react +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_text.bigarray +: pkg_text +: pkg_react +: pkg_bigarray +"src/text/lwt_text_stubs.c": use_lwt-react +"src/text/lwt_text_stubs.c": use_lwt-unix +"src/text/lwt_text_stubs.c": use_lwt +"src/text/lwt_text_stubs.c": pkg_unix +"src/text/lwt_text_stubs.c": pkg_text.bigarray +"src/text/lwt_text_stubs.c": pkg_text +"src/text/lwt_text_stubs.c": pkg_react +"src/text/lwt_text_stubs.c": pkg_bigarray +# Executable test_unix +: use_test +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_bigarray +: use_test +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_bigarray +# Library lwt-syntax +"syntax/lwt-syntax.cmxs": use_lwt-syntax +: pkg_camlp4.extend +# Executable test_react +: use_test +: use_lwt-react +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_react +: pkg_bigarray +: use_test +: use_lwt-react +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_react +: pkg_bigarray +# Executable test_core +: use_test +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_bigarray +: use_test +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_bigarray +# Library lwt-top +"src/top": include +"src/top/lwt-top.cmxs": use_lwt-top +# Library lwt-preemptive +"src/preemptive": include +"src/preemptive/lwt-preemptive.cmxs": use_lwt-preemptive +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_threads +: pkg_bigarray +# Library lwt-simple-top +"src/simple_top": include +"src/simple_top/lwt-simple-top.cmxs": use_lwt-simple-top +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_bigarray +# Library lwt-glib +"src/glib": include +"src/glib/lwt-glib.cmxs": use_lwt-glib +: use_liblwt-glib +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_bigarray +"src/glib/lwt_glib_stubs.c": use_lwt-unix +"src/glib/lwt_glib_stubs.c": use_lwt +"src/glib/lwt_glib_stubs.c": pkg_unix +"src/glib/lwt_glib_stubs.c": pkg_bigarray +# Executable relay +: use_lwt-syntax +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_camlp4.quotations.o +: pkg_camlp4.lib +: pkg_camlp4.extend +: pkg_bigarray +# Executable logging +: use_lwt-syntax +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_camlp4.quotations.o +: pkg_camlp4.lib +: pkg_camlp4.extend +: pkg_bigarray +# Library lwt-syntax-log +"syntax/lwt-syntax-log.cmxs": use_lwt-syntax-log +# Executable lwt-toplevel +"src/top/lwt_toplevel.byte": use_lwt-top +"src/top/lwt_toplevel.byte": use_lwt-text +"src/top/lwt_toplevel.byte": use_lwt-react +"src/top/lwt_toplevel.byte": use_lwt-unix +"src/top/lwt_toplevel.byte": use_lwt +"src/top/lwt_toplevel.byte": pkg_unix +"src/top/lwt_toplevel.byte": pkg_text.bigarray +"src/top/lwt_toplevel.byte": pkg_text +"src/top/lwt_toplevel.byte": pkg_react +"src/top/lwt_toplevel.byte": pkg_findlib +"src/top/lwt_toplevel.byte": pkg_bigarray +: use_lwt-top +: use_lwt-text +: use_lwt-react +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_text.bigarray +: pkg_text +: pkg_react +: pkg_findlib +: pkg_bigarray +# Executable parallelize +: use_lwt-syntax +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_camlp4.quotations.o +: pkg_camlp4.lib +: pkg_camlp4.extend +: pkg_bigarray +: use_lwt-syntax +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_camlp4.quotations.o +: pkg_camlp4.lib +: pkg_camlp4.extend +: pkg_bigarray +# Library lwt-extra +"src/extra": include +"src/extra/lwt-extra.cmxs": use_lwt-extra +: use_lwt-preemptive +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_threads +: pkg_bigarray +# Library optcomp +"syntax/optcomp.cmxs": use_optcomp +: pkg_camlp4.quotations.o +# Library lwt-syntax-options +"syntax": include +"syntax/lwt-syntax-options.cmxs": use_lwt-syntax-options +: pkg_camlp4.lib +# Library lwt-ssl +"src/ssl": include +"src/ssl/lwt-ssl.cmxs": use_lwt-ssl +: use_lwt-unix +: use_lwt +: pkg_unix +: pkg_ssl +: pkg_bigarray +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/apiref-intro b/thirdparty/lwt-2.3.2/apiref-intro new file mode 100644 index 0000000..820378d --- /dev/null +++ b/thirdparty/lwt-2.3.2/apiref-intro @@ -0,0 +1,109 @@ +{1 Lwt - API Reference} + +{2 Core library} + +The {e core} library ({e lwt} package) contains the {!Lwt} module, which defines +cooperative threads with all the primitives to manipulate them. It +also provides several general purpose modules, which do not depend on +any external package. + +{!modules: +Lwt +Lwt_condition +Lwt_list +Lwt_mutex +Lwt_mvar +Lwt_pool +Lwt_sequence +Lwt_pqueue +Lwt_stream +Lwt_switch +} + +{2 Unix bindings} + +The {e lwt.unix} package provides: +- the {!Lwt_unix} module, which wrap system calls into cooperative ones +- the {!Lwt_io} module, which defines cooperative byte channel, in + replacement of ones of the standard library +- module helpers for logging, spawning processes, ... + +{!modules: +Lwt_daemon +Lwt_gc +Lwt_io +Lwt_log +Lwt_main +Lwt_engine +Lwt_process +Lwt_throttle +Lwt_timeout +Lwt_unix +Lwt_bytes +Lwt_sys +} + +This package depends on the {e core} library and the {e unix} package. + +{2 Reactive programming helpers} + +The {e lwt.react} package provides helpers for functionnal reactive +programming with Lwt. It is based on the {e react} package. The +{!Lwt_react} module is a replacement for the [React] module. It +contains: + +- all the functions of the [React] module +- Lwt specific primitives +- cooperative versions of {e react} functions + +{!modules: +Lwt_react +} + +This package depends on the {e core} library and the {e react} package. + +{2 Syntax extensions} + +Lwt is shipped with two syntax extensions. The first one, contained in +the {e lwt.syntax} package, aims to make coding with Lwt easier, and +to make code more readable. The second, contained in the package {e +lwt.syntax.log}, is a camlp4 filter which decreases the performance +penalty when using logging by inlining level tests. + +{!modules: +Pa_lwt +Pa_lwt_log +} + +{2 Terminal manipulation} + +The package {e lwt.text} provides: +- terminal manipulation through the module {!Lwt_term} +- text channels which behaves as byte channels but are aware of the + text encoding +- a cooperative, fully customizable read-line facility + +{!modules: +Lwt_read_line +Lwt_term +Lwt_text +} + +This package depends on the {e core} library, and the {e lwt.react}, +{e lwt.unix}, {e text} packages. + +{2 Miscellaneous} + +The following modules are wrapper for integration of non-Lwt +functions/packages into Lwt. + +{!modules: +Lwt_glib +Lwt_lib +Lwt_preemptive +Lwt_ssl +} + +{2 Index} + +{!indexlist} diff --git a/thirdparty/lwt-2.3.2/configure b/thirdparty/lwt-2.3.2/configure new file mode 100755 index 0000000..6719c7c --- /dev/null +++ b/thirdparty/lwt-2.3.2/configure @@ -0,0 +1,8 @@ +#!/bin/sh + +# OASIS_START +# DO NOT EDIT (digest: ed33e59fe00e48bc31edf413bbc8b8d6) +set -e + +ocaml setup.ml -configure $* +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/discover.ml b/thirdparty/lwt-2.3.2/discover.ml new file mode 100644 index 0000000..e5edf40 --- /dev/null +++ b/thirdparty/lwt-2.3.2/discover.ml @@ -0,0 +1,294 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Program discover + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* Discover available features *) + +(* Keep that in sync with the list in myocamlbuild.ml *) +let search_paths = [ + "/usr"; + "/usr/local"; + "/opt"; + "/opt/local"; + "/sw"; + "/mingw"; +] + +open Printf + +(* +-----------------------------------------------------------------+ + | Test codes | + +-----------------------------------------------------------------+ *) + +let caml_code = " +external test : unit -> unit = \"lwt_test\" +let () = test () +" + +let pthread_code = " +#include +#include + +CAMLprim value lwt_test() +{ + pthread_create(0, 0, 0, 0); + return Val_unit; +} +" + +let libev_code = " +#include +#include + +CAMLprim value lwt_test() +{ + ev_default_loop(0); + return Val_unit; +} +" + +let fd_passing_code = " +#include +#include +#include + +CAMLprim value lwt_test() +{ + struct msghdr msg; + msg.msg_controllen = 0; + msg.msg_control = 0; + return Val_unit; +} +" + +let getcpu_code = " +#include +#define _GNU_SOURCE +#include + +CAMLprim value lwt_test() +{ + sched_getcpu(); + return Val_unit; +} +" + +let affinity_code = " +#include +#define _GNU_SOURCE +#include + +CAMLprim value lwt_test() +{ + sched_getaffinity(0, 0, 0); + return Val_unit; +} +" + +let eventfd_code = " +#include +#include + +CAMLprim value lwt_test() +{ + eventfd(0, 0); + return Val_unit; +} +" + +let get_credentials_code = " +#include +#include +#include + +CAMLprim value lwt_test() +{ + getsockopt(0, SOL_SOCKET, SO_PEERCRED, 0, 0); + return Val_unit; +} +" + +let fdatasync_code = " +#include +#include + +CAMLprim value lwt_test() +{ + fdatasync(0); + return Val_unit; +} +" + +(* +-----------------------------------------------------------------+ + | Compilation | + +-----------------------------------------------------------------+ *) + +let ocamlc = ref "ocamlc" +let ext_obj = ref ".o" +let exec_name = ref "a.out" +let use_libev = ref true +let os_type = ref "Unix" + +let log_file = ref "" +let caml_file = ref "" + +(* Search for a header file in standard directories. *) +let search_header header = + let rec loop = function + | [] -> + None + | dir :: dirs -> + if Sys.file_exists (dir ^ "/include/" ^ header) then + Some dir + else + loop dirs + in + loop search_paths + +let c_args = + let flags path = Printf.sprintf "-ccopt -I%s/include -cclib -L%s/lib" path path in + match search_header "ev.h", search_header "pthread.h" with + | None, None -> "" + | Some path, None | None, Some path -> flags path + | Some path1, Some path2 when path1 = path2 -> flags path1 + | Some path1, Some path2 -> flags path1 ^ " " ^ flags path2 + +let compile args stub_file = + ksprintf + Sys.command + "%s -custom %s %s %s %s > %s 2>&1" + !ocamlc + c_args + (Filename.quote stub_file) + args + (Filename.quote !caml_file) + (Filename.quote !log_file) + = 0 + +let safe_remove file_name = + try + Sys.remove file_name + with exn -> + () + +let test_code args stub_code = + let stub_file, oc = Filename.open_temp_file "lwt_stub" ".c" in + let cleanup () = + safe_remove stub_file; + safe_remove (Filename.chop_extension (Filename.basename stub_file) ^ !ext_obj) + in + try + output_string oc stub_code; + flush oc; + close_out oc; + let result = compile args stub_file in + cleanup (); + result + with exn -> + (try close_out oc with _ -> ()); + cleanup (); + raise exn + +let config = open_out "src/unix/lwt_config.h" +let config_ml = open_out "src/unix/lwt_config.ml" + +let test_feature ?(do_check = true) name macro ?(args="") code = + if do_check then begin + printf "testing for %s:%!" name; + if test_code args code then begin + fprintf config "#define %s\n" macro; + fprintf config_ml "#let %s = true\n" macro; + printf " %s available\n%!" (String.make (34 - String.length name) '.'); + true + end else begin + fprintf config "//#define %s\n" macro; + fprintf config_ml "#let %s = false\n" macro; + printf " %s unavailable\n%!" (String.make (34 - String.length name) '.'); + false + end + end else begin + printf "not checking for %s\n%!" name; + fprintf config "//#define %s\n" macro; + fprintf config_ml "#let %s = false\n" macro; + true + end + +(* +-----------------------------------------------------------------+ + | Entry point | + +-----------------------------------------------------------------+ *) + +let () = + let args = [ + "-ocamlc", Arg.Set_string ocamlc, " ocamlc"; + "-ext-obj", Arg.Set_string ext_obj, " C object files extension"; + "-exec-name", Arg.Set_string exec_name, " name of the executable produced by ocamlc"; + "-use-libev", Arg.Symbol (["true"; "false"], + function + | "true" -> use_libev := true + | "false" -> use_libev := false + | _ -> assert false), " whether to check for libev"; + "-os-type", Arg.Set_string os_type, " type of the target os"; + ] in + Arg.parse args ignore "check for external C libraries and available features\noptions are:"; + + (* Put the caml code into a temporary file. *) + let file, oc = Filename.open_temp_file "lwt_caml" ".ml" in + caml_file := file; + output_string oc caml_code; + close_out oc; + + log_file := Filename.temp_file "lwt_output" ".log"; + + (* Cleanup things on exit. *) + at_exit (fun () -> + (try close_out config with _ -> ()); + (try close_out config_ml with _ -> ()); + safe_remove !log_file; + safe_remove !exec_name; + safe_remove !caml_file; + safe_remove (Filename.chop_extension !caml_file ^ ".cmi"); + safe_remove (Filename.chop_extension !caml_file ^ ".cmo")); + + let missing = [] in + let missing = if test_feature ~do_check:!use_libev "libev" "HAVE_LIBEV" ~args:"-cclib -lev" libev_code then missing else "libev" :: missing in + let missing = if test_feature ~do_check:(!os_type <> "Win32") "pthread" "HAVE_PTHREAD" ~args:"-cclib -lpthread" pthread_code then missing else "pthread" :: missing in + + if missing <> [] then begin + printf " + The following recquired C libraries are missing: %s. +Please install them and retry. If they are installed in a non-standard location, set the environment variables C_INCLUDE_PATH and LIBRARY_PATH accordingly and retry. + +For example, if they are installed in /opt/local, you can type: + +export C_INCLUDE_PATH=/opt/local/include +export LIBRARY_PATH=/opt/local/lib + +To compile without libev support, use ./configure --disable-libev ... +" (String.concat ", " missing); + exit 1 + end; + + ignore (test_feature "eventfd" "HAVE_EVENTFD" eventfd_code); + ignore (test_feature "fd passing" "HAVE_FD_PASSING" fd_passing_code); + ignore (test_feature "sched_getcpu" "HAVE_GETCPU" getcpu_code); + ignore (test_feature "affinity getting/setting" "HAVE_AFFINITY" affinity_code); + ignore (test_feature "credentials getting" "HAVE_GET_CREDENTIALS" get_credentials_code); + ignore (test_feature "fdatasync" "HAVE_FDATASYNC" fdatasync_code) diff --git a/thirdparty/lwt-2.3.2/examples/gtk/Makefile b/thirdparty/lwt-2.3.2/examples/gtk/Makefile new file mode 100644 index 0000000..58a20a4 --- /dev/null +++ b/thirdparty/lwt-2.3.2/examples/gtk/Makefile @@ -0,0 +1,2 @@ +all: + ocamlbuild -use-ocamlfind -classic-display -tag 'syntax(camlp4o)' -package lwt.unix,lwt.glib,lwt.syntax,lablgtk2 connect.byte diff --git a/thirdparty/lwt-2.3.2/examples/gtk/connect.ml b/thirdparty/lwt-2.3.2/examples/gtk/connect.ml new file mode 100644 index 0000000..463321a --- /dev/null +++ b/thirdparty/lwt-2.3.2/examples/gtk/connect.ml @@ -0,0 +1,218 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Program Connect + * Copyright (C) 2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* A simple graphical telnet. *) + +open Lwt + +(* +-----------------------------------------------------------------+ + | Utils | + +-----------------------------------------------------------------+ *) + +let show_error fmt = + Printf.ksprintf + (fun message -> + let dialog = GWindow.message_dialog ~message_type:`ERROR ~buttons:GWindow.Buttons.ok ~message () in + ignore (dialog#connect#response (function + | `DELETE_EVENT -> () + | `OK -> dialog#destroy ())); + dialog#show ()) + fmt + +(* +-----------------------------------------------------------------+ + | Connection | + +-----------------------------------------------------------------+ *) + +(* Either [None] if we are not connected, either [Some (ic, oc, + thread)] if we are connected. In this last case [thread] is the + thread reading data from the connection. *) +let connection = ref None + +(* Read continously data from [ic] and write them to [view]. *) +let read ic (view : GText.view) = + let rec loop () = + match_lwt Lwt_io.read_line_opt ic with + | Some line -> + view#buffer#insert ~iter:view#buffer#end_iter ~tag_names:["recv"] (line ^ "\n"); + loop () + | None -> + view#buffer#insert ~iter:view#buffer#end_iter "end of connection\n"; + Lwt_io.close ic + in + try_lwt + loop () + with Unix.Unix_error (error, _, _) -> + show_error "reading error: %s" (Unix.error_message error); + return () + +(* Function called when the user active the [connect] menu + item. [view] is the text view used to display data received from + the connection. *) +let connect (view : GText.view) = + (* Create a popup for asking the address and port to connect to. *) + let dialog = GWindow.dialog ~title:"connection" () in + dialog#add_button_stock `OK `OK; + dialog#add_button_stock `CANCEL `CANCEL; + let hbox = GPack.hbox ~packing:dialog#vbox#add () in + ignore (GMisc.label ~packing:hbox#add ~text:"host: " ()); + let host = GEdit.entry ~packing:hbox#add ~text:"127.0.0.1" () in + ignore (GMisc.label ~packing:hbox#add ~text:" port: " ()); + let port = GEdit.spin_button ~digits:0 ~numeric:true ~packing:hbox#add () in + port#adjustment#set_bounds ~lower:0. ~upper:(float max_int) ~step_incr:1. (); + + (* Thread waiting for the popup to be closed. *) + let waiter, wakener = wait () in + + (* Wakeup the thread when the popup is closed. *) + ignore (dialog#connect#response (wakeup wakener)); + + dialog#show (); + + ignore ( + match_lwt waiter with + | `DELETE_EVENT -> + return () + | `CANCEL -> + dialog#destroy (); + return () + | `OK -> + let host = host#text and port = int_of_float port#value in + dialog#destroy (); + try_lwt + (* Resolve the address. *) + lwt entry = Lwt_unix.gethostbyname host in + if Array.length entry.Unix.h_addr_list = 0 then begin + show_error "no address found for host %S" host; + return () + end else begin + lwt ic, oc = Lwt_io.open_connection (Unix.ADDR_INET (entry.Unix.h_addr_list.(0), port)) in + (* Close the previous connection. *) + lwt () = + match !connection with + | None -> + return () + | Some (ic, oc, thread) -> + cancel thread; + try_lwt + Lwt_io.close ic <&> Lwt_io.close oc + with Unix.Unix_error (error, _, _) -> + show_error "cannot close the connection: %s" (Unix.error_message error); + return () + in + (* Clear the buffer. *) + view#buffer#delete view#buffer#start_iter view#buffer#end_iter; + connection := Some (ic, oc, read ic view); + return () + end + with + | Unix.Unix_error (error, _, _) -> + show_error "cannot establish the connection: %s" (Unix.error_message error); + return () + | Not_found -> + show_error "host %S not found" host; + return () + ) + +(* Send some data. *) +let write (view : GText.view) (entry : GEdit.entry) = + let text = entry#text in + entry#set_text ""; + match !connection with + | Some (ic, oc, thread) -> + view#buffer#insert ~iter:view#buffer#end_iter ~tag_names:["send"] (text ^ "\n"); + ignore ( + try_lwt + Lwt_io.write_line oc text + with Unix.Unix_error (error, _, _) -> + show_error "cannot send line: %s" (Unix.error_message error); + return () + ) + | None -> + show_error "not connected" + +(* +-----------------------------------------------------------------+ + | Entry point | + +-----------------------------------------------------------------+ *) + +lwt () = + (* Initializes GTK. *) + ignore (GMain.init ~setlocale:false ()); + + (* Integrate Lwt with Glib. *) + Lwt_glib.install (); + + (* Create the UI. *) + let window = GWindow.window ~title:"simple graphical telnet in OCaml with Lwt" ~allow_shrink:true ~width:640 ~height:480 () in + let vbox = GPack.vbox ~packing:window#add () in + + (* Create the menu. *) + let menu = GMenu.menu_bar ~packing:(vbox#pack ~expand:false) () in + let menu_file = GMenu.menu ~packing:(GMenu.menu_item ~label:"File" ~packing:menu#add ())#set_submenu () in + let menu_connect = GMenu.image_menu_item ~label:"Connect" ~packing:menu_file#add ~stock:`CONNECT () in + ignore (GMenu.separator_item ~packing:menu_file#add ()); + let menu_quit = GMenu.image_menu_item ~label:"Quit" ~packing:menu_file#add ~stock:`QUIT () in + + (* The text view displaying inputs and outputs. *) + let view = + GText.view + ~editable:false + ~packing:(GBin.scrolled_window + ~hpolicy:`AUTOMATIC + ~vpolicy:`AUTOMATIC + ~packing:(GBin.frame + ~label:"log" + ~packing:vbox#add + ())#add + ())#add + () + in + + ignore (view#buffer#create_tag ~name:"send" [`FOREGROUND "blue"]); + ignore (view#buffer#create_tag ~name:"recv" [`FOREGROUND "#007f00"]); + + let hbox = GPack.hbox ~packing:(GBin.frame ~label:"input" ~packing:(vbox#pack ~expand:false) ())#add () in + + (* The entry for user input. *) + let entry = GEdit.entry ~packing:hbox#add () in + let send = GButton.button ~label:"send" ~packing:(hbox#pack ~expand:false) () in + + (* Try to use a monospace font. *) + (try + view#misc#modify_font_by_name "Monospace"; + entry#misc#modify_font_by_name "Monospace" + with _ -> + ()); + + (* Thread waiting for the main window to be closed. *) + let waiter, wakener = wait () in + + (* Setup callbacks. *) + ignore (window#connect#destroy (wakeup wakener)); + ignore (menu_quit#connect#activate (wakeup wakener)); + ignore (menu_connect#connect#activate (fun () -> connect view)); + ignore (entry#connect#activate (fun () -> write view entry)); + ignore (send#connect#clicked (fun () -> write view entry)); + + window#show (); + + (* Wait for the main window to be closed. *) + waiter diff --git a/thirdparty/lwt-2.3.2/examples/unix/logging.ml b/thirdparty/lwt-2.3.2/examples/unix/logging.ml new file mode 100644 index 0000000..e0209fe --- /dev/null +++ b/thirdparty/lwt-2.3.2/examples/unix/logging.ml @@ -0,0 +1,62 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Program Logging + * Copyright (C) 2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* This example illustrate the use of the Lwt_log module from + lwt.unix. *) + +(* The logging section for this module: *) +let section = Lwt_log.Section.make "test" + +lwt () = + (* Enable all logging levels superior from [Info] to [Fatal]: *) + Lwt_log.Section.set_level section Lwt_log.Info; + + (* A message with the default logger: *) + lwt () = Lwt_log.log ~section ~level:Lwt_log.Info "this message will appear only on stderr" in + + (* Same as begore, but using [Lwt_log.info]: *) + lwt () = Lwt_log.info ~section "this one too" in + + (* A message to a custom logger, logging simultaneously to [stderr] + and to the system logger daemon: *) + let logger = + Lwt_log.broadcast + [Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr (); + Lwt_log.syslog ~facility:`User ()] + in + lwt () = Lwt_log.info ~section ~logger "this message will appear on stderr and in '/var/log/user.log'" in + + (* Logging of exceptions: *) + Printexc.record_backtrace true; + let f () : unit = raise Exit in + let g () = f () in + let h () = g () in + lwt () = + try + h (); + Lwt.return () + with exn -> + Lwt_log.error ~section ~exn "h failed with" + in + + let logger = Lwt_log.channel ~template:"$(name): $(section): $(loc-file): $(loc-line): $(loc-column): $(message)" ~close_mode:`Keep ~channel:Lwt_io.stderr () in + Lwt_log.info ~section ~logger "this message will appear with a location" diff --git a/thirdparty/lwt-2.3.2/examples/unix/parallelize.ml b/thirdparty/lwt-2.3.2/examples/unix/parallelize.ml new file mode 100644 index 0000000..bd72c82 --- /dev/null +++ b/thirdparty/lwt-2.3.2/examples/unix/parallelize.ml @@ -0,0 +1,57 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Program Parallelize + * Copyright (C) 2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* Reads commands from standard input and launch them in parallel, + using as many processes as the number of CPUs. *) + +open Lwt + +(* Reads one command, launch it and waits for when it termination, + then start again: *) +let rec launch () = + match_lwt Lwt_io.read_line_opt Lwt_io.stdin with + | None -> + return () + | Some line -> + lwt exit_status = Lwt_process.exec (Lwt_process.shell line) in + launch () + +(* Creates the initial threads, where is the number of + CPUs: *) +let rec create_threads = function + | 0 -> + return () + | n -> + launch () <&> create_threads (n - 1) + +(* Counts the number of CPUs using "/proc/cpuinfo": *) +let cpus_count () = + Lwt_stream.fold (fun _ n -> succ n) + (Lwt_stream.filter + (fun line -> + try + Scanf.sscanf line "processor :" true + with _ -> + false) + (Lwt_io.lines_of_file "/proc/cpuinfo")) 0 + +lwt () = cpus_count () >>= create_threads diff --git a/thirdparty/lwt-2.3.2/examples/unix/relay.ml b/thirdparty/lwt-2.3.2/examples/unix/relay.ml new file mode 100644 index 0000000..3ffa0a2 --- /dev/null +++ b/thirdparty/lwt-2.3.2/examples/unix/relay.ml @@ -0,0 +1,156 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Program Relay + * Copyright (C) 2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* Relay data from an address to another. *) + +open Lwt + +(* +-----------------------------------------------------------------+ + | Relaying | + +-----------------------------------------------------------------+ *) + +(* Write exactly [len] bytes from [buf] at [ofs]. *) +let rec write_exactly fd buf ofs len = + lwt n = Lwt_bytes.write fd buf ofs len in + if n = len then + (* Everything has been written, do nothing. *) + return () + else + (* Write remaining data. *) + write_exactly fd buf (ofs + n) (len - n) + +(* Copy continously data from [in_fd] to [out_fd]. *) +let relay in_fd out_fd = + (* Queue of data received but not yet written. *) + let queue = Queue.create () in + + (* Condition used to signal the writer that some data are + available. *) + let cond = Lwt_condition.create () in + + (* Boolean which tells whether the input socket has been closed. *) + let end_of_input = ref false in + + (* Write continously data received to [out_fd]. *) + let rec loop_write () = + if Queue.is_empty queue then + if !end_of_input then + (* End of input reached, exit. *) + return () + else + (* There is no data pending, wait for some. *) + lwt () = Lwt_condition.wait cond in + loop_write () + else + let (buf, len) = Queue.take queue in + lwt () = write_exactly out_fd buf 0 len in + loop_write () + in + + (* Start the writer. *) + let writer = loop_write () in + + (* Read continously from [in_fd]. *) + let rec loop_read () = + let buf = Lwt_bytes.create 8192 in + match_lwt Lwt_bytes.read in_fd buf 0 8192 with + | 0 -> + (* If we read nothing, this means that the connection has + been closed. *) + (* Mark the end of input has reached. *) + end_of_input := true; + (* Singal the writer in case it is waiting for data. *) + Lwt_condition.signal cond (); + (* Wait for it to terminate. *) + writer + | n -> + (* Otherwise, send data to the writer. *) + Queue.add (buf, n) queue; + (* Singal the writer in case it is waiting for data. *) + Lwt_condition.signal cond (); + loop_read () + in + + (* Wait for either the reader to terminate or the writer to fail. *) + pick [writer; loop_read ()] + +(* +-----------------------------------------------------------------+ + | Entry point | + +-----------------------------------------------------------------+ *) + +let usage () = + prerr_endline "usage: relay : :"; + exit 2 + +(* Convert a string of the form ":" to an internet address + object. *) +let addr_of_string str = + (* Split the host and the port. *) + let idx = try String.index str ':' with Not_found -> usage () in + let host = String.sub str 0 idx and port = String.sub str (idx + 1) (String.length str - idx - 1) in + (* Parse the port. *) + let port = try int_of_string port with Failure _ -> usage () in + (* Request the address of the host. *) + lwt entry = Lwt_unix.gethostbyname host in + if Array.length entry.Unix.h_addr_list = 0 then begin + Printf.eprintf "no address found for host %S\n" host; + exit 1 + end; + return (Unix.ADDR_INET (entry.Unix.h_addr_list.(0), port)) + +lwt () = + if Array.length Sys.argv <> 3 then usage (); + + try_lwt + (* Resolve addresses. *) + lwt src_addr = addr_of_string Sys.argv.(1) and dst_addr = addr_of_string Sys.argv.(2) in + + (* Initialize the listening address. *) + let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Lwt_unix.setsockopt sock Unix.SO_REUSEADDR true; + Lwt_unix.bind sock src_addr; + Lwt_unix.listen sock 1024; + + ignore (Lwt_log.notice "waiting for connection"); + + (* Wait for a connection. *) + lwt fd1, _ = Lwt_unix.accept sock in + + ignore (Lwt_log.notice "connection received, start relayling"); + + (* Closes the no-more used listening socket. *) + lwt () = Lwt_unix.close sock in + + (* Connect to the destination port. *) + let fd2 = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + lwt () = Lwt_unix.connect fd2 dst_addr in + + (* Start relaying. *) + lwt () = pick [relay fd1 fd2; relay fd2 fd1] in + + ignore (Lwt_log.notice "done relayling"); + + return () + + with exn -> + ignore (Lwt_log.error ~exn "something went wrong"); + exit 1 diff --git a/thirdparty/lwt-2.3.2/lwt-api.odocl b/thirdparty/lwt-2.3.2/lwt-api.odocl new file mode 100644 index 0000000..67e416c --- /dev/null +++ b/thirdparty/lwt-2.3.2/lwt-api.odocl @@ -0,0 +1,40 @@ +# OASIS_START +# DO NOT EDIT (digest: 11d6fd54a0a3f207d6602a7b1da2317e) +src/core/Lwt_condition +src/core/Lwt_list +src/core/Lwt +src/core/Lwt_mutex +src/core/Lwt_mvar +src/core/Lwt_pool +src/core/Lwt_sequence +src/core/Lwt_stream +src/core/Lwt_switch +src/core/Lwt_util +src/core/Lwt_pqueue +src/extra/Lwt_lib +src/glib/Lwt_glib +src/preemptive/Lwt_preemptive +src/react/Lwt_event +src/react/Lwt_signal +src/react/Lwt_react +src/ssl/Lwt_ssl +src/text/Lwt_text +src/text/Lwt_term +src/text/Lwt_read_line +src/top/Lwt_top +src/unix/Lwt_chan +src/unix/Lwt_daemon +src/unix/Lwt_gc +src/unix/Lwt_io +src/unix/Lwt_log +src/unix/Lwt_main +src/unix/Lwt_process +src/unix/Lwt_throttle +src/unix/Lwt_timeout +src/unix/Lwt_unix +src/unix/Lwt_sys +src/unix/Lwt_engine +src/unix/Lwt_bytes +syntax/Pa_lwt +syntax/Pa_lwt_log +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/manual/Makefile b/thirdparty/lwt-2.3.2/manual/Makefile new file mode 100644 index 0000000..09d009a --- /dev/null +++ b/thirdparty/lwt-2.3.2/manual/Makefile @@ -0,0 +1,20 @@ +# Makefile +# -------- +# Copyright : (c) 2010, Jeremie Dimino +# Licence : BSD3 +# +# This file is a part of lwt. + +all: manual.pdf + +manual-wiki.tex: manual.wiki + latex_of_wiki < manual.wiki > manual-wiki.tex + +manual.pdf: manual.tex manual-wiki.tex + rubber --pdf manual.tex + +clean-aux: + rm -f .latex_of_wiki_offsets *.log *.aux *.out *.toc + +clean: clean-aux + rm -f manual.pdf manual-wiki.tex diff --git a/thirdparty/lwt-2.3.2/manual/manual-wiki.tex b/thirdparty/lwt-2.3.2/manual/manual-wiki.tex new file mode 100644 index 0000000..e56f773 --- /dev/null +++ b/thirdparty/lwt-2.3.2/manual/manual-wiki.tex @@ -0,0 +1,1359 @@ + +\section{ Introduction } + +When writing a program, a common developer's task is to handle IO +operations. Indeed most software interact with several different +resources, such as: + + + +\begin{itemize} +\item the kernel, by doing system calls +\item the user, by reading the keyboard, the mouse, or any input device +\item a graphical server, to build graphical user interface +\item other computers, by using the network +\item ... + +\end{itemize} + +When this list contains only one item, it is pretty easy to +handle. However as this list grows it becomes harder and harder to +make everything works together. Several choices have been proposed +to solve this problem: + + + +\begin{itemize} +\item using a main loop, and integrate all components we are +interacting with into this main loop. +\item using preemptive system threads + +\end{itemize} + +Both solution have their advantages and their drawbacks. For the +first one, it may works, but it becomes very complicated to write +some piece of asynchronous sequential code. The typical example being with +graphical user interfaces freezing and not redrawing themselves +because they are waiting for some blocking part of the code to +complete. + + + +If you already wrote code using preemptive threads, you shall know +that doing it right with threads is a hard job. Moreover system +threads consume non negligible resources, and so you can only launch +a limited number of threads at the same time. Thus this is not a +real solution. + + + +{\tt Lwt} offers a new alternative. It provides very light-weight +cooperative threads; ``launching'' a thread is a very quick +operation, it does not require a new stack, a new process, or +anything else. Moreover context switches are very fast. In fact, it +is so easy that we will launch a thread for every system call. And +composing cooperative threads will allow us to write highly +asynchronous programs. + + + +In a first part, we will explain the concepts of {\tt Lwt}, then we will +describe the many sub-libraries of {\tt Lwt}. + + + +\section{ The Lwt core library } + +In this section we describe the basics of {\tt Lwt}. It is advised to +start an ocaml toplevel and try the given code examples. To start, +launch {\tt ocaml} in a terminal or in emacs with the tuareg +mode, and type: + + + +\begin{verbatim} +# #use "topfind";; +# #require "lwt";; + +\end{verbatim} + +{\tt Lwt} is also shipped with an improved toplevel, which supports line +edition and completion. If it has been correctly installed, you +should be able to start it with the following command: + + + +\begin{verbatim} +$ lwt-toplevel + +\end{verbatim} + +\subsection{ Lwt concepts } + +Let's take a classical function of the {\tt Pervasives} module: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# Pervasives.input_char; +- : in_channel -> char = + +\end{lstlisting} +This function will wait for a character to come on the given input +channel, then return it. The problem with this function is that it is +blocking: while it is being executed, the whole program will be +blocked, and other events will not be handled until it returns. + + + +Now let's look at the lwt equivalent: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# Lwt_io.read_char;; +- : Lwt_io.input_channel -> char Lwt.t = + +\end{lstlisting} +As you can see, it does not returns a character but something of +type {\tt char Lwt.t}. The type {\tt 'a Lwt.t} is the type +of threads returning a value of type {\tt 'a}. Actually the +{\tt Lwt\_io.read\_char} will try to read a character from the +given input channel and \emph{immediatly} returns a light-weight +thread. + + + +Now, let's see what we can do with a {\tt Lwt} thread. The following +code create a pipe, and launch a thread reading on the input side: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# let ic, oc = Lwt_io.pipe ();; +val ic : Lwt_io.input_channel = +val oc : Lwt_io.output_channel = +# let t = Lwt_io.read_char ic;; +val t : char Lwt.t = + +\end{lstlisting} +We can now look at the state of our newly created thread: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# Lwt.state t;; +- : char Lwt.state = Sleep + +\end{lstlisting} +A thread may be in one of the following states: + + + +\begin{itemize} +\item {\tt Return x}, which means that the thread has terminated +successfully and returned the value {\tt x} +\item {\tt Fail exn}, which means that the thread has terminated, +but instead of returning a value, it failed with the exception +{\tt exn} +\item {\tt Sleep}, which means that the thread is currently +sleeping and have not yet returned a value or an exception + +\end{itemize} + +The thread {\tt t} is sleeping because there is currently nothing +to read on the pipe. Let's write something: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# Lwt_io.write_char oc 'a';; +- : unit Lwt.t = +# Lwt.state t;; +- : char Lwt.state = Return 'a' + +\end{lstlisting} +So, after we write something, the reading thread has been wakeup and +has returned the value {\tt 'a'}. + + + +\subsection{ Primitives for thread creation } + +There are several primitives for creating {\tt Lwt} threads. These +functions are located in the module {\tt Lwt}. + + + +Here are the main primitives: + + + +\begin{itemize} +\item {\tt Lwt.return : 'a -> 'a Lwt.t} +\mbox{}\\ +creates a thread which has already terminated and returned a value +\item {\tt Lwt.fail : exn -> 'a Lwt.t} +\mbox{}\\ +creates a thread which has already terminated and failed with an +exception +\item {\tt Lwt.wait : unit -> 'a Lwt.t * 'a Lwt.u} +\mbox{}\\ +creates a sleeping thread and returns this thread plus a wakener (of +type {\tt 'a Lwt.u}) which must be used to wakeup the sleeping +thread. + +\end{itemize} + +To wake up a sleeping thread, you must use one of the following +functions: + + + +\begin{itemize} +\item {\tt Lwt.wakeup : 'a Lwt.u -> 'a -> unit} +\mbox{}\\ +wakes up the thread with a value. +\item {\tt Lwt.wakeup\_exn : 'a Lwt.u -> exn -> unit} +\mbox{}\\ +wakes up the thread with an exception. + +\end{itemize} + +Note that this is an error to wakeup two times the same threads. {\tt Lwt} +will raise {\tt Invalid\_argument} if you try to do so. + + + +With these informations, try to guess the result of each of the +following expression: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# Lwt.state (Lwt.return 42);; +# Lwt.state (fail Exit);; +# let waiter, wakener = Lwt.wait ();; +# Lwt.state waiter;; +# Lwt.wakeup wakener 42;; +# Lwt.state waiter;; +# let waiter, wakener = Lwt.wait ();; +# Lwt.state waiter;; +# Lwt.wakeup_exn wakener Exit;; +# Lwt.state waiter;; + +\end{lstlisting} +\subsubsection{ Primitives for thread composition } + +The most important operation you need to know is {\tt bind}: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val bind : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t + +\end{lstlisting} +{\tt bind t f} creates a thread which waits for {\tt t} to +terminates, then pass the result to {\tt f}. If {\tt t} is a +sleeping thread, then {\tt bind t f} will be a sleeping thread too, +until {\tt t} terminates. If {\tt t} fails, then the resulting +thread will fail with the same exception. For example, consider the +following expression: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +Lwt.bind + (Lwt_io.read_line Lwt_io.stdin) + (fun str -> Lwt_io.printlf "You typed %S" str) + +\end{lstlisting} +This code will first wait for the user to enter a line of text, then +print a message on the standard output. + + + +Similarly to {\tt bind}, there is a function to handle the case +when {\tt t} fails: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val catch : (unit -> 'a Lwt.t) -> (exn -> 'a Lwt.t) -> 'a Lwt.t + +\end{lstlisting} +{\tt catch f g} will call {\tt f ()}, then waits for its +termination, and if it fails with an exception {\tt exn}, calls +{\tt g exn} to handle it. Note that both exceptions raised with +{\tt Pervasives.raise} and {\tt Lwt.fail} are caught by +{\tt catch}. + + + +\subsubsection{ Cancelable threads } + +In some case, we may want to cancel a thread. For example, because it +has not terminated after a timeout. This can be done with cancelable +threads. To create a cancelable thread, you must use the +{\tt Lwt.task} function: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val task : unit -> 'a Lwt.t * 'a Lwt.u + +\end{lstlisting} +It has the same semantic as {\tt Lwt.wait} except that the +sleeping thread can be canceled with {\tt Lwt.cancel}: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val cancel : 'a Lwt.t -> unit + +\end{lstlisting} +The thread will then fails with the exception +{\tt Lwt.Canceled}. To execute a function when the thread is +canceled, you must use {\tt Lwt.on\_cancel}: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val on_cancel : 'a Lwt.t -> (unit -> unit) -> unit + +\end{lstlisting} +Note that it is also possible to cancel a thread which has not been +created with {\tt Lwt.task}. In this case, the deepest cancelable +thread connected with the given thread will be cancelled. + + + +For example, consider the following code: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# let waiter, wakener = Lwt.task ();; +val waiter : '_a Lwt.t = +val wakener : '_a Lwt.u = +# let t = bind waiter (fun x -> return (x + 1));; +val t : int Lwt.t = + +\end{lstlisting} +Here, cancelling {\tt t} will in fact cancel {\tt waiter}. +{\tt t} will then fails with the exception {\tt Lwt.Canceled}: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# Lwt.cancel t;; +- : unit = () +# Lwt.state waiter;; +- : int Lwt.state = Fail Lwt.Canceled +# Lwt.state t;; +- : int Lwt.state = Fail Lwt.Canceled + +\end{lstlisting} +By the way, it is possible to prevent a thread from being canceled +by using the function {\tt Lwt.protected}: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val protected : 'a Lwt.t -> 'a Lwt.t + +\end{lstlisting} +Canceling {\tt (proctected t)} will have no effect on {\tt t}. + + + +\subsubsection{ Primitives for multi-thread composition } + +We now show how to compose several threads at the same time. The +main functions for this are in the {\tt Lwt} module: {\tt join}, +{\tt choose} and {\tt pick}. + + + +The first one, {\tt join} takes a list of threads and wait for all +of them to terminate: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val join : unit Lwt.t list -> unit Lwt.t + +\end{lstlisting} +Moreover, if at least one thread fails, {\tt join l} will fails with +the same exception as the first to fail, after all threads threads terminated. + + + +On the contrary {\tt choose} waits for at least one thread to +terminate, then returns the same value or exception: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val choose : 'a Lwt.t list -> 'a Lwt.t + +\end{lstlisting} +For example: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# let waiter1, wakener1 = Lwt.wait ();; +val waiter1 : '_a Lwt.t = +val wakener1 : '_a Lwt.u = +# let waiter2, wakener2 = Lwt.wait ();; +val waiter2 : '_a Lwt.t = +val wakener : '_a Lwt.u = +# let t = Lwt.choose [waiter1; waiter2];; +val t : '_a Lwt.t = +# Lwt.state t;; +- : '_a Lwt.state = Sleep +# Lwt.wakeup wakener2 42;; +- : unit = () +# Lwt.state t;; +- : int Lwt.state = Return 42 + +\end{lstlisting} +Thel last one, {\tt pick}, is the same as {\tt join} except that it cancels +all other threads when one terminates. + + + +\subsubsection{ Threads local storage } + +Lwt can stores variables with different values on different +threads. This is called threads local storage. For example, this can +be used to store contexts or thread identifiers. The contents of a +variable can be read with: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val Lwt.get : 'a Lwt.key -> 'a option + +\end{lstlisting} +which takes a key to identify the variable we want to read and +returns either {\tt None} if the variable is not set, or +{\tt Some x} if it is. The value returned is the value of the +variable in the current thread. + + + +New keys can be created with: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val Lwt.new_key : unit -> 'a Lwt.key + +\end{lstlisting} +To set a variable, you must use: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val Lwt.with_value : 'a Lwt.key -> 'a option -> (unit -> 'b) -> 'b + +\end{lstlisting} +{\tt with\_value key value f} will executes {\tt f} with +the binding {\tt key -> value}. The old value associated to +{\tt key} is restored after {\tt f} terminates. + + + +For example, you can use local storage to store thread identifiers +and use them in logs: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +let id_key = Lwt.new_key () + +let log msg = + let thread_id = + match Lwt.get id_key with + | Some id -> id + | None -> "main" + in + Lwt_io.printlf "%s: %s" thread_id msg + +lwt () = + Lwt.join [ + Lwt.with_value id_key (Some "thread 1") (fun () -> log "foo"); + Lwt.with_value id_key (Some "thread 2") (fun () -> log "bar"); + ] + +\end{lstlisting} +\subsubsection{ Rules } + +{\tt Lwt} will always try to execute the more it can before yielding and +switching to another cooperative thread. In order to make it works well, +you must follow the following rules: + + + +\begin{itemize} +\item do not write function that may takes time to complete without +using {\tt Lwt}, +\item do not do IOs that may block, otherwise the whole program will +hang. You must instead use asynchronous IOs operations. + +\end{itemize} + +\subsection{ The syntax extension } + +{\tt Lwt} offers a syntax extension which increases code readability and +makes coding using {\tt Lwt} easier. To use it add the ``lwt.syntax'' package when +compiling: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +$ ocamlfind ocamlc -syntax camlp4o -package lwt.syntax -linkpkg -o foo foo.ml + +\end{lstlisting} +Or in the toplevel (after loading topfind): + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# #camlp4o;; +# #require "lwt.syntax";; + +\end{lstlisting} +The following construction are added to the language: + + + +\begin{itemize} +\item {\tt lwt} \emph{pattern$_{\mbox{1}}$} {\tt =} \emph{expr$_{\mbox{1}}$} [ {\tt and} +\emph{pattern$_{\mbox{2}}$} {\tt =} \emph{expr$_{\mbox{2}}$} ... ] {\tt in} \emph{expr} +\mbox{}\\ +which is a parallel let-binding construction. For example in the +following code: + +\end{itemize} + +\lstset{language=[Objective]Caml}\begin{lstlisting} +lwt x = f () and y = g () in +expr + +\end{lstlisting} +the thread {\tt f ()} and {\tt g ()} are launched in parallel +and their result are then bound to {\tt x} and {\tt y} in the +expression \emph{expr}. + + + +Of course you can also launch the two threads sequentially by +writing your code like that: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +lwt x = f () in +lwt y = g () in +expr + +\end{lstlisting} +\begin{itemize} +\item {\tt try\_lwt} \emph{expr} [ {\tt with} \emph{pattern$_{\mbox{1}}$} +{\tt ->} \emph{expr$_{\mbox{1}}$} ... ] [ {\tt finally} \emph{expr'} ] +\mbox{}\\ +which is the equivalent of the standard {\tt try-with} +construction but for {\tt Lwt}. Both exception raised by +{\tt Pervasives.raise} and {\tt Lwt.fail} are caught."; + +\end{itemize} + +\begin{itemize} +\item {\tt for\_lwt} \emph{ident} {\tt =} \emph{expr$_{\mbox{init}}$} ( {\tt to} {\tt |} +{\tt downto} ) \emph{expr$_{\mbox{final}}$} {\tt do} \emph{expr} +{\tt done} +\mbox{}\\ +which is the equivalent of the standard {\tt for} construction +but for {\tt Lwt}. + +\end{itemize} + +\begin{itemize} +\item {\tt raise\_lwt} \emph{exn} +\mbox{}\\ +which is the same as {\tt Lwt.fail} \emph{exn} but with backtrace support. + +\end{itemize} + +\subsubsection{ Correspondence table } + +You can keep in mind the following table to write code using lwt: + + + +\noindent +\begin{tabular}{p{0.5\textwidth}p{0.5\textwidth}} +\multicolumn{1}{l}{\begin{minipage}{0.5\textwidth}\centering without {\tt Lwt} \end{minipage}}&\multicolumn{1}{l}{\begin{minipage}{0.5\textwidth}\centering with {\tt Lwt} \end{minipage}}\\ + & \\ + {\tt let} \emph{pattern$_{\mbox{1}}$} {\tt =} \emph{expr$_{\mbox{1}}$} & {\tt lwt} \emph{pattern$_{\mbox{1}}$} {\tt =} \emph{expr$_{\mbox{1}}$} \\ + {\tt and} \emph{pattern$_{\mbox{2}}$} {\tt =} \emph{expr$_{\mbox{2}}$} & {\tt and} \emph{pattern$_{\mbox{2}}$} {\tt =} \emph{expr$_{\mbox{2}}$} \\ + ... & ... \\ + {\tt and} \emph{pattern$_{\mbox{n}}$} {\tt =} \emph{expr$_{\mbox{n}}$} {\tt in} & {\tt and} \emph{pattern$_{\mbox{n}}$} {\tt =} \emph{expr$_{\mbox{n}}$} {\tt in} \\ + \emph{expr} & \emph{expr} \\ + & \\ + {\tt try} & {\tt try\_lwt} \\ + \emph{ expr} & \emph{ expr} \\ + {\tt with} & {\tt with} \\ + \emph{ } {\tt |} \emph{pattern$_{\mbox{1}}$} {\tt ->} \emph{expr$_{\mbox{1}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{1}}$} {\tt ->} \emph{expr$_{\mbox{1}}$} \\ + \emph{ } {\tt |} \emph{pattern$_{\mbox{2}}$} {\tt ->} \emph{expr$_{\mbox{2}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{2}}$} {\tt ->} \emph{expr$_{\mbox{2}}$} \\ + \emph{ } ... & \emph{ } ... \\ + \emph{ } {\tt |} \emph{pattern$_{\mbox{n}}$} {\tt ->} \emph{expr$_{\mbox{n}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{n}}$} {\tt ->} \emph{expr$_{\mbox{n}}$} \\ + & \\ + {\tt for} \emph{ident} {\tt =} \emph{expr$_{\mbox{init}}$} {\tt to} \emph{expr$_{\mbox{final}}$} {\tt do} & {\tt for\_lwt} \emph{ident} {\tt =} \emph{expr$_{\mbox{init}}$} {\tt to} \emph{expr$_{\mbox{final}}$} {\tt do} \\ + \emph{ expr} & \emph{ expr} \\ + {\tt done} & {\tt done} \\ + & \\ + {\tt raise} \emph{exn} & {\tt raise\_lwt} \emph{exn} \\ + & \\ + {\tt assert} \emph{expr} & {\tt assert\_lwt} \emph{expr} \\ + & \\ + {\tt match} \emph{expr} {\tt with} & {\tt match\_lwt} \emph{expr} {\tt with} \\ + \emph{ } {\tt |} \emph{pattern$_{\mbox{1}}$} {\tt ->} \emph{expr$_{\mbox{1}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{1}}$} {\tt ->} \emph{expr$_{\mbox{1}}$} \\ + \emph{ } {\tt |} \emph{pattern$_{\mbox{2}}$} {\tt ->} \emph{expr$_{\mbox{2}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{2}}$} {\tt ->} \emph{expr$_{\mbox{2}}$} \\ + \emph{ } ... & \emph{ } ... \\ + \emph{ } {\tt |} \emph{pattern$_{\mbox{n}}$} {\tt ->} \emph{expr$_{\mbox{n}}$} & \emph{ } {\tt |} \emph{pattern$_{\mbox{n}}$} {\tt ->} \emph{expr$_{\mbox{n}}$} \\ + & \\ + {\tt while} \emph{expr} {\tt do} & {\tt while\_lwt} \emph{expr} {\tt do} \\ + \emph{ expr} & \emph{ expr} \\ + {\tt done} & {\tt done} \\ +\end{tabular} + +\subsection{ Backtrace support } + +When using {\tt Lwt}, exceptions are not recorded by the ocaml runtime, and so you can not +get backtraces. However it is possible to get them when using the syntax extension. All you +have to do is to pass the {\tt -lwt-debug} switch to {\tt camlp4}: + + + +\begin{verbatim} +$ ocamlfind ocamlc -syntax camlp4o -package lwt.syntax \ + -ppopt -lwt-debug -linkpkg -o foo foo.ml + +\end{verbatim} + +\subsection{ Other modules of the core library } + +The core library contains several modules that depend only on +{\tt Lwt}. The following naming convention is used in {\tt Lwt}: when a +function takes as argument a function returning a thread that is going +to be executed sequentially, it is suffixed with ``{\tt \_s}''. And +when it is going to be executed in parallel, it is suffixed with +``{\tt \_p}''. For example, in the {\tt Lwt\_list} module we have: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t +val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +\end{lstlisting} +\subsubsection{ Mutexes } + +{\tt Lwt\_mutex} provides mutexes for {\tt Lwt}. Its use is almost the +same as the {\tt Mutex} module of the thread library shipped with +OCaml. In general, programs using {\tt Lwt} do not need a lot of +mutexes. They are only usefull for serialising operations. + + + +\subsubsection{ Lists } + +The {\tt Lwt\_list} module defines iteration and scanning functions +over lists, similar to the ones of the {\tt List} module, but using +functions that return a thread. For example: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t +val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + +\end{lstlisting} +In {\tt iter\_s f l}, {\tt iter\_s} will call f on each elements +of {\tt l}, waiting for completion between each elements. On the +contrary, in {\tt iter\_p f l}, {\tt iter\_p} will call f on all +elements of {\tt l}, then wait for all the threads to terminate. + + + +\subsubsection{ Data streams } + +{\tt Lwt} streams are used in a lot of places in {\tt Lwt} and its sub +libraries. They offer a high-level interface to manipulate data flows. + + + +A stream is an object which returns elements sequentially and +lazily. Lazily means that the source of the stream is guessed for new +elements only when needed. This module contains a lot of stream +transformation, iteration, and scanning functions. + + + +The common way of creating a stream is by using +{\tt Lwt\_stream.from} or by using {\tt Lwt\_stream.create}: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val from : (unit -> 'a option Lwt.t) -> 'a Lwt_stream.t +val create : unit -> 'a Lwt_stream.t * ('a option -> unit) + +\end{lstlisting} +As for streams of the standard library, {\tt from} takes as +argument a function which is used to create new elements. + + + +{\tt create} returns a function used to push new elements +into the stream and the stream which will receive them. + + + +For example: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# let stream, push = Lwt_stream.create ();; +val stream : '_a Lwt_stream.t = +val push : '_a option -> unit = +# push (Some 1);; +- : unit = () +# push (Some 2);; +- : unit = () +# push (Some 3);; +- : unit = () +# Lwt.state (Lwt_stream.next stream);; +- : int Lwt.state = Return 1 +# Lwt.state (Lwt_stream.next stream);; +- : int Lwt.state = Return 2 +# Lwt.state (Lwt_stream.next stream);; +- : int Lwt.state = Return 3 +# Lwt.state (Lwt_stream.next stream);; +- : int Lwt.state = Sleep + +\end{lstlisting} +Note that streams are consumable. Once you take an element from a +stream, it is removed from it. So, if you want to iterates two times +over a stream, you may consider ``clonning'' it, with +{\tt Lwt\_stream.clone}. Cloned stream will returns the same +elements in the same order. Consuming one will not consume the other. +For example: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# let s = Lwt_stream.of_list [1; 2];; +val s : int Lwt_stream.t = +# let s' = Lwt_stream.clone s;; +val s' : int Lwt_stream.t = +# Lwt.state (Lwt_stream.next s);; +- : int Lwt.state = Return 1 +# Lwt.state (Lwt_stream.next s);; +- : int Lwt.state = Return 2 +# Lwt.state (Lwt_stream.next s');; +- : int Lwt.state = Return 1 +# Lwt.state (Lwt_stream.next s');; +- : int Lwt.state = Return 2 + +\end{lstlisting} +\subsubsection{ Mailbox variables } + +The {\tt Lwt\_mvar} module provides mailbox variables. A mailbox +variable, also called a ``mvar'', is a cell which may contains 0 or 1 +element. If it contains no elements, we say that the mvar is empty, +if it contains one, we say that it is full. Adding an element to a +full mvar will block until one is taken. Taking an element from an +empty mvar will block until one is added. + + + +Mailbox variables are commonly used to pass messages between threads. + + + +Note that a mailbox variable can be seen as a pushable stream with a +limited memory. + + + +\section{ Running a Lwt program } + +Threads you create with {\tt Lwt} always have the type +{\tt Lwt.t}. If you want to write a program and run it this is not +enough. Indeed you don't know when a {\tt Lwt} thread is terminated. + + + +For example if your program is just: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +let _ = Lwt_io.printl "Hello, world!" + +\end{lstlisting} +you have no guarantee that the thread writing {\tt "Hello, world!"} +on the terminal will be terminated when the program exit. In order +to wait for a thread to terminate, you have to call the function +{\tt Lwt\_main.run}: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val Lwt_main.run : 'a Lwt.t -> 'a + +\end{lstlisting} +This functions wait for the given thread to terminate and returns +its result. In fact it does more than that; it also run the +scheduler which is responsible for making thread to progress when +events are received from the outside world. + + + +So basically, when you write a {\tt Lwt} program you must call at +the toplevel the function {\tt Lwt\_main.run}. For instance: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +let () = Lwt_main.run (Lwt_io.printl "Hello, world!") + +\end{lstlisting} +Note that you must call {\tt Lwt\_main.run} only once at a time. It +cannot be used anywhere to get the result of a thread. It must only +be used in the entry point of your program. + + + +\section{ The {\tt lwt.unix} library } + +The package {\tt lwt.unix} contains all {\tt unix} dependant +modules of {\tt Lwt}. Among all its features, it implements cooperative +versions of functions of the standard library and the unix library. + + + +\subsection{ Unix primitives } + +The {\tt Lwt\_unix} provides cooperative system calls. For example, +the {\tt Lwt} counterpart of {\tt Unix.read} is: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val read : file_descr -> string -> int -> int -> int Lwt.t + +\end{lstlisting} +{\tt Lwt\_io} provides features similar to buffered channels of +the standard library (of type {\tt in\_channel} or +{\tt out\_channel}) but cooperatively. + + + +{\tt Lwt\_gc} allow you to register finaliser that return a +thread. At the end of the program, {\tt Lwt} will wait for all the +finaliser to terminates. + + + +\subsection{ The Lwt scheduler } + +Threads doing IO may be put asleep until some events are received by +the process. For example when you read from a file descriptor, you +may have to wait for the file descriptor to become readable if no +data are immediatly available on it. + + + +{\tt Lwt} contains a shceduler which is responsible for managing +multiple threads waiting for events, and restart them when needed. +This scheduler is implemented by the two modules {\tt Lwt\_engine} +and {\tt Lwt\_main}. {\tt Lwt\_engine} is a low-level module, it +provides signatures for IO multiplexers as well as several builtin +implementation. {\tt Lwt} support by default multiplexing IO with +{\tt libev} or {\tt Unix.select}. The signature is given by the +class {\tt Lwt\_engine.t}. + + + +{\tt libev} is used by default on Unix, because it supports any +number of file descriptors while Unix.select supports only 1024 at +most, and is also much more efficient. On Windows {\tt Unix.select} +is used because {\tt libev} does not works properly. The user may +change at any time the backend in use. + + + +The engine can also be used directly in order to integrate other +libraries with {\tt Lwt}. For example {\tt GTK} need to be notified +when some events are received. If you use {\tt Lwt} with {\tt GTK} +you need to use the {\tt Lwt} scheduler to monitor {\tt GTK} +sources. This is what is done by the {\tt lwt.glib} package. + + + +The {\tt Lwt\_main} module contains the \emph{main loop} of +{\tt Lwt}. It is run by calling the function {\tt Lwt\_main.run}: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val Lwt_main.run : 'a Lwt.t -> 'a + +\end{lstlisting} +This function continously run the scheduler until the thread passed +as argument terminates. + + + +\subsection{ The logging facility } + +The package {\tt lwt.unix} contains a module {\tt Lwt\_log} +providing loggers. It support logging to a file, a channel, or to the +syslog daemon. You can also defines your own logger by providing the +appropriate functions (function {\tt Lwt\_log.make}). + + + +Several loggers can be merged into one. Sending logs on the merged +logger will send these logs to all its components. + + + +For example to redirect all logs to {\tt stderr} and to the syslog +daemon: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# Lwt_log.default_logger := + Lwt_log.broadcast [ + Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr (); + Lwt_log.syslog ~facility:`User (); + ] +;; + +\end{lstlisting} +{\tt Lwt} also provides a syntax extension, in the package +{\tt lwt.syntax.log}. It does not modify the language but +it replaces log statement of the form: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +Lwt_log.info_f ~section "something happened: %s" msg + +\end{lstlisting} +by: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +if Lwt_log.Section.level section <= Lwt_log.Info then + Lwt_log.info_f ~section "somethign happend: %s" msg +else + Lwt.return () + +\end{lstlisting} +The advantages of using the syntax extension are the following: + + + +\begin{itemize} +\item it check the log level before calling the logging function, so +arguments are not computed if not needed +\item debugging logs can be removed at parsing time + +\end{itemize} + +By default, the syntax extension remove all logs with the level +{\tt debug}. To keep them pass the command line option +{\tt -lwt-debug} to camlp4. + + + +\section{ The Lwt.react library } + +The {\tt Lwt\_react} module provide helpers for using the {\tt react} +library with {\tt Lwt}. It extends the {\tt React} module by adding +{\tt Lwt} specific functions. It can be used as a replacement of +{\tt React}. For example you can add at the beginning of you +program: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +open Lwt_react + +\end{lstlisting} +instead of: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +open React + +\end{lstlisting} +or: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +module React = Lwt_react + +\end{lstlisting} +Among the added functionnality we have {\tt Lwt\_react.E.next}, which +takes an event and returns a thread which will wait until the next +occurence of this event. For example: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# open Lwt_react;; +# let event, push = E.create ();; +val event : '_a React.event = +val push : '_a -> unit = +# let t = E.next event;; +val t : '_a Lwt.t = +# Lwt.state t;; +- : '_a Lwt.state = Sleep +# push 42;; +- : unit = () +# Lwt.state t;; +- : int Lwt.state = Return 42 + +\end{lstlisting} +Another interesting feature is the ability to limit events +(resp. signals) to occurs (resp. to changes) too often. For example, +suppose you are doing a program which displays something on the screeen +each time a signal changes. If at some point the signal changes 1000 +times per second, you probably want not to render it 1000 times per +second. For that you use {\tt Lwt\_react.S.limit}: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val limit : (unit -> unit Lwt.t) -> 'a React.signal -> 'a React.signal + +\end{lstlisting} +{\tt Lwt\_react.S.limit f signal} returns a signal which varies as +{\tt signal} except that two consecutive updates are separeted by a +call to {\tt f}. For example if {\tt f} returns a thread which sleep +for 0.1 seconds, then there will be no more than 10 changes per +second. For example: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +open Lwt_react + +let draw x = + (* Draw the screen *) + ... + +let () = + (* The signal we are interested in: *) + let signal = ... in + + (* The limited signal: *) + let signal' = S.limit (fun () -> Lwt_unix.sleep 0.1) signal in + + (* Redraw the screen each time the limited signal change: *) + S.notify_p draw signal' + +\end{lstlisting} +\section{ The lwt.text library } + +The {\tt lwt.text} library provides functions to deal with text +mode (in a terminal). It is composed of the three following modules: + + + +\begin{itemize} +\item {\tt Lwt\_text}, which is the equivalent of {\tt Lwt\_io} +but for unicode text channels +\item {\tt Lwt\_term}, providing various terminal utilities, such as +reading a key from the terminal +\item {\tt Lwt\_read\_line}, which provides functions to input text +from the user with line editing support + +\end{itemize} + +\subsection{ Text channels } + +A text channel is basically a byte channel plus an encoding. Input +(resp. output) text channels decode (resp. encode) unicode characters +on the fly. By default, output text channels use transliteration, so +they will not fails because text you want to print cannot be encoded +in the system encoding. + + + +For example, with you locale sets to ``C'', and the variable +{\tt name} set to ``Jérémie'', you got: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# lwt () = Lwt_text.printlf "My name is %s" name;; +My name is J?r?mie + +\end{lstlisting} +\subsection{ Terminal utilities } + +The {\tt Lwt\_term} allow you to put the terminal in \emph{raw mode}, +meanings that input is not buffered and character are +returned as the user type them. For example, you can read a key with: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# lwt key = Lwt_term.read_key ();; +val key : Lwt_term.key = Lwt_term.Key_control 'j' + +\end{lstlisting} +The second main feature of {\tt Lwt\_term} is the ability to prints +text with styles. For example, to print text in bold and blue: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# open Lwt_term;; +# lwt () = printlc [fg blue; bold; text "foo"];; +foo + +\end{lstlisting} +If the output is not a terminal, then {\tt printlc} will drop +styles, and act as {\tt Lwt\_text.printl}. + + + +\subsection{ Read-line } + +{\tt Lwt\_read\_line} provides a full featured and fully +customisable read-line implementation. You can either use the +high-level and easy to use {\tt read\_*} functions, or use the +advanced {\tt Lwt\_read\_line.Control.read\_*} functions. + + + +For example: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +# open Lwt_term;; +# lwt l = Lwt_read_line.read_line ~prompt:[text "foo> "] ();; +foo> Hello, world! +val l : Text.t = "Hello, world!" + +\end{lstlisting} +The second class of functions is a bit more complicated to use, but +allow to control a running read-line instances. For example you can +temporary hide it to draw something, you can send it commands, fake +input, and the prompt is a signal so it can change dynamically. + + + +\section{ Other libraries } + +\subsection{ Detaching computation to preemptive threads } + +It may happen that you want to run a function which will take time to +compute or that you want to use a blocking function that cannot be +used in a non-blocking way. For these situations, {\tt Lwt} allow you to +\emph{detach} the computation to a preemptive thread. + + + +This is done by the module {\tt Lwt\_preemptive} of the +{\tt lwt.preemptive} package which maintains a spool of system +threads. The main function is: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +val detach : ('a -> 'b) -> 'a -> 'b Lwt.t + +\end{lstlisting} +{\tt detach f x} will execute {\tt f x} in another thread and +asynchronously wait for the result. + + + +The {\tt lwt.extra} package provides wrappers for a few blocking +functions of the standard C library like {\tt gethostbyname} (in +the module {\tt Lwt\_lib}). + + + +\subsection{ SSL support } + +The package {\tt lwt.ssl} provides the module {\tt Lwt\_ssl} +which allow to use SSL asynchronously + + + +\subsection{ Glib integration } + +The {\tt lwt.glib} embed the {\tt glib} main loop into the +{\tt Lwt} one. This allow you to write GTK application using {\tt Lwt}. The +one thing you have to do is to call {\tt Lwt\_glib.install} at +the beginning of you program. + + + +\section{ Writing stubs using {\tt Lwt} } + +\subsection{ Thread-safe notifications } + +If you want to notify the main thread from another thread, you can use the {\tt Lwt} +thread safe notification system. First you need to create a notification identifier +(which is just an integer) from the OCaml side using the +{\tt Lwt\_unix.make\_notification} function, then you can send it from either the +OCaml code with {\tt Lwt\_unix.send\_notification} function, or from the C code using +the function {\tt lwt\_unix\_send\_notification} (defined in {\tt lwt\_unix\_.h}). + + + +Notification are received and processed asynchronously by the main thread. + + + +\subsection{ Jobs } + +For operations that can not be executed asynchronously, {\tt Lwt} uses a +system of jobs that can be executed in a different threads. A job is +composed of four functions: + + + +\begin{itemize} +\item A function to create the job, which creates a job structure info +and stores parameters in it. This function is executed in the +main thread. +\item A function which execute the job. This one may be executed asynchronously +in another thread. +\item A function which read the result of the job. This function is +executed in the main thread. +\item And finally a function that free resources allocated for the +job, which is also executed in the main thread. + +\end{itemize} + +We show as example the implementation of {\tt Lwt\_unix.mkdir}. On the C +side we have: + + + +\lstset{language=c}\begin{lstlisting}/* The job info structure */ +struct job_mkdir { + /* Informations required by lwt. + It must be the first field of the structure. */ + struct lwt_unix_job job; + + /* The name of the directory to create. */ + char *name; + + /* Permissions for the directory. */ + int perms; + + /* The result of the call to mkdir. */ + int result; + + /* The errno value after the call. */ + int error_code; +}; + +/* Convenient macro for retrieving a mkdir job info structure from an + ocaml custom value. */ +#define Job_mkdir_val(v) *(struct job_mkdir**)Data_custom_val(v) + +/* The function that effectively executes the job. */ +static void worker_mkdir(struct job_mkdir *job) +{ + /* Call mkdir and save its result. */ + job->result = mkdir(job->name, job->perms); + + /* Save the contents of [errno]. */ + job->error_code = errno; +} + +/* The stub that create the job. */ +CAMLprim value lwt_unix_mkdir_job(value val_name, value val_perms) +{ + struct job_mkdir *job = lwt_unix_new(struct job_mkdir); + + /* Sets the worker for this job. */ + job->job.worker = (lwt_unix_job_worker)worker_mkdir; + + /* Copy the name of the directory into the C memory. */ + job->name = lwt_unix_strdup(String_val(val_name)); + + /* Copy the perms parameter. */ + job->perms = Int_val(val_perms); + + /* Put the job into an ocaml custom value and returns it. */ + return lwt_unix_alloc_job(&(job->job)); +} + +/* The stub that read the result of the job. */ +CAMLprim value lwt_unix_mkdir_result(value val_job) +{ + struct job_mkdir *job = Job_mkdir_val(val_job); + + /* If mkdir failed, raise the unix error now. */ + if (job->result < 0) unix_error(job->error_code, "mkdir", Nothing); + + return Val_unit; +} + +/* The stub that free resources. */ +CAMLprim value lwt_unix_mkdir_free(value val_job) +{ + struct job_mkdir *job = Job_mkdir_val(val_job); + + /* Free the name of the directory. */ + free(job->name); + + /* Free resources allocated by lwt_unix for this job. */ + lwt_unix_free_job(&job->job); + + return Val_unit; +} +\end{lstlisting} +and on the ocaml side: + + + +\lstset{language=[Objective]Caml}\begin{lstlisting} +(* The stub for creating the job. *) +external mkdir_job : string -> int -> [ `unix_mkdir ] job = "lwt_unix_mkdir_job" + +(* The stub for reading the result of the job. *) +external mkdir_result : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_result" + +(* The stub reading the result of the job. *) +external mkdir_free : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_free" + +(* And finally the ocaml function. *) +let mkdir name perms = + Lwt_unix.execute_job (mkdir_job name perms) mkdir_result mkdir_free + +\end{lstlisting} \ No newline at end of file diff --git a/thirdparty/lwt-2.3.2/manual/manual.pdf b/thirdparty/lwt-2.3.2/manual/manual.pdf new file mode 100644 index 0000000000000000000000000000000000000000..6aa1da876984b0a6d9c8f5c34feed4669624528e GIT binary patch literal 239218 zcmb?^cRbba`@az)n-UqvjM8z=!LfIV%#6t1d#}hUdkfh+DW^NXoa?@?*R}5JdfwN4qnEuZdIbt*!=mr%YZ%0Wf*>GE9TO~GUJ#2s zh~>Jaf+dLMDu~fmU)Rpq(gF-+0`c=>>09U_zQnfwWk!&=g`JJ1p8ei;KuiZeXa66A z!440``QKm)M*1MhJ9Z#lOB;QVnX!(IwvE%zLAic6sJ+esldz*~LSg?6{bN`QU41J% z+n+;1S^s9tBiusa|BWeYV{C40XY8PF3o@{@0ofVZ=xghNbb-GS5<4^t#~)@n%=|Cx z!yx}_Dob-KOIv`2!?VGDt4Uz0qq7}(G1yO~if99ZGSk*E)8BuoLn4FyR=3B7XFaTC z*iSY8A~$n;Gdtre2huz7mHwpqqp!qvcuv-z`d8RfjxET{QdipyWNT+>qiv}FQ$?(Q zGK8ZuupgP>r!~mgn*oOKp9`@5N$LAO1p^-u5!+9FBRs*@$-++C5v1>Er*C0 zt76up{=jxf#g;ZU`nFb<7JB-Cu0eKt%Kndewm&KPKjx3fn(e24g|&4}?QFDxVQuZL ztSoKpeoBSyPn!I1;3Fbt|EWY7J0pD?kU0=<5Tdp;0IXC0H^GAaZxzaZR7C7Q6)I(K zr|)=JrR;xF>0u*b2Ose)_)on`8rvR@Kk&a*B>PcIf&WzGRc$+Mz@CAiV}8i`;D1u! zQC5#=5&lz)QrgC5I+l(g2W=Z;gmoMq{kK}&SK$$}=J=^VIeQBWV+%u&_FkB`vavL@ z(Ki2S9UQ+^+Wxplc;)!1Dulb3-LV7PTNpbYUpP4aq_=~SkD3AJPn9Vm#i=^R z&Oa&dzhRG90_RV?Ay`H%O18R2`Urcr`6&j@KPm6Ofse?T^QYeSWMOG&h>){^wyv?6 zvE89Xl=FY7?uhSk{Z!pPzhJ=7bnTAInCpM34t_XnavfJ4;A6#T zh(UFYv@I<3%?{Zw6!I6UgCBKbDCCgt^li+IEr4~z-VPyNlz_!Ocz+O z?d^V~Ja(3Vr|9dOTOqQdU23^p6S8zPoVzBJe}W&UHXK zAY%(VeIOPc&7`2e&vo{PU<fL$E4=q4Sta}>rc=NSVYaV?ewqe>sspR zV*zExkM#`8ad=)u%60^fU%jdHMXclDY2=B(H-l1{q*=3^pP1(FM``)X2lUD6O>Av0 z5F*hR24sXpN}J5;+%G6cdbhyOO!@HC3JCL^20aG9rcAy@bt+9t0OXP*#Od^TrK>{n zH>8Zv)r-gE9XB(AC)l*LpTUF8udH0sfqkYS`*>5b4z^*tj2qN^Pc9tuW!L$^_82Uk zO#hC@rK@0_OIx(s#`XGS9?#op&$Jgow5YJ(6SqFf={CYYLv!~s)3}<-<(h%-?+mwe zqX>G(U5Rxs7-A%ET{QKke>m(9jX8gj3EP7xFxzM9B}}(NEXv6AYeoK}hdxgVsZ76R zV!^`2AxJC?5FBMHdrMj6yKysLNE|)A&E+Qx#`EIK&<0;M*WL4CLT6cHNq4yR;?C>y zwv7yD>IH2vDy8d;N6(L33fyF{eBsvnHJ9VAX&Ds5GE=hdu5(towU~f8^(Yb(uB=o$ z)-7^*bXL$!=I{^KH^*+T>2_dSQORBUPAo5et?7<)MB$kj+n1I&dieEsRR^^+RDF5- zg3U_;8$Ym`typ2T^B3sE31TJ1Ylhs56@tqz6hxs8xYpWcAe-ZrQi`+_n0)aTf*1Sg zYA`DaGIQs>@xG>UbKPT{*!NLcsOr^aZj468mCYWr*Gz(O;yXn}n{>4;p0$~;y^L!5 z?e$gbFK7&sWDu`CBMCi!$4|;-hWecTC@r*IVzbI(jv-m(!42!O_yK;$ej!J1&u{sc zp}6$z;KIl z4@{`(@;Q4b!L9JBmS32*)6&G>y!$b7WvP{XQX2VA968p~_*Wa%yqlk!$}1i+Ui9Cj zUHaym5MR~q>WbU2NhlF>HOo*Vo%e$AbD?3XkayG9j7z&Up!W8Y)2CzjEwS(&Up<1k3pS7RgHOMikcf zJzh`9s-G;{h(7MqKmym4q~`{_<||?+x!NMc^zK}ke766i?A_?-*6WvG^favwy|H+g zmKV=b@>81A7mziR+|C4JG)$*+JHz_dL3DVA^+J7`GSEp91D|NNjHfeS9O*6Yy89{1qt z7aY`$%iM3OMLye@k#Lc;e4}k!_N@OTr-ED0?XPvpl)O{*kPIz+8Ij ze~U|as|&pGUIRqGM&~D97>eFdxSBy`^rf-n7M>cm>ZNy%_D?FY7b71JM<+KjE4|nu zSC=wr+1-uia3*J$CS@-ecpX}M^Vzw$D`;oAwdHSeSEkpyPZP=LT2c#{X`Nexy{?6J zi55xEG+<<{ycG4w5EPa>RVeBAwdU>c&d1J(+!|!mFKx02%w#{_?V~F{0xE#B>_trl zCo6pri!4yCVzG!=0_&6oP(l0%ta4Z^a{9KG_BOge1_Is7o`L_8($_QA76vkRRYW2L z2eJVUE|@wNFoX?23xe(?p}_ZqEP#c>7NiP-vLePHQ8n5+H#`5$n_$qopG6T}W>1H*u<49Wo%&w!n^OAgrGm z(g9+2n793!V(Q2pHfF1Y?DQxquv*jgt!y z=kLXLl*8jP+^?_xr3~S4FdN{ptS}fD4!{*`96%Am{=g4sD)0rdh>g8v_&|CPI2aE2E|iM{utPYA4GKIt{z7`kOm8n2_@}(F za@L%ntj#@b)WT82Fgg9YD?h!0HY(%gPBb2jn+Ugdl-%&C10J zW@BgnE6pB2(}y+t?-vkO4j7mNa9ao%0dWCK2>5TgI~JPv^0|Mb+yCSThwLR!z=8p0 z1KgGs&IM*?`&$l=`R-n(`Hwkd1JXMHR)rz*DgfYOW#<6@U0`MhANP)bw{+}hp{$5R ziWSHY0FPw{5@S|Yc7WaA1m=C$I4-t-w_Y5u1z`n406Y=O#R+Bu0t+jUQ*pw7qt|`5 zj!WyGuM#jWAa@7K3xvDwxdV_*ad2_{)?E)c+Xw0nd+NViCH7-53~)^dP>LZ$#tAGE zFd&cOVrTo`ydCq?gAJ*F5a$kfg9BJG5ZYmYytoj&0T~q6-^lHlsU2*I{R7_iO%28d z&Z|D&K#@)`2DgM+7oUU_syj!+`|>2IRyr$ZzVypLx>3Cd^^p{#_|? zz#Cv)KvD^a3|PE@?LR~=2Y|^Zi|jCO$35WR6%qTqK>=@M!W4hqd|dmVg6^0VM)Eus6#JB)@O~ z;(-GB8yoC5OTbTU9&Ab-=Ix)a0{{dDtE+$1Dv9hI>t4d$IN^=)avD7UkP2APy*q1K3)#us1V1 z0+bzWyPr%1fQ`V0-7%tr{q)}vvBQCM0Ij9?W{P+u)*Bbmj8Z3_r-hPZdvB&l zTvoT8Sd7RSpP`1+(bem{c5-vN8$u9r&q_(#|5;(h?KyN0ENLD;3?nu+FDxlkYYf$K zQ*rca$H$&TSuXhMpEh)_1as&}PET7)cTOs}2E?~blenad-;}n_taO(^D{<*Ne=8~u z4}U4>_Oh6%xb^UB_VLjSMZ@hyk`?a`2=|8* z?79?CZ>8`#JFg=Zw7U_KvAI;d57IwZyUISA-(PJ-2t|c43B28SX(}&z@`k|3QTZya7)r0z*Pz(m=)q2P%8WA3&u4cssVf zAN0fg7jO1#4u}GOifjjcH^0Q1BS8d#f$Rs4!x820f(X}P*!&=fz<^lxm%HJm$`YZI zcY{DlXce<&l-4mP}Fi+gXa~s?N79t;XEuZVNx%VqJ+5EaVl) z&NpTc71)j3HQvN6yWBVYdQM95tW}2SoDWyWz&GCIwd~g-PfZ6?6B>CYO2g^ik)Ua| z+LaG_R*^aA-=LN~@O^qgv(Bqo)f8$^wmmQ zrP%&DE+5_*guO64&2{^3@@Hjw&a{dl)^BG*U@1hF?maFYtj1WBA!^U09s6F5-Dk0{ zog#VeO}|JzRP$XUIaV#VY}InMVmyKab1SQ1H+62Tv@$KaH;16Ts5YUsK?C=LL$2CN zftH}VCoh3vqH=Y7GyAAM{(E8KI2HF!iA(%M;o~+ib`0FX+dP;VDb-WEby~wdPUlny z#f023yDzS~+CS5h=OU6L3Cc{Ynap}wvnH42{2@iMcws%al(|N|l{17X%rn916GTk^ zHf9`koZfAM(#CI+xmQ%>VmnwH9Ofm?8yj#uz_**l@)0In2<&wgAbS*4vJBI?bIwB< z>4sC7sC!YG_^B;&Tc(=6LUMa%5Eipg6y7id)wc%ynNjC6ye23{F;O}OW%wkudYva% z*n_h>otMVYI#AlG?+JU&37$#%sy%rV*x!10Ze+&NRkS2#3(aJw&TV<>QO`a z<%A+>n*NA>4pW zv+f#fLU*5{*btg+va3Z{3oDLh*mxjVi6B*dfcDuOQN`Q`tN9V(4|#(w7p& zWclU@$=Ve@o!{cInbr5ks%FWeJ`U-gV`jeo7<*Z>m}_i z=6#0P>V7BRQw?(G5jK@InOgs1c>P-+=fc~kUzt#Rn)sSezJeUpP(YQ$2~(ar~r z;?Mis_y$?a*DWSdXit$SFVUsteneP*{RvCz92%W-FvBc7IG6Wcy(>A>giZ3PsM$%u zi#OV^xrXvF?O(m=2*QiF7R=xIf*Q#K*H`LH!WWI39Y%$#u89%M@1kZo7%8mmmR2oL zcdb#vQwcqI=oIAEeXdj7zIB!^3BA-_7==%$IeK^fTBurF$Wyeu*|-`sn~MZV)XL5F zkiNW|S{Ek1r&MKMYgCV?QzWnqv@FIX&h~=3eLijTc@c+?SRAeO>OJ<0E;k;MkjqcQ z3xo|D#QOu%!D7}dFL7-W)6$ch;x-r;MAuaPn$2PGIx*}wNeg^uFp$eYQS@NJ~?F4*t;KMX$$ zRdG6H1z~>ww)c#+HS5fn;9UIcZ+NmiwSxk(tRZRN#?mkLvM&m_RVlHc>?)5N$vDrW zy5D=k9C$}7m4n8dB>FZq?m?2@ps4c#x$#Gtk2FeVF|R(}_@;2iU#BB=RXNmUil%R7 z8zYK8wy+k-m+ESXeKq;JIO!EXEzG56uZxzX8c(k|Qp+x)S@u7qJk|6PPh#sc4GO)I z{lzO{=Scdc@KF55LE|G!tV~x;Mm~x1ueVny8?8$_7&Yt?VQVRf`SPAkdJxRG+<$SE zKqHws^64esk?-rMDI+e5SIwgfzg`GIKkb7PuldZPkB6S0Nb}Q~_z-mPt$z|ra=Kjp2JBsovuRmV;susl?M%F=Btbi1` zeATjbEnivb&Quut?aMHI-PU*mZh5z&!Mqld!8PWy9W)$YR$GVOvvllmMs#sX=}nYC zdgx;%ycL{aHC%OfX^E`@xS~q*ZS2>cCM7dTP6c@*r}(mSm5@9S>(Lhvw0*m|s{XLS zYKouamPCx^nTuDR?y^+PKs1-NKPDtsC3e^ZR<#$4OMIp1M(Z|xlq=*)I+w9T^pa&q zqxYNYBaW+guDa9RmHui2acE7{Olr9?=WVw^e2Y@wSHe78Uk>TD--Y7YHgN$bWR_{8 zGoz4idHhJhT75Ju>Wy07rxB^wAIRsTukl4jkdaAf zRVMJF;>gfD;GvevifdNl$eKTX!p)f`Dlw=KGhJp5R+^G}EBEXwJZyEm_$u>^ADYUP zNF7RLKqG5Fm zZPoTHD=Ir4)lR8rshL~4sD@YyMatv2Z_|1D%~X>y@rNT~&ExB?k2fS~<5poNVjl9C3BB6suR*AeAMC?btQBJj<{RQwHS}6qxcPC2 zn?=qLcYXzR&GdOkSmK%;1y@A~@2YKIXKy~m{BUo+?q=LfxKYW1T$0Y{%kZj~B;c;@ zt8$lBq)iGxlx*)pcc033!UWbmKD{w3hp?D14Cr0GQ33+%>iZ0%&FPU=6lo*TFmjOu zK#1d49Qm~Rrx;2!>$Z`~qM50QF<#5H4%0w1ElVw`DY5v2EBX_zCWdjj5aB3sN$QP3RjX zX01AfA5n^RlkfXpJ!GnJQ9|x-%~5gh=v2h!@2k)+ zzI;TkLTG+pnw9Lv2GVMdC}=W7GJ%I$YK@iw&cu24UC_nM2*+CSjB%vZESg7`#xyUG z4qYXvd*s_gL3^27k_@+)?kpvFW^UQ@p~|zE8r_N=&meV|m(x+Ia%k^ik+45PRjHKr zeT}ph-Kvq)kAuX0=8dbOofR&wq7;^?t64QGMt7L!Tt$Tjp$ zRWLS5t^BD5lpQKmY@@h7Tqq+ZJXcTWf|jaaL28uw1$?81$E1&h9|fc>&}vw$zw>`5 ze~!iFU0}@WIs3-+mmRf)`C2^fSY6l!?iXsQm>D=@ts*sG#V;={>g$(x=a z<=wcb*Oz37=h8av(@xvf@<<^7tur*=mV#81GU1_pDd*6Nx2nW<1%6U5m{xbmx7VOP zS{BXduz=dLsy)R#wT4|t5Wj2vD1sCC7CemXryhR{LdD1Bbj8Zo2BlKykk(!}%NLu8 z_PyCMTPhpdi*7>SF^TbVtvY4fn0!;q)Fr3}Ceiq73TSD{^e5%|N5h3T1)#ik{G;RC zUD*!@%)6;j@@F(%@P+PfI@(TM_eTtM5!CRt8VTC8})+ zg55wQ0uKYXB0lK6yxBk0dz*c3{GGgvem{DCn~2$)Z|fL zw)%+sJFCb6otl%gZC;)@3n5LB+qn5Jz!0@y-YWucvaHypP?azfwUVfGl{E%J5p_MvyBCOTzgPQLKdEK#dVtX&`}xcCJ#*D- zbcKy6B+8`Zloe{pSZ5!4_pV=+B}nxsiW2q}pcxUtWR=eU=D%t2pnUfR?46MIbo0x( z1S~W>XK9l4)-Swag=F_Uozz-1NUzvQdIt-=_PHm@=NDjy*WR!t_Fk6h-i0jv+MNX5 z^o*{Ktxk|M{gW>$e9{|M+UH|;NvN~ps%SGVVYHN`8cKAMU8nkl{$*;*S>Ajx{$5kS z=$<@}Zm2HE?VNQLMGxPWZ=mi5J!{;}qlR3Ue=d{nC&cwl|9991Mx`9v7 zT;$%um%C6o%*5$Rg`V}WFXd>Sm+v&wQR;tX8ERw1R;-))=oMOaE;~A(LJxMh>kXE`z`Hgp@m4TDRGXnPAeZGn8 z>=@3K?Kf{6899iFA3MB=4qSgt&2eXraiT|btG;q`u0w9)v;Zbi$$YKST_F|}KTzk#z|EF^0@ZQp1A%S4v&*cjA za7lHH=Hz+>*pfa}hn+wK2k>{GSN_;09M|DJ%wOq%eQyYGe(^W7K%4m=<~*PUdPX?_ z82s0Xfo_sN5Ci)UaG;4D0-QcLPI#=GJ0#MBSrNS|z+s5v#D|;ge)GEQK-)D0IKy|G z_^|Q(N(`{fj_5)Gn#qq79Dh`mfFec?3Xd$Gj3mZMy48aIfOAVC1^;|qT@j!%8%@|&^>0?VD6#CzN`~oI>ML7>cEtO(i1)2Rm zlcu&|Sw0?*h_{u@g7pe-?8S~(d@aCCm7;nwp{YR$L;6`A(e zAlT9BlCS)C;aIcXNQCIG^Ch3dY(vpgX{f`a7)LP;e$m&*x(8{9(6 z9c|dubS&^GN=E5WAjIHMuq9z+NTI|F7#nR6Am5aUBNi>H7o}@v9FLrdaS9?otE{;Zt;GW;koGdtvec}pc@PXem6$=z3F_IzQO76Yl z^}k;uS9-oX;&Q#UCopY6w}D|4=gFiX8NALOcB_rfhHWJaDIn$=TLkX&D#nCC?)G@D zol~NHYF}5~nV za=+xXk_kK^dXiV1d3l)0)nN7|%}su#eAAr8B*4b6$ z>5vhtUc`(*;%__m(Uc(=d+XjD^I+{3whvWcdO!Lp2z9V@3jY}Gsl0Wvk@DiN$pUR{ z)(Q9$=fOgzC8*zIh;E#D$6`+R>RDihl$Q4xkrm+$FKmrC+K1LbPKDP*DSGaClqQ&+ zQrZO*+}qKKwc0{Xy28hEx57oa8Tu@hVJKXW#}kQPvv+#VRy*WMM2KcGn!)4Kfv|PU zS7stzy~^@ul?lHx%c_yP$xuB@LouTcr<5{UDs@lt&t#YMpO#m_QB`|o7`XP$m+O~;VT)2z&jr?U@G$)UdD!3adYx?3{gRjijXNMKH=O!cqQXY?{ zt(%W-ai6_sS;Nit1lM)PMKmB=jQ_oh=*)Be^-q3IlHYA#CDR(9w(Ie=`}swzt*msz z%Be@DMOtfL#PE6*^`8onp#_o8d59CAvCi*k@gXyJX-cDz^OhfrANLupE&6lxfVLNF?0vJy(xrxqCM`7kt-iz|A!zU-mPNN3V z=%{%Hotf3VzW(f?XsgoTCS<89*zhY~>MehyMFrjqeV3q;0q^~FD6hRueeFPgnjos8 z>Xb#$llP(Y5t5)UV;6VSrg`j6ufS_G7-wl{p&Oy464(R;F;5gr>+bnu=Q1qT^=EZI zjmaKdyd7Q5Q;|!ySo4vG#QVvoa|zug^^bk0GCPKEM4CVH-SK_bST%M04E8XD>KEFkF`l{rnSYis$#{N6Wd=8rkMrAS;U zqcp`k*)5>w>MRGEzMvWFZ#0>2L3 zlp>RS8G#U_*n<~9Fceu zTL@{h4yh}0R?O_pb;!COpBb!p&~vxVn_r26QW^dt_f$HS%tt~n4Hv64|0~}RDrpxS9tuO7`cO?VYtr~Cq1P*+IAh>p z2a|e*&MBi7DqdFojIRHY{;g}YgVeOuC`BFpY$|F>@gx4%Gkw$gi1KMq!Ao%`ONuwq|AF3W^mUf0~^s+BYJoQA*H?9xPy)hYE(A{in` z&wXe%lvneV-E_mh9%lZ+43!jsXS<%4-4{b*iRFzaVkE2!f*5k$zgf4 zgO&3#S)Le^j5$pFfpz0$399j7iUcuwmk(bDEM4keta-JMUT<1Y`f$lyY2;me%A5Y6 z)>FL~MrgBy#S$M?!&ldy$HApx`D(46`okct;-k=Y!JP-a z&gTlyw>#@HL>U`QiSsLVson%ee>QU-U+fUXCHu-*!sp}aGuYk7TBj=Ht4iniX8Nm6 zfc8zA5YdtwfjaPys1dNfYVNln?gl1p7>qV+c=R+BljyYqr$KVn>O23+)ydOLt8AaE z>T zj2Nhr{-?0nfRn5c;9iO2#J^PSC(aBMg(r1`!wxP$`je{Ipj==mP}Lou`A^1m05%|+ zc7dMrUx|M$Wsh(Tl%uRb(=P{brPi->z@eT$$O=J-XmveF#=lhjM<(27mX#GS4WRM; z_@sX_N(9b;INuIjmT{c$FANgKfjGW@f)DOp19eb&1LginEdKy0PC&o*t|0ke#0ZoE zXcRfd_K{06ew`WdzK9dSCxKT77is>nR{sMRfZpW41Q$kC=0Zox33gw&d*63^Jle>+L@)RJBfnagnyT9S zGham(WEnNMas!#ouW(haFY@5YMGXwA&VQ6c^+pazUq6p)=*CJ8yIrM87q|!x|FXTd zJdw-Mas?KaaYiq7jpExTqhR*KcKl~s{3`hy=6|nc-lRn(&dhP!_d1Y1DvA_0wvlVFl@KPXKzz2 zChQvAlm?uX)V#CHWLc9+>(QF^ZIzq#FFqhBabSX(I?YGFp${@u3sA6S=&JS3&BT2^ zQdGI1y5<58IfpUXE4hC5gG$>=m1_A`2^G^B4BnYnMqGC&@FLOqky-N|)*30Jc1iDk ze$ee(Hc43M%R^jMV^aQ7G(%VgBQWEdoBN1A*isx0w0=Jgb~($rk-(a7go%C%T)Nsw z)RF9@B_y$7JsE*~9ZO?1yMDtEy7z{!^szp6ddZ+HQ7M^5Q@c|?aYWW$Xi$AD&-f&T zoGar>233mnrzn;s)T)e%xSsGHT#S`g_OmbUd)#c*6uEz@J;P?5uiZg{i7hH_O_L$2 z!lZHw$K~^9XT^-$KL zpuXZum_5#veZw@&qYp<62Vy6jrzm`pyDZ_#4IjI_jcs?#khf7C(6OA0 zDtlKmYFSIp8AT1W(7)1yAz8QdigvrdEP8+86f-#vN>mp}lF{ms_kcsW&c`<8`Y`Bl zjQ1+z0HOZYd}#9o*3KzUCcBR$&-(11bqSl`JvUjBdGKA{STTj6(Uk1c{Z#Z;&Z)wv zF|Ws2CXc+I6oTN>Jy+vBnjhM-bzh{rLYggR5WSnZ<+Hq=;wG~0v78>iU~4ZwG==9c zRnX1sxpogMa>p07nI(PmrP+4IEY{lYqvv8C@1w7@MzuQi!_{m>8dHr&!uixc4_Kw8 zO^Z8wC|0`)X|9pAQEY^7DOoWUkI4z+3{zN%H%I2K3pfll=1w=Lo>%TZ|~i>3NU=MDaJ?i z^DCVl*Y&W3osB+WR*-4%G(cNM;Th-G{O} z=ioT)cNN{+4kbO|qSTsQs=grP^SWC}h+&FV%PROlON^_f;5?N2Oa_}A}_6=DB+52s8s1u(h z*Pj0Jb!w>Ky&k$`RPwC%C~j3jc#p-H_xz%>w%-RW8ghGU$V}Sn0HwFz?#MDdkG|I6 zRgzJXM*NMGxtqh*=`(MN!d-q!XL?CCoY28HdOm|UK9;yrX5ndu_l}8wmrTM*#NJ5g zNJL9ac`4{O{&m}8OuRq|8UFgBLC85K^m89K3<*MbYUso99uCNRy@xhjzr#px^x0Tv z12>GH-*Z(VTzPb9*gbHySuQ-D1OmOQCcDCZ*3dHztunXsarwZR+&*$E-h~~BGJ5?n z2g|g#(Lyy@JX!9HYt?D5EO0Amv!qkxYZrH{xCrQwKMuaT&dV*Q-|p54e;-6%p3MZB za}l_zp;NmOCLb9?cD<>MUpSjP<6-BR zmHA-HCrHa0R=y&XCr48nfq&ua7&6q?^JNeS_Zn+Pk00?p+Tt)2+%36bF16T!wR#j? zZ4Wvl9>LUzooU*~_hN)}Nzw0Xpj0@~&0*^X8ID{}bQ+i32y&HdLd}#QL@IT8z|!@i z{R^Rf9Iv%|=^J7CNgBmt zM#gp$(cUv(+)b{Zu_i%@;SmlcH9DTqXjzA}HkEnTQM#dADLq zZd`ccu+5nCnx1O@SrYi-g98qHdOAMr*|VQ;b&E*LCpG7SO}q=W5a|Z$8Xz zHq_`Z2!zk0U66RDpsm~8@*_cT&}*v7FNcfV005p z2gAqjTFWuMG_<-dmE6>j zbBG^TQKm&ZcYH2bleON-;f$*E?H`}cbVD+uESG}xb zaKujYm88^e@$=6=4z-mOCw$jyfGQY!_XR##uyA`NK0Utz`NbEZ3Ra*Q{fVs1gt1B# zPFdG@5+cuZnx$=VGuu(Nr5$q@7NoM2=%-aL;4*3N3C=yz?BQeS69&&lzTOj1U}!p3C=`QlprZ zK>~y(FrNPOyLXdES-GsuI()j&Kb${JO?0p8(@RxUhU)4!%a1*kN60boOhfPn3M>`9 z4UxoYT;hV0k%Rh-Wg(s%R(S8LwjrJ1cwU0V>vqw81DWCl@ke z#mcE{v1isfRg(b)i7_~MpF&2&OW0FGP_ECE6y1D69c@d`A0Xl4avH^T?b@BeH|FGd zV=C_`+g#P|8%_696UV#OOR*HuQLH?E-|`%ZHkc^e!4UPl@%ZDMuMtV8>hiv-k$8%sc2nM#w*^}WT?>^8wy0ZO;9(tG)>RX=$wEl?A;4^kO7~JDg3xH z@bEo_z!g?NN%Z#zIe+$b0~a~`QcUe%O!%i$eaCQ!BQz&BO2GCmHavJSL_zTj5gZPb zdnZ&edlw=8j&8qd`z`IS_581M0{2C5owOyrciZCsniM$g$;ov>hsBYrqE2{I;F<;C zNahI};YaRq`jv41RoMaT0&>FUF5-f}qX@z;@5&Ce&a(nHfgG#34zBh8uV6b&crYt) zp8#<4!U@E`*5W4-|E|O0$jw2&dEei5SRDLTfj_a$_PY*?gI_!FN8;agSnOS)`8(qP zN@F%w#Fcj^8OE;&(Fww01FkGV+%I}eO-C-6`JJ$S*J5$x2AJOw|E|U2$UQB;A!Y@x z=HLKa{5adcB19*=GjL}da3jzOrg`u?8UCaupwj`sFHf5JkC6=l69KcHO~ z`wsB~CpwAcKYJkzxMl@$VdHT*{R$HumJ+Pn74#q43}Ill&d9bL57L17L?8 zh?;*1?98j)wj2>7bo=%cWKf_?=6834KU|9P+~6tYQ^*bz95VP#gyyz+b-B6^kv1ov zbw<}frA=LQ*4Njuu>cW9BYP)YAN(~L27Uj0bi`$|7V zH8Z$Lw3o;wKb8$f7ZI59zK7uS%CbJ!^$DDzz9Ro`-5 zM<+s=^fbMV56N|2qX{7*JTmt?FQ;p)>t-prJ-999B*IIuH=h=(j|`{8;+Bz&RDiTy zJIkZH%iJG)5HYzplKCY;lAwwBz9jN|z_5pkLbl%}_I1;8pzoIA>uafYiRfVb~b|POz1`-7A8HwB*D66nbZjE0eK`+vfC_V~H31V(2w585pkBkRixUKe&EEckR0`F&%n;fB84HsM*M?U8&MkxO$T?qDqx z!(plklmLhiG3LCKw@O!jc6CFQB;S>@D{rUcdM-K%UeX6i;cPf9=q6mOHmeLRWjqIA z9l3%0B)5Rtz+;T)A*O>KY0uL!XSSNsHl#Z&=*U4@YJ9z3qQ#dwO;lu4`UL}Smkv=B zY*lTutY}_vt1)rh^-xj60>{~bMzX~!c9vf-p`6kSM}8`l%~(HVkBpS|u;pUi6qYl0 za%X^&n56{TEhsYCr1gY3SB1Z4oGzWCPu}aQfQPO6>6I1W3C}63xVv>zN!}?m{f$aj z-IAk=`Oe&5x2u+2GFNz;Pt)AL3TeKXc`IneNIzT~5+th~`S3+{15ywSf$ZjG;$3h?$v*G+%E-^fQMS?K z#d(dhl{7Xf*h2<>U->O$$;@Tr24DK45%!pRw!Apzi;AKzbRy39UUuWE zRx@Xea`3iI5MiAhV-5HmW1hE^qeJ2V2=>L9>{eJs&>L;?z7mlL?HRQP3_bG7Brdd6 zi$oMS-zsP`jTw1GWLEJ%wvb`T=n6-xkqR!npv4D};7e2}eUJU)mRGNRPEOO5fA z5iXIIjqsFrOTn~yog%OH)vCY)(r+scMi7V>2YVdCfXU*UIu4hZO&A58sCSiomcx7g&gbvpc%czqXw(@-KiDVJWM3T{9HwWPH4b+ z<7LZA>wm6zogG#h2)iU;B(f-iay_q|cwxGX9#~GJEljl-3NP1QOYgXg5^_o-1r(Dj4GMf zIbvYep!~kKR!nmnAz+y1>v*QSLlrl^fYcluki_C53AeeB=-vu_H{`x|G3|nflf(nd z8N0Ud3tBL*ZR*vFefhJPQOIv^TS6@Cm33oo>r7|kmkWAa4_Y?NL};@}`v|cnU(;=3gG)?zv|?As+_07} zBzG-_`gQt!=QuA^*z4%<`~n)vDQtD$Y^mE*I}IGK>buG0Hu$U?9W&>U%6*w1F5Mcv znZdgW=8f5Uln~rH)c>Lf{nDw+IoYMeo_C~-9R`XWK`O8Lu+(2*spH>em@GF-?0G#h zZWCLyScKvpJp1xRIaa*XAcHCoFLp_o?>CLqKPh&0UXI-rP;3yB~;?P(CTM2`cO`r@jdul z_}gOnw%N-;PwKYW^eOzko3~7c&bsU4r$p@F*6BkeXY3}Hnno0o3rr>F-y|0EU=@5S zd`2?rY0vptO|qhv+pTG7Y?{A^+rU0F^Zq=Y;>F&2UA^zd(pPS&elfbi(Yir!e#%^l zf~?LA?|PsI>goF(8JLpXBSH?HXVGp+At!63r59^QNQb=c+r6 zP=s@9HCjijtZ(Jeen0b63)P2KFY}dnqm%plE-Xgd+-Q`DTRw$p+BK1{@Dgq&60vA= zP0GHf!q$zsft4GhnCVkkz5bxx-O{V;5@Gj+jg|a1lTJrj4A`02B#hm&qL4YN52d}@ zN_JY6u7gwFv$yI-DTL=+{X>vP2PjA@N+s{lRxA-#8@U+3+^h>`zZ5S~1=|Gc3Pnnj zgg$6W@>;%`zHQ)3wVcN@I_ zkF~Fk>T2uSrCYkYL6H2>AsteZQc@BE(%mf}-5@0(Al(hpjUXl62uKJ>w|8^CbG}#M zcg}n69d``>U^vEP&b9X3n>C;H%xCT>`RtBf!9MmT+>iG5{VWUrF0`AmybBqY>`J4x zu%nV=my^V*?npg`#eGrbyLT)DFZKY07PR5kc?l<(#*Gj)=c_|77!7bR{!gh59;5l= z1o}JgG{%bP}=#NoT%D>D}VE=96&+TFRj{yD)@8hlz-S0+!1Jc|TqWjJ0&(a4_ zumd;@VD9Dr5Rd!oSbsOnzl?z*lNB8H@rT&le=+6)icD5OZ|+_h^M^Rye=`P(Og5mz zxMzG*4cPVj#&@X~zdo8j*UZHQ$bAAT#`leX&7;5BFfL%?1v^lI-#5Nn zScCHnuo*z$8e@RIg#Tpl-+2bamq7p|b>H*d!Wx`sfEWYw8vdD;e{cLxS$XUAcFGCRMRsqG{+d_#zevQd>-@_r z@MyUKR?B_kf67SU7l8mJQ(kZ|4}ie_*Hi`pPlg8!1?hH##@`#?dIeZ6fE4EaX#Yhb zf&ktVE1>#&-}ql7B0Hd9d^;=XzVW|EM0OqkcmZ?>?;3;dHV%UO)UgA!t6NgoedB-e zsbl8^h)iHm{M!z!zu)LTbK`av3rc;YynyyTn3oAip8vjKw`#S3a6cH&|02U~rviZ?P=fv% zjQLM*@h!5)1&m?3x8%Fchu{(n&@>11f5F)Pi~It{Y61O+_Zm> zivK5p{})mOHtSzPii29(faDL(Eu>fhD+5_LU2hlopaxBwqm3CUd;TIv`aoDaPCSVc zN0*Z5TjU-uNGv3qUfb!pk)8{|(AwN*XA^0Ed13!k_3=gT`sRyGl1UM{m0+p1W4>X5 z;V?`F2b+&bj{{R}vT$W{0}#Be536)Nnr|L-C$-@dK6*>h-f7hZKr+-~~9hgxB=DQ1nS?5WJ(YfSM_K4+iy8{ zy;87umrcsQ^2tqlMg~0^RM#y3F@VQ-sz_F`?gXi0J9A?%C9E7b$W?qbH;gcz;O;J4 znBCV*dG6(FqMg$hl7S%19PypTkos9a+s{H8`2geUtz3ugV4K9b2PSr(f`?`Digved zaCrI;$>z8HuV*e0_qDYzeYe>^%U*eWla~EJCQwLOq*(7QQsBOQwn-8zh9iS1OYn$y zzddYq4a?Y#-6YS^12b(@J^e{k4%LRDvAmR`_8gbyCe4^dY%Uf8`_WR$M+ZJopOcpZ zUGuD6?dP%XP&AGPCT$@lZK@9+Y8dmV15X2ats6tc*|r<5&XU6PnPjpto*lBOv&6-) z>B>l+K4|gE)A3J4<@laDTbG#9R8?bDe1;k(ri`mqDQM)lb-@Ge!;3o0erkDHFsIr# zRLkEJux_br(ffixiR9*`K|m$zH?}fXmw}K5$XCu{Ggfc2z35xR6DHulO72nKd_NDH3x%(7#n+8O0w&inn{Bc-i7%|6dI%VT5C`Q(B(N^ zl4LKQ<-2$J#LOA-!oZYTqrByEXq%jGWm;MYcTBg8ckDi*3O<|>u)3hC8Ot6TMJf`N z!O&$v$@^5i$$|FDI6Tyya)O%6uIR$3dh2So@f#hjk(X(&l7sd0NY59>j11gBmZln(082`ZR=f4E-rW;VYrEhNa@J^n;% zrD{%|=$yqWfXI{Ebb9L5Rt}LZ6OMEogdjT{r08RPIVq9XqC%I)r>E*|Jvo^PEF^~P zey>1C!Nb13jecfqti^P$-`6l*;Xv+8a40+QpHtF}4IOi+0%af>`frf*Xyr*nh{v{+ zsm{e>HVn^W%wEyBM839pc93ajl7bT}Fc%k9O6=0BGeB2hT4BYfAC=fw@N{IDXeHv& zv*9;776(4-brXq6SGA^RO^vJ~a$jM8bf|6;4$q?HIk@J3uLusZF6LX%rH3RCv)Q=1 zeB#rtH7>y9+wV@K+cNcvpLN&#Yp4tZq1X=GJmJGAYK$lHf@v>X`1HoL0#X?{V~cT_%yj0zt6 zQg`r8Oc}MV^mUxO>%)xCe$Tyd*Vaj<&>gg>4@y3JWkO(aq9ZezLgy(^KB&fqH(DNJ zN%7_M(ZENBOY=(C>_g9S6Mwg`$Jhv!K|-)yk3*`nw2Fd*k(nFx4B?Beul5bo+<|P} z8lH`8Fsu*zm4H}8soRyZCRsR0NEz#r!B2;AaQ$naCEa@S{4-1-P5-$)U z(Tzk*E~e+v2_9Oty$RPu5Y~mpHrIGuE{=WDkW95^Al|?JQxd65ypW9~%>QSsTMot> z%Hx%+c4^oek?*VhXjsyYdnD6DCP=bqL9(MESJ^N4%xr!= z{O2z1*XsxhoSW=#C`%3o;dgDEm#L{nHE~DePrs<$}?6Wc%p#82#Ql55%%K9 zM!fefNYz}})g##x>5+wxzg{|Ck>-?Dg-d#CIJ1=$Z&|H6)P0`XE2ZT{sFuu3Ao2P( z&Xs>mREzN@)wQDAlqZ7#fxK+6vh^M7ovj1#7~gM?;5vRjeawwEyt~^x)b4ckZI%jB&oH z^hRNHT6E)$wie%Gl>~y&3|uUyTxmUBw@*?}(VKbGp#|Pt{J1hOp+VJ(#cT7je-gdQ z&-BxcZJZR++g{|Yp@NUl+;|a0YYn}IbP#Ptd-s7#zqkckzfXnG=U$=%EtcKS%$h%> z{e+}8kf8}0+aY$Dk6WR?ChTmBN<jkyaWRrz4MKxa@mwZ3i+$@j{ zL-IhPym|XfFP85zd7^WO-H_Uc)a(f6?9H2Dk5&v#I?cz7JhOv$f1`WydyQP^%ape-MZIV_d&~^HdZ+Tf%Yip5x#GQc$lJb_$dJcm87RoD<^m90B%WNWn{qJgKLj^2>iLuj$VAV0#cH3c6b^LN#L@z0Q$U17e`y~RzJjMNRE9&Z_KJRpC22~P*tF>d#` zH{u(S)U@Ws@J8fJzBi-eU?%Njn43A#$Oy>p1NVbdq5>g?+``x z{3}ero;T}-wx&p0W6%4qWsk_ePUl0$arMbRUNwvLzg+c3>OoQqa6WN<>mW2YjkV0o zm>V<#a`&*BACWv?`VhbT(DP^Lo5IIvgDyV>mZ0phz7Z?dMLljwRw83v_z4-x-wQ^5 z|8`j9e@=&B5yAgCK>mgZ0`r*wtN+g0x{n9~GMK;k0}A~A3E-a*!MklUzuSNZ1n>5r z+_mAlh4a8bTcE$D(*IRO+%@C`3Po-(Dl@>~l7Cp)pG6ZVz)Ii(Bdr1Yt$pO)w%j5u zzeE@R>z<9k= z6#urve};TZCc2&Idq3n~^Yw2+zSV018g;-J|5^&&HU0yt0T4JaO>Q7SFyudP$z8)g zLk0nu*6qy8`yt;ch{3HF1c0T$2t_c)|01hyDLuf9!+XZRu~qIy4J`L|N)b1}zPlIk zAFuacsPr#2>8}G+fMf(W``|aF6ri)|R~g%11XcbO8wLdI=6|;RuhNwj=-v94rR#S> z?N_VME(BXdAHD8ZOiRBs)<@oe{4)`dQsSGG3SYu)&5<|aPdL%jz zn9mO`=-nKBf7S3{5W77Ynil@_P{(H)E>oQHks6wztvq=a_LB}LbP2>*Ok0ZgFeeW_ zc-8ho5d_u}a3f&N80Nk7>ol7*mfvJ$Lzg0G^$+7B4Uj9#jHaNTfx0+_p;3$?7tGvg zwjzej!r86|);5hFlSMM0lCiMdG?jf?4HgeG z6c@op>`V6n4XNW3V`6ADkaGHBJCC8kBA3nJj#f-(FcB=@q>q@G9MKdq`@)`jAqH-1#69?CROjarlUhO$AA_bL3{m#^%)- zzVf89cjMDRT=PxOAp6J@o1&%B0dfSNJOesM%+P{Q7Ygm+Op~it1y2sSQkMKh$qSjH zKdcPveyAt4>W3~M`H6}Du#8h3KW!=kF)#zMBG~BjPl{d6K~K>KLAfFDjxZi(vnGSs zGTqVbkseFYk_ern8PN|abm9?Ck$mmngz+iSkuzi~hstakI#l$8vPuR7M@JToS~Ux_ zO697Fwrv?5_0v#7#J#!7p{77VY(}1yX;K7)N*f**?rcj`^ijW>Puy&ZNg;KgyC2 zKrc&3$3Bu#5sM((Ce%u+d?X`=ma-QfPxI%3Ne+aeRP5JRD^6GHQvV}gEEhxz4)fDX=bZ$oOEXkuxF zaCdWzqqgPRJ2c!3t;;?ECMj`8k673(^$gx5_rdDkT0|sf2(9q&qj&x7^V4KYA)RD% z2%iS)BkV)NQ+TYeo19S8EmQPx-Y#x2w5&axeQjKGAnUAqS+-uihx>8AY~rzt!I*nX z^t`j?w4Wr!9)thtUT8bCl{j3Uu{q8;McFp`Gg1o-{2xtL_=TCUq&)7FkwJ3N!ag*i zJLaB;Q&<@<6CBQ(Cq;j*#i4wsHuR{g4KK5&7t9heVA474aUn1Yk#BcjvqM@q=cp&L zhEYzmU4&v2S7cpRuLRU5)f0vttvp{Q4PEm27I#JoQpf6%Zx&y>#*Bjm@|f$vZ_Sq zGg}sU_P7aJ8#h}!H*Hbd=y4o7-eQ?ze3zI|vdnz47#Vd$uL`;Z>uj&B4$f;dN3xJI z)!ahXgpUHc0a33DM)yR-&$Z#6f1*w>oGsN(S;5Eaz)MU!Ws}DDgjp>0$yKFr)~L$& zeqK6I|MHD(aP`r|I^;|1%e8_BWrKrmI8)v$4y)`s+*Cgr9;PAH2sawX=7b7&6MRC% zqn}fSZjxuk{noEN%3^Xl?J;kRT*_t&`)&7Q(csPVQ$hvgvIdiyJXVY64aQ0CFZL}a z_gJG(71~&jxzz)w(Zg4VI&`md)-je9!(jPy4l{<~Ol3$IXhn6b=-4T<#7>V`Y}(&ClsW`K5vwfyu(x7efu(V-{Kuzw-D;!JB$W)sI!A;46P=zTocwSR7pN^p*=Y)Q+~7`%5+k*?X1NL zWvB?d=B=U#&&LiZe<4E*@9$)|@8fKt$^>puX;WvIcwCH~rLQWfTsOQZgj*lg5Kg^M z^M;VAz??n2?6S;pP{Tr?|i{vjy&EF28|MJ}V z>!JIvbLZ_O+kboR)Ygt&?ZokVrKrM#;R!4JaH^}jkV>JmCAO$FxwdTdo*(oayEa&g@7yhS2wx>JKGq}@M1o<7ykEk(l9 z`zbY}M^DgI<}U8s#malTX&>5D$MX+NryuiY%yqa}mL9rr^rkr0&+Sh+snl9aejO*g z65IapMGwKyP{_FEMacI8+31y_Hzsw#jG{~@24bG-7nm1b# zPDF5JY}n)xJLJCcO{>hGaGV~eCUcnbc+H2*o0nCn{#}wfzhgOlR6$(v%!+EO3PbNp ziq)Y8ycu4uybJdhNXwTYluC`%N|ikYAE_h?LPfu5 zWJA8%a6xl)e~l?|VMx<%%+^`C#Y+K85YuczRoMKYB|pve0lCFZ)K4F$l8HJ0B8yhM z;`k=PS5qGbnn&VZ<&G7PdPdi2e#aL%-3%gqH7ib2H7D^}{e4WwmPoH6@x_oZG|SW* zU2A?Ti&HNcOsMxNUz4gtl;GeSB;J~o7Fso0)$5%2*LAT;YNmMG5y>y`n;#q2H(3{) z_AzE7pkl!;=#pMYL%0`2)g!zJ2xj)XerC#Q7xO~L*xn{YryoNXe%r@Kab_B7J+z$x z$D^j3Qz63Z+^(}+e;#6Cg`Ab&TGLQyPC?X{vc1{>a&%^Tau}~IHx_DzNQbeZWb=YV zN5qyQ>B_T?AkmvD4W?Ko@n^KP^yH<79se7ypF{#YXi6kxS`8Bp-)$VHGCDh={_mEOP(((`5d=%pU#M zJYm9acLU|;f!Kn|hQbR!O3?K2oq8|>@nohyxl&P19mNDd)=Tk=WqU|-(&zPXhvvG_e}ClrINY520pSrkb_S>pPUvJ0B#iAJ!Lh1BxL&9`oOnK3?u18ZY3+PE~` zsGsc4G~!i0>4zSTs}2-&Sx8FI4y8mA3}?VPS45hkZ6SdaNu&HIQSlhIBd{J+h!Q~6 zYa942jfX;))}L)hMZ@9c8Z}AbWd{?|{r6G=Ij@D;i z&vZDG6-7wizKd16dW-E#OX%)ZQK#;1pBH$z4ltKw_$J2vqCX7K^nRiXWb8kgo^pa2 zDKE7+cZIDGk-Tx{{O+=3pmf^ypr?LFfrX@=Kc=L4F_+ZG4}s$CS=gdg|IdjBU0f(( zk{hLU{&0zE(^%^b>DoAvR?lXSt5y`M_)chephP1OW@XKczWO5|)_G`Ka$z^ToNI$5 zGpYIleHtalWBAVDD=KP7C;Uv{l?-Pgf*yXraFe6}pSzDUVr}-Y?u2EQ#({<8H+FW> zpc{(WD8!iuWp&i((m!HPCdgfP$Y1z9%{GTxtz%dgx0!;BO5V*p%Zr?2im?_!daiuo ze@ed=@8X&gbuAzdWukI12VI(mFf5@ZqQUKQeuNl|IV$vKCcH+`J_)7Gs435ljj#1a zS-kHub0GNKt=fZ_q$#^Ksct*-E3X~zgV(FEFElq`g@azA4>X8&ns#?mYO7KCi8wyr z8JZk|?ZS<1R8#ktf7YSXQ>h=@9q@qQmHZ@*P9lP0JBBJdUAeRXteu~vU)V>d-Y_M? z)7mq)A1F3Rc0B05W$@yx?8=w?=GJ-hO78OCLrQ3lmy{yIg>dk+gHc1$e(=Fb9^oFn zt#jdPZ4V0_5X+uheen|{clA7kPW^HWYw3#kWyol{Z+bl9j*<`-t#>eIt7V(zAHC6mU5&p$=q2oL6s(RtdX zZzwTE<);&EjDm-Ro_H}nnD(i5*)7^_w>Aa#)aIdKJDXErx~g@q`dJS;D33R64>@?A zJ~327?g#{jLop;9MXI%JuJz^lV#SOFg@=GDgrZJ5^J8Y-98O6j=XldKh(eJYI$?zu zP0n@O%o=F#Q`B9;;CxGE`c`?ax`cZgV1wAg#LVpEFtA>E(qKrx=x_XhUrv(R$Hc?z zwQv6-?SsZfVEIt8bC6-!3u37E^7%mL)00UM6Ds+bFR~7!7{PXYhWl&~-%eVn!I9d!Hkyvx+0ic&IAys2%caOEM?+C$yVS ze*2xY2p^cp-!XEoGVmjpS+O9Y!=_2O`WLoU3*xH#q7HFpF&FK3>oSFHQ6kO1`}Fa& z*9JXXfv|*SS?uPE!CSP+kZpd)Csl2+Y-B?Rd$wfpsHQHN?iz6En5rHP^z)5Kq3}a> zrCSSwc0MAW60hKdw_D=ajwQMsFpwIM!#As0J=YEx@yFaS;_K7d(y&kPDst+36BOMf z@K`Ey-n7r?eNIs1#XbnB8P}a!$!7bKKZbPU1EbG&B;iNf$R%PiO*H#hi~tdJ>_h=- zlFWVHFv0UBTaL%hQ&prRx`uQ!;@5ml!|x#Gc|a>q&juf`k14xGq+_oN&qh}l2hGr0 z3`k)#I*p#ddzkF62}2jfeisHYB_?cKpz=k&@U z-(Ue2-nMz)PyIT1vN^JtyvEKk^}_VltElSby|4Ljt9oVb>0$Ak*iAoslWz!oKQ^*7 zjoPRmZa@%u5wq5;bIXuUJuxbp*+!sybSjjJmp$b+(Q+Bi?le>M&2U%fXos5c2+cn_ zve>fqWK4*Th-HZ;hn$$vdE|3nnORZD(Hr;72(PDb-926k6Fx=r`z(|TU&%O+rkyU1 zR>;}qs{+b4ExF3=S^{I>D}|eWLLPF|kAN%geg)S5rntL3$^Ty50aVQY*W&IDgAtHx zyZu%FI7gWC?tR5?HsJ5B?zUuy1^#Kv$qP6JQ^DTt&;HFXa6!QdP$N0P%%HfPdT^(L{q;%Q-aXx3 z(t){7`AsDCi$QRDUfP z=%)bQV=z(w)7SJbV}Nwe3G~R^%dWec65yf+rgk!Off<5vt0nUHUynaM1MUCJTwLHh z|BLKm16cdqVA>l%T>tdl`pYw*w8{;R-~7iPuKO6+Z{h=gb1VDrV6WfgBmNim0-oK! zg}nf#@EjK|z!Xk0A)|!mOk9yyZPdcO{&|I2QJ*^j=s0DtU3-}i&dA@=j(piZV=>@;6hRwV;^)$etCKH zc-zfXcj6N%%Pbr+V^&6;2I^cUYedo7i}v^pE>o%Zg^DW(J7Et&#f9$(~ z3$Lfm^*9OX_wA3C!T)5M;^|ma_fe@$Xu1A}2*D-C23!>}bs|x$p!e6+_m#*~H^GNJ zP?4D9+67cBuh(6f(r`VmMr_KyRk$>~U)Jw;86UCXV)}7T=PfFy`Wp1qS+q!Lf>?ke zYfUJI$2wNgK822nSo%l8&N^S*6`l~r)o+^i@rq0F zXMctjB`t3a`|2RU@qXN_`j@Ppq#SO{2wL!?cf3 z)5~X#O$YX;%cK^REip$vZ+2psp;Hwi@r^tSQWMf6#0d?`f5+l)hn{*9G5(pj(Ifbk z?4iTf#(NcA?~1Jr8D*ipVKh-9#$_q^E>gcy_JE*=1_p7bCn{CG3wSac=VK2IhWit} zU1%J1&3+2gI4HrMx>p6bFCmxd$xR6jAg}!Vw7&F!I?CrTn;2$(rBD5=skecSxG;~)p9PvjevB)aLF^&agZLldGn|48O) z%{q1ly|_9t7OyX%G!8cq{N^H#)^8j>mNC>~m=|_^F4J>9efT+iG(xf>Yk!+t%{$R~ zHO`T(ygHD$r_-WdlcFE`%@_H_G|`R}6HTNh$0F5>*JTj0s8hj7!{?F z*Gu*mez9eQd^caSw2HTACKSZ?fE6s3npMOq%&6%nE5^{oI zl{iI9U3wq&TeV~y@?v*^$napCac=$l?Q_nJ$$&=4hb34J>zA^-W|Fk2kpY61J%X{; z@L%=tY#31T`JGlbhcKT`vFfT*MGBV@amgFEGKI@2ms(5SaLt5C!f!rD8a!*3aI$2o zs;%QcM(IF?QnXsbwpe+HPl~M-4C&G`SM&@9VPuMrn8?h>FO-h$be1RPU!tGskS~_jJ9j{Hi&EyTM|73D$sbs~c^aGczNlc*nPA?x zu%f0}o6L`U6Iz26xrLl!n%_e#bl(zdk&WuR$Dk!qdLahp`Yh5SZk2m|QDO*wFG(FA z_l9T@ZkW`EVL1mCJe_$}cCtP4bPbtgL%b#fqG5|XjQ zadL4H!zMj-nBX0yWqxjU^C?B2Xgn^X&qu3ZMxlFx41dKQB}s!@P$iSTY+|2$__m=$ zH!W+$_7d0ngC#-f%d4VfM-Z)9(YE8{n5*)O5$Jxhod^SKN_WV7&&{u88b{PN<6bjW zOxtQA`tXm3w^U$1ZK>%Mqcvbcm-Kz@i;q$qp~$q#jN>|knt>*vR{fSCF?Y;U&m8X$ z5^&}{Ja4s*$CrA;RoYAZ!Xm+p^)kfd1 zp8^7dk|Tep>ucV>YYn=LyTwp8A>J=tJpN$23r1qZkxiP!vP#x$L# zLvt<0G%zFDn2(+8U$ISGH<*bCb{eIw8E5JzzC^x&`_h25OoZuTx7)>OXZo%ubC@5Me<@$ z*1Qv%@rmrj&LynH3U2vu5wbNPg#*eKcqh2!GqcCoo(4m|yCGzQyRWI$x9Ai&5ael( z#)RLra%iq{{KE6qCZ@Flr}+WDJ50D~!U!y>OrTGsA~n^?4nM*yf3Vm`-|_lw^?}dn z^PC8#ANcC6h@j*2GmD?ZQGbY!#u2g&~+1K z?7@;LHOaEATT~jLxKl#-0}6k_>H5)lQnJ;J>5B%TmQ~fcn+3VY9RUv?Fz6(voV>7T zIPp1Rs)P3QX4uM7pXho0T3}SP{mMsmT%zpKI3v@JM0x8=Rl#DFvok>vhpF3(U5$+w zGIFKwhU)P{9Ct9B&6O(o%fBi-s)v=@g&Bi;#At4ow~+M|F${UlG)cdA5Z3@w=ooe} zUhpY;zaV|W^Rm}I!SW8%>cJ1cKNduJ*R<%Cgq>x_s$WA$SE_Oi?`X8f{X|6G=}Q@H zZN6X{+!MqfZx#GIkC{y3pKmN0^0a;kHi|R5bek$#@4?b2WR@)9Ja}%0`D{QPePi-X zr1^jnr{clAYe`J0bHQ#SXn!ZQgPQ?tjsS^(50D*4Tz za7`D&wMufY3+f^>hq*RA2 z?KCMn;ShVGG0D?b;~GQ`BTarl%GxLvN95aBgAve4`O$;6{Ap#^vCZ&+<_SnD168!# z4Yi#Q(x6t|He&&63*yqW261@HNj0U$)!lS%DXwyMyIk$Cpw#CFzc#8Q^U}a$H(AY> z(etWMCt`3~IwXEFo~kpQ9mL-^6PRkFb{FKaJ~^B z)r&nhxZ+%_*H>i(RgiwCYN3(NtP>JHWQaS5IXylUAcf$#9XZ|PT^A2n(Ft`}k zuQ%=Baj`#+`oH61e@NB=|0Qp1WM&|0?Lw}7JK5n@(T|&#T?dIp(ZJ5w%7GjVryD?M zey^wg2;iS_G0VLDzbncC)|eFlCIIgIedB-1sy}y|lNSIcfTH@o@m<^t z%%kGu0gwqWQzJolMLEEQ&B+ZQ698Cr&+}bT4zR{tfNla9j?8Zb_}#~Ri-!W-8a6N* z1pk=TfE@=Qe8L4F(f5PBi-i2TO}C&VCp*w30S5I2P~`ubQy@-2qZZtI1YoOwZ+z<& zn2O5=MpYAZSNsFq-U6y2fLaO|;D+bduOgVu1%?y>2pPDw-i6nG-K0Mg@$ZcP@!bQK z`bR%HxIOw!K=eNp{J$kU{f+|t#=2)C2LX}_w-*)v4hH&7yyH(82>1^0{971kP)jrN zYYhg#exl$($bzde{t-h@gct=eEnxvI*<=XQHZx_~z$xhWMOjLDZ>Q<3_5-T2RPFly zCx{_ri618A5v3tv{yOOJd(1CRuYs|piPpxL2pGoQy-Npt(#BCCJRxd?&#nB?G9x<8 zndFFrgeKNDzG&sp3RJB%?+iR;q-oF6zVCo!zTP-XI{W2S&DLF?Z=1uPw$J7qX<11o#?Yt}6V5<1( zrG(^NXdFai3U$~$mYdBJ&NTTYTs2WKnwf)askxEqt(=JL1TTZ28qFs}UJSKmW7WzG za}a{BizP*ixN#4bcgG(|xcAPc!&{f&bt}ka$8?@{jD^ooE~Y=#j~buh ze$-g{EqjHYvsd!Wm0PG*RYI$^Jja&WD6l7RP57BUn@M#Bliw>I`p?0(alNWU_z-UR zX(E^OW1`tlhF6GBCvNtwmdh;RET{~;aB|xBD};(C%y8G^o;5*oJMTmG8zFpv3Q|!_ zR%v+M{e;j9_T6~kWTB%;JLV`1T&su3d1Tz8a&v}<)MlWJ%{UM8B*&7TjqsCW+bNY9 zWi4ebm4*&dx6uxSq9EhRxD!UL-Ow#dLN6(y+Gc4Vdg$1YsetP+KIr%fN}7TdZj~*_ z@@n!+O6VJQC6hJTY}^2~lsHKl1M2k_6A>7rxNJ8~qnx;9$LQ0ZgrBNYz9$6-356Gd zE$Th*USx*UOdb3*fj#hyon*wAkXUo`BetbOf7b8dscU^Wah%^@$Ys5Ew(()AbB;8C zXwu%9JguC1T_!g=q>KE;F|Sf}LUi;BXC6{Ay^I_e-8S3_5|QAC;)>{a|73_Y$7YYH zO`b}z*j1>f_;HtKY6;c>kcUTK*XWce2tpu+C5J(^kTw3$*p+Ck*JJ8S%)+A z3d!cIB{?N)UVlvXLdfO$>hqhyn7D6o7H5XtHdTqW#%e#xYU@Ip9JcFBxZs!}bYtEm zz0*=iOO>Zp5nOyc!Lh4dby+cVnRWPx4O#^vK)9l~npE~lP!6-1k&kj6V!s2CxC(dI zi3ZO1k5T5rs?z$MR5O9Ixkb)NgYDiPpCvAdt0zf*K4(Ka{Orp^oV>21h7Hdw-We6> ziP%uGGE*{*m&%y5N1)8_o!Otu@9^&NVp=*1GOF`Dg1+ zdDk!E&9d(m@~?~W?LB3TZ53tYW?pGdKCj*Je&5X}(wPzeLXZ-m#y1u5W80>tJ)R%z zE@!!3ScoICaOr5td4*zp1`cv7oKhqyZ)fQ&;{IrbVT#M{q*))4>Y;DDh>QziqCtFE+_Ik_KLL+vZ8j=oBGGvUbk2y2|0pXv zBw1TC3I{}*a3!G`C1WZngE>#Zi?(mc(qSm8(q8?Z5Th!`O9u~?~64bCO0A!NEd z&M#A=CkSd^+GT9VEI|Z89zwvGtUn>`X@@gnf=l^n_b7}57?&Jy!^bWYPD->ND=jS& z!r@Tkt;0)@U+46hkFfqhd=5!m6V{lzx%Nsy3RZq8$V!=f}cNt$X&G&!GamN$?~!{aEGe#nqUJR5zF z*f*)jpZmqsfSj8d3tm)~DaAs$e~a#bM4>~CG36v>w)U@sZ*Cl=g1m5K2vf_K47wCg zYKK%-a1PhI(tzHWhot% z%8hi>7M$7qqsc20->`HD0&Z*#dp+lN?F>{%>0T^!&k8~&m>sxfq;>H}oa;uxx-bbl zDJ4?K5Ag8^VdLXV^mHA=UrCr73*(HVonuQe=%4rHI=De3@jbCT^Bf$!QJa{B<6mUf zQf7@^e^U_~j6htwskw6Ikx&=L=yY)Iksv39QdIP=pUbT(N_*n-V05i8PejZJi_MI~;6f zM8$D^#$gNfxdySP5Xou9bP5xuu=Q@+Kw~LWyyL@tfQo_($|-lz_PZ28z#kY$mQ8UA zz3j+ZIA$R^gKDX8uH-25nhf#hqJa&{Sg(1mI)+3pPr24{0-bF1qTpFPu~>7J(#E$( zFoq)D#vS{6%q=?j3zB{K!6MXKIiLMLzf!1T;mw2QKS0};dn2mg22VY>td(bbL;7{- zN|4^r8;vicWuthSj?ebsU}Q?iK6Iqb&uf5^ye)k4B08xC7P(Z4+v|rMwd8e7k0}?y z%Nia^^5W^S5YB>_)6Nyhen>YDk7==3l~Q4)D%)Uw>Me2O-IRtMJj+Iz_tYb3dk#*> z!<;=%Dh~cTi3yfi&-M(C z`K)|_96=9-C;Mxoz_$u59^;I4#?*`&2KHyEWCj7Vt}q9J$1%td7&fWb^UU?wZb=a9 zWG!DS$~(2+g$cySjljm`ZZn2e>L;r_dE&}ror%?eCEE2=j5O#~w)k*$QuOk>XRltF z$$ZS?`e!R5=ZX0+nXt`p#RXqODQVd` zGsw-TDbfNUOh!3L(|Do6d&Jrz@ zB6E9;y+y|&=Y+&@H-SVe7j3zH)2DKId1!n3swKbOk`7NLuM|A@FrT7gnRaiiGXc8? z6t6zp35|&=MG%t}f<+Grhkn1JN|6N_9|GDhZ$*(O`{g^+cR!T{Oa%ASN0y0( z#|~gpTi!`D#C<3cn{`mIcm=!76PmM6oNzO+Z9K2nzY_BMMrKS_j= zZeS4}gg@MZ8TI}I&G5$N1fTXx02cK!%o83FOogbUeF@4*kp{5<;UBQ%j|6=v=mb|k zum>QL3o2_V&8S@1Dvv5Qq+|;~EkBUOr$YUCrCPyYBddIjUBN7f4pMpq!WW0$bzoSB zWC(tUgQ6tzfxf~gL(2_fT=6kkI=q=1rV(-fij*iq=qSh4{y0gN|HB=SGlC5?6XSHk zlz??;6XKg?ZfSd&Z3>$0?vE<1k6K=!ZP)0GxaXN1h?-w`nG5BUEGQdnl;R8Bz>gSV zdhxqvcWwHTnO$F`;0DdM`EpXNBq1!lGxAIo=rb>iUMc=eW@Y)1i8it>_$7$_1&q&T zaUWmx^5j!Noqd%G@sIls62!i=E(@C%Obbf==lxiIi@7=ZFJ2H~+MC$8VI!J7q4^SZ zs?bfsk9Ami6+Kj%l1ihb_|eCY5}G379V3~3DCTSbsa_*gmYb{bw{4SQgP_l-I=tx8 z23Q(C{0*f~jyS=&rYr?zc->bwzk{qlz8@u|c-Bso=Y z0dE!KYmh(B=zHeCPWsL>D|k~99(#K-2MY0cqYy`O)jGoi@cv8^jV&bqw&1$SR2#YZLA znBjvRTGbTv8Zud>?JSh|MZ=M-hw#qNAkuvHWima-L^jG;b<+J%kW1QDO#OOTM zsviAL(cV1&Q>TuN9;hYMJ;)0EVi6{dAj8+GoKR{l0uV@`7W40TAl%7||WW+p#SGI(5$>=&q_JxL|LEK-qy`coz@5 zEAjf9?H_O$fEWT}sqfm|>c#$JwCn(|%K>(4?}D7aF7q#Ji4$1r{jCLd;2)g+WeX4k zIRFK~`w{<|<+o@UIL81n5DbYD*u8(@7(mlF!65J)Kttl+Z`EH>1H3>^FsK;ET`^8@ zQL_P=!3hR|=eR4z`J3@A7RSK@b{-E0z{>ouA+rJ0JZ^9p_#YnzFs!X#A-cas^?qq% z{8!i=$8X}Be_?mGIye84!gVY5xC&6XK9{mKXcVCoX)ZiGhO_V;%8<}=O0KQJr?1&T zh^Hx~rUS8De|Kk&W9m`pew%HhM<0^qay}Hlp{Vc-i`UhiCg=kKYT=oS`*8~+Y_VMy zZ5u*iJGC@RkxK0O1=4Ksu)@RsE@s^V8%Er>th*zrpUW^{lO+?p6vJ=+8e_h$e+?^RZ)==J<|l$O6Vp|yxO{(@ACq>I07vkSy}D4Z(S@D@|?D9x(^ zJb>!uC3_sR#aJ*|TH~WWBVHiDq(a9VpQ5CRj%Z%MqKn6y=yB{UMv0$zb*Se2kYvAy z5$&ui`s5gimn8}c<>5ZTKtJ8Fc!5E4D1O2?U($luPg4zzF*Q{urBgwbZCGIz$9JX2 zC?yXyGTU{xA#;JP%RBv&F|RfH0ybVSUYlW7WEX z`*S12YP#Cc^!t+w%=Z)B@plvjT0GwG;IkrA*TlYs^HJ-6buC}8zx3|MO_@nX8VRD$ zpegJHsYxT#w;%A_Kg=_fISVx&?(VxQ{n#FKfWvLl;IiD|`CJ&{{B!A4%>p*GvUo#q z=W6i`>CuFZ{X$92Hk2aLlf?(}KYlh4OiUGV&o*o9Yu5{$p?qZyktlaTDk8A<%w5W# zKWx*&=AJcR5oVs!=s8N>h>k;ek}Pgl)0G_Dn*rHF8!Ek@{w}47#8$SRR%y1_PHuEh z=mi}bqsIDdfz**4{#h5u|Fv)16@~x#4^dG}Z%AcZ+?ESo0_l2~jM-Y>IY$s* z_#CKr5E>Z0*n~bVGD3R(P9fC^0^2pG<%XFK`RoiUnY+yCblg#pO%y|?u#Y99_^GKG zpdOeWh{U`bS!*ZvQ_jUKC?1k5%jZ!Ij-S47Ka;&leMTSzU*1d^dNqkN$D2vjFOj6nh7}~4=El`YxXp>0~)+qEA?B#O5UU)GI!F1PTLW|>Z6R; zT#XMG1o31sVP6SP`0-=ECJMl-h2N;~C>Mr#ir|l@T=0QADFlK#Ql~-sy({9y*pTg+ z!-rY^xyQZimSi)U{Owon-w}#uBRF`O3qzmY4CAISyu*7nnqWkV&=?+DuOC$u5I_D5dHxhz?lt>FGNT(nvEl9T#f&x;~f|Alos5H_k(gKoq z9l-aeaCr5*f7~(d7@uRX-DmAR_o}&9JbTV(UVHi$4HAd+3bU~)^Fy~z;tX5g+2`lB zi)4QWa-%aVcd*}Wlp5f7zE*F8PrC-8Dx06#_@cZc@I?!}*lihtA+8@6KUE3I(rlU< z4gQdLN7^n(p^PhKm&@jx@ksfd{4_f1LNfb$BP%95oenzkd#8x40alt-yGI`xI6UZ}%+1@{$2)U$iL^M|`U zUyJPcnS0&NUcni#yE)bKkY?xF+{5@(3lf13XQDXq4Y!|JpR!#P?dRYmEq>iAONmCs zl@}B2)5-DqD`g;!IR50Ky4VB!H6!Exs%rF5xp@m&!5DE%YkT6W4<+6PJqQtGDX%*H z_KJQt@lJ7edCwKyfs_E+57{GynYxcK;~qdS&rWTHxf<2_O&Qq^mGB$zrC~9w4J2-u zguL=<#A%)CFMc_-wnODj%I>iiyo%6Eu6M3k_tvcshmrym6F0=;u{4*d72!i zZU}4TdG}6SOj2(Cm>`C{LyGI$kYCaiwCUI8!jk)9 zNMVZS_e6P`#r)T}kJ4lcnAsClNjl8hla0UFzDkz!Q!#8=(Mw`@Gu}Yf;kmPL;;X$ovBCHbWLF&nKp9PQ9^?XGC7OOZdIxx>%OfxibCnPQ&yPh77NLeFlwO z`#dS*k~4}+hGf0J#66q&sJC8Y&FFkpFZ8925{HrY{LGQH?~lA^*n|vFd>{5B?u-uY zb>a=93h#C6i%FC&b9HXIiJkpnqR}v0`pb}%q8+2V&234MREb#y#V0wVRot^87dup4 zViWG#!h{loiqJd-AvcJE=@{%#jpvBlme`nomfk9q=#Hio&To3%I8vumM@=QP)t_-q zU+bZAaP7rlt}7eHsyQuB;|VU{u=v-~YSkK2R4dv~WPZ#FzD~OpN}2c*HSy>5J>JzZ zTCv-?0hnI8mNBDemN_^&ShrH@7m;*J2?^ET_e$WLmK(!O$68Wovq!y5nQd{UIe%Jd zmFzZe8&0IenNOE&k5IXly|7Oo)DGA2sy#ai??TXhxD4wxZk953le3urB%#eX9k>}?%9~so0 zEuI=rsrNR2>yBNoxS{m!YmA-|sZGG8T9@UAMvmW-Vt9Ud3R^c`=Eex;kb@Z}NjYJ8 zk;R55i{V)EQ}N;H>J?y9vJ1<PYOptqSHUSSP83|W7pf0 z!~TYX|D4M%V9S``Y<(Dw(j%&=yQ(Y^Loccgum%=0nlBcqJ#4QFNVMau_$u$gxm--2 zhN8VPA8~_&8LLBKl3L3zzs6_qi~neCMb9d~tcnN@VX$MH|LQ3o_b!w#Mc-RSzT$D; z=P^_!aniA^eNV`ou<9G-`Iu~jM?2r+iVpGe-Dl|Q5$IJ72^Lk3{+jD`1d(SnzjHCR zoLLw3=1vWI?KSb;oC~kK?c#$s*|u~ugw)24`WPw|^D#kN0(Ej2@;r-VAfP!Eu|7~Ir!Wsvghd*Eq zDA>XMi?bwjpWNm5&_7UMSo2?gV1s#3fd3uVfF7mr|5FGtt^qwt-T#Ns;g0g8&_D3l z2`3lxmoV6lA`1Nj-4A&5Yj1b7j)%f0h5mv5L9%#~@Cl)R{xH!vDhsx6=AL?2_Ge7{X-azA;Fyo5xBGg8?C>$Fa!kPhBMS2 zYpA1StbgQs*ii65G>GD8Ljj`o*S>{Yg25kpJm(|e2*RA9z;6*jKqe@lhy8obT);pO zkuD!4Wkr}Xh#d|?;1~-9_ELY(8Q7u05I9;xftTH1h2im%5m+Wd|6sB@`UW2M6c?~S zMHGh{y3e=umjMUFRR$i&$2)4D=j?B?0H@>u=55D%`6#a$qPFG&2B^Hp{c+*A=gF-F zO3Df1_8^KF1UP{I7s11(;^cvVsPf05+=H3xS9Sk0pgX}q@?_fDf5YAWpqu_5*GVux z{3Gu6ouc2mzx2nTPIa%s3l%0&OUxL#{u%ptxz6um1rKGps5Ddb?U_4emGXDi1$dE| zZEda zao?t`PxpGOXVBGNOs)}+UYRz(C7*t?o~P$dPgMANbnaEGloDlG^X(PGxR)Emnq)jZ zdpv9R=8Su;=L_N5ScW2>-+fpni<>A-cSazXSSlm)GSf9d93}Z0y$AR!s7irNpXq~H z+PVA3y?d7^nY9h#^>LrW`sy4OPqFNNQeP&!7NL3}UxD?Uf30k3rF?^dtI6tzmhe~k zvV4+!RripwWnxC2+Ah3I5k@87vl1?8@cFugU%L8<`duPLjK3v0PM8CJHaau^Rito7 zbV<*Yj3g7$i*ZkiFSijIGKDCxi17Ck+dliOWaLk5pkiAYfW^_P>6MwMtBqw{VlG9F zli|-jd)EG@G)nWPiTzD=x|h@j#v&V6?|Hh!lQY!E-~8y`G4#fCA`UBQsVx5H@X$nw zUV*il5Zcv=zO((Kl;&NRUthf{W&fgaev`k~JVR9Sl3{+0pIWNTjp>}eU7Rg>64ZNG za~~D(PMx#4mW$KE#Wree?3*=8X!+^MIgL0M*M_d2j*R}&l1{~S4?D>{!uWJBWzhR6 zI9&KJs*C1HGOsIXFhup_oA!0^ii^}3g^%~IwXr0NYwipR3H9hgm{y)>O!csp3yQ6@ zcJQyPK-!{~a*5S>3oh>swH9*`nT5OX7i0%9T+8FU(@)-TkF+^|$Ni0p{*bTOBA+pI zS4<17rhz@2*~<~Fl_%V!SC34+N|R|qdnj%Dspslh;-}ce?5EOU#S<}e&CQMh5}`s@ zD^v4LF6No|G5Cw?cPN%JBwt>V58k=zn{eOi*7@7$qmg<-wePZSc%~>1c^S(n!X~F2iv@OrEUDQ9a zfV8uSmS;D9jlT0eUZ4rf#TtQgQS`SQOJPW_EDsaE8KZnTzPbk6U_^|bZPPWu`q3ZhKpg%gRPpNv+y^KXjPEkCuuGO2T%Klc z$G?A*0CQ6Hc_u&cY=!l*%L2DWPHjvBsikc^PRg186bd1eke0*}YL*-J9I+46mj_7-RrE}}mqndzPlzA9hsC4;=cvy&G$pOhiJnmapf zV}J!|I<-^LCqaGjzM1d#mn*}0FYgX%ME`unl7~%#68`M+W1!?a-y)ZjYnM|BD@?sc^ z^?jJGJ|*AU91EWM`G;ZJ49_P6@EtBMb6usyoGb0^StbqE5eOM^R7Kyq@wG6sq$4+~ zFjJ>)anzstimp}l-m+am>=izv=$Wo7 zBiME5i3^GHXy39ngHi7UuReTSS(77)$$u-?m}wi=SiV~Hy_&9Q;&ZR_iD?p63sTB^ zrPexwJiQ*U`vE^#TG@9Xm$YQjp_cco;Fq$p!2lwX5xb0c%3;lbX+rO}ris~PhZD9Ya3>3$2Zkof(X&b7{`M|L7AD`2qT|=uwy2a>^J?s()twv=dm$*s|Tw)DQ$D}?_8U9ZDh4UtkZ$Nuz zyZcae$6A77y^z`IIT749_b~Rv^#`7r^`7y#vzWQcSUad=dKH&r$MpT|oG@zB?v6~_ zqs%k1>2+?FT9MFYc*1B$JI`OZYd4W(OE8YS zAogx8?P=wP)Z3rvBYm$gb ztPv^NoRl(7-c$f`+H?9K0oGJq@k_{;u%$_QIw%S6*y^U4$JVK;scSS&fTF?`k^~`}|*e)vSRL3h# z+RpU;Xmj_L+R~8BB%2~1BxS=Q_VXF1A{AkH3a;4xvhwtiwd6N6jm=Z~UVY<=C;Zf% zSnh%tQ9^_tzw)(~I|4h9pp~>qu-2rRtO`v5J=06oe#l^PsfT z8e9$bV$B!VTr(-@FS}I#O%b}mTS~?iJls}{Em+~yv5NIZ%#vfnKz)PkQZxOol!Nxo zF&U5g1w85v6Mp5zDcoK1Z0zoPI}ajwA9w4SY(K-6^ztRZ+^iF4Li=pnCcgN1D+b4u zHX~Nm}j!`(1U({eR)ER>8*7zvAi*92LGg>k&oP)otmkE*H@h_p(`}Rz0DdLSl_Lu5-bp*HStYi9-)Jlgtm1MTPiT2Off~_NR_ZiQ*sM zx`aFsAp9;ZGZh!KrS`__;ZtlR#ljaaeee7;wWoUGo-^GUP`rrCsii&Wy=*xp`P7Werjh7PsoP!$)Ag`aLA6fr zX|&Q>-VPQ1x~XgGHJ$}_vSlu5SAQ~4uWNsftPWr>-xIN+HPw|ngVG|;Fv!|4u1l1( ztTU|#R$4~)4Q*_#jr7dnXJAu+1Kp>{`L#Vj42SKn>Hmbo{*gNj0UQRr`u^Mm?HAxL zaM)2ouY*$m5;_46J4)vDhtT1!=|ni}D4Q2T;gjI7qpVzrginOSjxuv06g~kCgA*H_ z+`5N#J}DA5^e8hI!khtZ6QW4i(4*{J2!(-d2%<>X(4*{J2!&6GgbfAuF@LY~36Zd& zN7=a$=6pgVY&eqh_nc3Ngbf8YTYnWkDH1mHC_5LTV#7{|gbh7P#fMP%gh<%Xqx4(| zg#mLDf|x}|P1*hs1^5Sy6CND?xCiV}`>vyMz@QI+fe4@v5YqSLCWb?hAVUz3_BhIO zlnd;S91mY35OE3sE(n0Yqhw$Rg@Lm#Cj!nk&ZCB1e+YvjgK)fnjtc>}1c`v_HLV`fgrVSYP5Ij8F#5M>O3cdVAIIJh$TQ$q z)hJ~)lTei5(g&vb9)$=_a@O_}4C@L~#yGQ}8x(hA=| z5nO%u$hF9UQ*P{IdPP5L$$Ke!MKh-$g@8ml3!2*PIIV$U75V31=v32-`{DTNA1sbS4&#AvnlP2VEVZ^R->s~ zo2lM5c=Lgt$V?bhP>u8j73a_v@)>WLV79Am`lw7Ta}s{!=oKrOW-=14x z$|HXz-6Bg_efL7bgPZlT;VcO}9V;STo@U72p|KZ~9SauY?1aCSZbYOezfHkqsL`-} z-cylyyUi4N)bGZJ&PV+tycO=@`0+dvwz%sv+Eyq&BSDYwy;ZslIcPr8rOBpZm?rFO z?(~yA-H=ls&#|xZeXt$Z=7Mb9@nD%%cV<{~enz9cAnu8~so>I5`FpNUOQ`(v14?^L z&i2q7ij~Pz1Ss-%M{}#K7#6qXh%YhNj=J#?dljtr?)fxuVMu-BGNk4&H<({LQ~1~o z^YL}R?x&95{VIPQI5vgdvA@C;o%8m?3Jle zx3RmAal#l1r94?s+o%MbD#T)$mM(?;d_XU&$@TIxle15j7f%tkqmTH-DSRLGWaY82 zs*v2mTizf@xfh3Y*&>FCrYU}WbwF@L`8KC} z#nb%yw9mm6sDAIh3A8iFt%_IPzAMozaDE1t=!QQ=;!ih7cT#mQv?m|5`kdZIN$>ghIka!23k1 znd8FLWcplbK~{X;L?#BMdd_kV)|URL*JVTO7@p@W?|OYzf7;7357*i5n9q*SfPxz54yFWS`$ z-x^qkJj6MtFt`Jrw5P?KHF;uu(Z&RwfM-IiOp)woaM(0B-h;-PmOz&dBv7RyhlcnANxtFn8~o8>XlOXC!-{Yg&?U&vg4 z+2U=ofxlc8;~1SfDzMzbSSiJTM5e;uZobT6@g#$rc$|QpkA$?QF0RtOW?A^7{4f21J}aOn?|jMOy{*=yFzItNGh5!Pf(d+-ALR*+MY{-AR``nE^mf@g zTp4L=bxB3yZgjN8hCNYzDWodzN;bqXw1Il%w4xYUs#I03k$U{fJyo?9$oR(U2398K z?ga{lr+MViSNPt2uluKxg{?Ggk$70>kwQ&7^fJ$Josr>|BP(MXcvz?Q=+^TuSIC$K zG8%7nvFoJH-=ADINBufzsO*Ee@TkhPxq`Q()Hk8k*VD6w^}bgZs=YU#w`=RWS4`lMMiQt9%6r&7usu7}6 z+-VN#s@csHqLwV!wSM8Cbempm(0r@i{{^@G%*NMszN|};Z{|^^>Tf;{YHd+;X3eVF zOo)$4#D$PwpdzTz$XI=ucCMZ}Lwc)6RCo5R03UZD7RSi9+fIIz8Fd%!SA=^X-nXhp zTKb%+gBL-;A@-$w@`Z?#bkCV*&tp0LU%x-<|aAVitFaQ`WkW?r53p)G|i^?Vtqo$7)X z>);r<{k)MdONlFkRTZav$9xIZRahRXqL|a%mpk~HI5P$L5+u*wFh0{Gm6My(FyQtd zd3N#EcD{H2QtnyWH@`D1TlOhxPiT0ToT*i7Ko-ya zR-v)de{Z)LYc{l@*vQ@Y1)jSKMr*@$Cp*lT!u#bEb=Ee)_*9!!xX|$1tzNwLF5!^# z=K+`CY^>j~cL#UpM{HcBHHOn7VkzTz=4l0m>^VcN(`@Pzj8Y`w`ULKtZ}mj_PzW9c zIu4B~p0k`L6sj-~?wwa!(`~T(B;d<}nJf2ZLb2pVXEvEKTGaEquL{k}1qOAD$Isny z6Q*djWX&x&PwAGmGHL3BY=e&_aZe?fWJmm^izvgzfosiGgS`|At{-?~Y9j01@l+v5 z7bIUVCZ<6btS7yL$^9$Usj=VgX|G?tdsc=j2wD8=IS2f)*KMb^gAA_GzM0JrTDYUy zrH+(b8)9&3F>(PJ=BzUDk(O+%nh}HI>5$fW4C;sNxF*QW$^KO?JJX0^Q`K<5g8p z?p5I%y6{XUm&c5VUiS~) zt3p8r!2*~i)y|)7Ec?CoZjcAv46LhcEfd{tXYQ*+$;!jDBT~89`%&FIj;KS>Vm4T` z0iRjTO3h~zKYzhqHh`xSW>e8HaCArdlLpVt)4XyzrAre)<8 zRuP|Id|z*%6bv9E<6pBRqHyecE;-^${vIZ>1QtC$DX2)P%MIe>H(OWU`|e&pKcu@6 zomxkwldg(RnYU71eCn9xUU7y4zm@PkUuN~kpQKcNx}EBLeSMKSWTU$jzH{He5A1*6GzcTuwxA`EA=9_92)Yqi;|!COJ|lg#&HEFRdk8KR+GC>h2N zC{G!gL&kg{vvJ!{aChGBUB7k7`@T`Rb3QPK42bK;DGER4-tea)o@Kloj^eycEksrs zBGjh@+i5FsmV4ADnDSfP*zQP+1?7Fz_Ab0$jqyDKsv)|tHc4Fz7+H~b5`bPm| z4=jZ>bkH6t<+SOC5S=yA@a)0eJ563EddUlFWp?g~T6HcVhb!ADnMGr)+fyhVb2N2^ znY7m0!+UyMk+f2LVKmwfl6G9@vn!GGOd}L6yRj#X>o7T{hXo}^mFsOT)95!}9z}@= z#NmB(CAUoDQ4m8AhCy5_rJBs-sd&o0J=3dOLJaOI1RsA|Q2o(O=5Zy(HLWu9(OnYITtoNsd~3Moml?w>Br7e}`6-B3)4845L4|ks zo08x2@k}xtXck>Wa>zZwn7A7Pl_pxdCLce0tR^F6e@MppO2YM{wAl4!IJ2-7HvLuE z3OjPBbYBzw@Twb9IORYk*KZH&ID37vL9Tnn+@*p-NJIcTIhv4BBmK)gl^CI#)0~_lphPCuF}1Q-bN zA+Ss0JZAUyd#<3kAb34MG>(;)^O)_}5jidxaAyUG*3oKm9<#tYD#*oykcAKW2e;dA z_DH|`0iI}_^c(O2P>}yaLNDkae0IN#lX!um|EqBl)jbP}vZZpjNA3?bNQ`|JqymYh zKQWdL2NXMCY@R0}r7(5v(&(JDSF`sV-F@IIHXrw}w}2&*0<+*1erhs7t{@_o)@e&FXEpVjb;6jGLPsq(ll38*cdko) z!IW0yy9DoEq@v#O&tr4hbsh>xxxYr}Z7H#1wddZSa<}=uCVQV^Z(;aiXuiFCBZ+~vFU+Z;P)2{M=A#Ek$pO5iG?D<39 zg`5i?DU&&RHkw{%_qCgoZQc_q(S{MK{;+zv^+kEOSY*Is%XXxkhRX80pDMvcpH%_@ z1GkhIIk$8<75Sn?uQ^d8hfbA==L}nzH=0M&awDh%7w!9ehO7h#y>t58Q~gL=MoVvV zCr>(-k&dx$H;r*wRt0v;rHhBw$zaEzc(!7oA+y^|SlqbcEWK*zGQ+9*4ib~b$)PZ^ zg*WYB=g8;7X{YL59*$L&^bWOgadg`dXT?nKX?Sk`q9Or}FJpg>MsT^&8H!l8U;~;7 zeIobbtoX(5*Bk2G6BVEDGyDydHOkg8EWl?$y6%?M|nHH{9_z8z=a@%RyQR?Rmj zC#4DF&;f~cFX8v7y4M=MXxd(9;^R+zu(>tC^%xiP-i1E3JoGS0HZeLhMom1ir8CQX zpKmYzgpt?5aBO&3+r7Do?xgt;#Q%7iQh8C8pG{2~#iby@ZpQhI@9nGtY*vhr>YKdi zY8Yy}A>%0tKlzqJj5f+hz1(p06|7Iu%d0-RQrV;4;ap7=&6~qMRA+|KLTGY@&8nj3 zX*YUu#>To;n(PD9wA#R#b~!D~X;0gYhgN9}&-?LPV9BGxIVwpz-C2)Ik@~{>QZ1>; z3cq(t^X>7LzmZITcYhwe@ba5w{d5n$oGjW&Ud{v^C6NbvyaQY2AtINl@=rSi@McLS zIb%=vFS#rXKDZKBb(QqY>5su5ms);GpJHScF6g-aV9)>VR#=TqFbD9!x}*NtG;oHA zODIt;{##$$x-@3G->dCh55BQ>9SJ&lrcku0t(`uS_cAlxZDd{IX`(^Pl+$isZ&7ES z7UzQ8@Fc?b!NB{{En72k{-d_?<6u2Y0m53}0cmvns>TT0MS*F?`XFl9yAZ9R-Hk~M z6b&S1MNQ#ox@Ba!;?&z;M0<71>Z~cheL4qocF-kbec+geqkEm{EiKvx)(BtC3#{v> zp3)6CzSj@f%f3dVK-sdKAul6|?&a;307DS>gwyYj9LMbv~xc$!YC z!r4l_vbs3t8vH0#!_RYf&_Cen#_{MRPJ7#9ak!S~}747(6Nr3bRJqH<{kB3ej*R zVdE)I`D*6!d9r2Xv7VtS&}$LqXKoSJ80GB`HX5$2ND}o+v1+gj8eO12?e{_TUX{sr z-)8SJCCeJzw{Ik)$rn4~+owfOH{0Jz#+8kL#A34BEm;&!u@tV6vx-$&lcR=H-}fa? z^uBE8qt`OrNx*Fyo=UOxN~e-RClpsyfso6%4®)ge0&9MI6Z)wj|GSyI#Z5QWuNqfBKG?;0eT;!PR`>od2|L zZf4OVC2!m!?6=wIBlX{lzY=Sn$@)?7^`Y5AxyZRk7^&7CmWiobjy_mXO}D3sMp&c_ zWyLwnM(v~J*6}Xj4;5B>H1S<;E;tu(x_W{bmKIjWS?rmPljMfs%Yh^!iVNT8`MhcGdKy%bYDo+hD**= z(`1IStW0MtJAFWH@Q#_*kbAbcs4qSIC3LTb=VuxU=jp^pNgMV4^*Ipv*UdbQ-(WV7 zJdYYbQ+AUZcX%mkW(5qk!=AaCdN8~e3wVg$ZSOVU%qPz%)?yscrO<=SU(Y4hKVZ)3 zZ*Jg~7y3^Axpj~E2aZ>&DV^HARF&?X*ZEZ;E= zNJUc8Ml1`CA{NF^nwPp;P2MAz)eH{?EMYs>j4@-eOUu=LPIDRrR1%IgTuw$76m<+* zBpTuVnGQUJJd061 zTFW|gDlgFfncoYd+7$Kimosnf^*WOIAbSquH>lgOim@8-ClF6Vsz3UajEH-DWbf$W zA_;lTS0$Ug?sq{p4_frPsDh(y()^0`@9_{@PGEJlsUZhFCsGkKLy=ruN5s5nl?58A$*J?|5Kw$8GAjTnu5qw`d?p>CvV zZo;tVX@k1^3qNg={S?_O4Dh4cvbJqfE0+5*E}HY1o$uqfC^QL|5o%dA(aNjywb}e$ zk|4FY`jN+K($DCQz{IE#YXPkRA5=2c9@*$chxsQ*16` zM7OQ2QhDIHhKMup-C=t5LOb>x?W3P#g_jC2TzJdF?2BY>-g-u%#<+_GGxf&>}`t~f*d z)7c+mz1a~e3&1l(u)zmk zA^+QuBHrNdFWmp!;PdP=`Tmuq9l-|wC^0p3zW{&P;2(3r_(SM~4L)!J`LAYhRN#mZ z49-*zj1-P;uAoQRg8mRZ+(W_uqYeCv@NwazZYICy`b!uv+HfHt(1spmmPVK}ptRva z5El>%c2XzT_gBuqXbJ-McgKr;bl;4i*ibmx5da~M3m^4jLL>}~rVtUVL;ql=IoeIX zcI?1g4Q{Y-Jm;f!7l?8OMpH1rNOMg1nEN6kVPG@`LqPBZJ<6AbsH>pBXbQ%MDCeUn z5Tcxc(G)iVB5>dv`S*SX9+n_@B%+*;+Fu~b85m9RAo9LEN@|6u&JYkVfd`Rc&QWqI zgu=jRiWdRG2L+AzSKWpHgB4zYZyfLE--oypGzKYp!NUgJoR3x)c9fk8QN~=r!Il$2EJfH+ zhAM=@fZh#3oCP>Z*I#>>3%KY3V<-fr{)f?v3kD!V052b}@;~SnFh>GLZpRTkc;JS= z7aPQng&+u}2s`Fyj-aEsxFEpe6+zC&Fj+*xoSYz-0D?Ln^EXEz%*n?GJYEsy{12lS zCod0(w|RV`fgSTVN0c)U2)K)2ih~`4lMx96r*m!uQylD=?>Hi15Yw0&!4wBO<~xo^ z7#{8yk!}N5>AxxoCqQg@5P0eWv&?@G2KX{BqA6~Fo%YMV`~r7G>L$W4Lli7vY;ek=ZL_Z%zok_5o&}5p*4*6cvK-JJ+DY*M{{Dqmih3gz| z`*$}=hrBsuC)o*kdo$;A>Nf9ouw{ks6d1IZECgSDTGF7R@N!$usFFAQd<)6vbc4H} zWYQCZ$Cl1Sdbu=As&)n&7jgO#l3Xj+u-7r8zxJB8?d!+m1Mbh5Q@(IrjoEzGGdcNzA31QrWutD#COx zkRrIUhLFbRh0SI@VJ(C*q5dv;*1b1SKg@NA!>x`qD}LViGTZ3eadopcuQqL&6Cf;> zbSQgDUwKD|PVWV8IM_aLnv7^Z9aUWFtT2&OAw~Li*L?1M!vjKkh%+Ru;^teehFD~q zp4q`GAH2hRv({;3%z`tvMJGxm-&#};!-}+{o0X7bx#s3MAJ+xWsoMxHuwmrLa1(u8 z^ciPL)_?v$e27SZ(OGo0WLppgC&o6h>ZcWC=vi}8c+oJZlfR-Q?#6^xcDr(x z8oB^JN0z<#Q)1OhON#T?%T@G-8?C*WJuvAtUXgnk1~L_5AWPD@%CEXlKS&w-5>Mpl zoOFAgzNlHp728iC!ctXCeIPaIO}2R4<+^@YN3{4eqMgWTwvO73v1Lvlw$75_R;n9L z*Nk)ggQuj@>cmx4s#MIvJ>5Sjr5CqeQO0ali90WR)hr^zo%udR#LqzC*xKPWre1Tg@F)o+vo*#@i zgZV|jTU|~#{WODJI(-MbG=uc)qRH8g$VjxSllQpDec**Nx&uXX7KgsOp{~sm$P`15 zW?bcp-(2IUo0nmCLCf5usEf|R++%Dpm)_?Ey^qC;vhkC$r@|P|8b)uWrVDr*nRrjJ z#h5|nMmhb*sr|?A(>?Y5sX^r@f1TKp)#7D^eAJ6nN_+;L4Eb`2cns%jwmzlpoxEuh z=RdBmY-=h%;f{XZD;vYX5W^ueEavm>Dj8bj80>B`lKey#S0ZU1-nI{I%QX@@p2dky zlaO^t?jy_MVXH4+BJ(8U-9PYtQe^dH^2eUz4!yFp{feH@Ksh}s>a)?*4oiqO^u4zi z8`W9CO1;^XZ)qi$H-6kQ<*%06x)fK)z#VnnL4&-fIzd07p1Z3*`%)Do6-^NJW%}CQ zP&#{YnA1!2IEw00XM2-(t1DDI8xJ3&@;p#<4J*g|&WP-#%mNY5;W%T{d0GAAlMgaP z#pinYEm-es)d{C(9wArrS#MaQ)>((H_52buq*B*pBp_> z2chBW7No;1Wm$GYkttQgmfnLF)u3pZibxH@)3>qjMCGE@!-*Xr8X#Vgl6YVB(jZlzI>fX%&qF_qaK`r*La=2f zw5?y(m-~v>M{seTuMf!&UBWvW?CTq=_ zR6C^4{GSHmTYY@wUxb$9+v8DFyQO?CSxPOykw0mw-b6rpbcxo#_rf=Crf=RMVuOo! z9cP^Sw^}z&H*MrE&oJ86o(mWK;@)3GVi+lC68>f_4ms!9vg96rsp;!FG~rq*lTuWC zholh#4atOlI{J6A1x~`NPnrcIr|jr3{Nsjs_=3}9^vS4BxrXN&LARW(Z-;Je zOB;tQ|_LPUmccb!@HLRx95MgiUu453hZ0#0EXYTGaRbmr|^<{S|;7J>E zNB0-!MAkQ={U7?(4YCImT2!*B#%>6GxZq*%IGH~))dv0b`N6OJM4Bv&mXEti>B*zT zCCzT1x|d-Puv;b@yXq z9XqykH2kLq_HZRfeK|ZdD3&B5Qz%yKTACYODIP`gwBnS97ps1SG=2H>ss`t5!Ob~B zBxXywyC$z{?9?Aco?#VU9n25s^3x-5wIDG%r;M3b(z3M;vku=Lq<7nU9bTzJ!=h5k z?@&IslEUAtej$cs-ASXkFp0Il^P(}yV{48xYBNzx<2VHpeW5peJc#W~#BMd!CR;p8 zd2XE)LmMGu zqLE8~&|VD}Q=)NK>z&C~^P;Ua*UhVxY^$}34^)MV=V5FQEu)GWx|8eKe|~0Hpmd-w zd@$I-K|O@`achBlNAR&gkyW4ijsjQ4IUA!cb(lZ7P;b_c@Qey233q|Fb%7nZYYLs{ zo)ju{5+&?5hLuh8jb{l2c)htL#c!a5YgSh1vsFC2fsJ8w!!!YRz3G;pF(Yny5I%_= z^lW^iOL}};)^Lt>Hsy~Ws`}Me19RdWtU`t)hT4qYB)yLte9X5+`b1>e~{F}bik3M;XRi01Q= zdWK_-P9zWz`=;-syQx9+_;vK)S09LxvVyEXz4xSbvvOp0hg|+9eUX?rrZ|tsku|}v zq7`DXxOA_fp~@Uph+?C+stx1eJJxMz6j|~brqJcDI$qjc>_}Ba^a^3m`vd7`xP4H5 zT;MlDn&KwzzViB3l!kU7Yjo`JqnL@;7LFM(Nc=ok0rhQ`rn&m2qxv?Z$xx43~6hwjQHpZ zYz{q~HzYS~<62r)Px)P`^hclH<_WaUy0VxAUzSJ1TEY+6m5TU4_Y4hl4zJ9$FnJAS zA^If)uK6h&-G#9H2iGQ`)p}k;S?@cftlV~R=z443bzitr^Rj>31P50u;$!%a!FjQ!do+z zTJimQ=Kdr$ui-8sby;WAaf}xB2bmK>jP_vZ{Rc)1+vkr0N&m-2Sg@n!EC&Vn-!WP^ zA^9JhoIivPalDfpK4HK(=I_EMIDCR|gnt)4$>9@r)C31nvAIuh_=Fv$Z$c;xuuD#0 z19S{`0DG;!)|vYRhfmm1{w9PupWyHbJ8C_IQ1}FgPuNicCxpT$IDEp65;!3gKEdG= zc9g*hq3{U~pRl8!5D*EUNt*27~q$j0Q5Uv=Oe&6LScYkaw4#Q zgdKGpM`KN4>cbHW>!(owENBJX{BzEPMo7 zM<@)8t$7geK?1hbziSs4uzlu5^u_6qNWUjcG+f||6E85$KBgdG0{N?6bAc~T2>h~P ze^?}+kTECt;)KZX8n$ot{FjND69m`>-_wp4`X8o8uyAAJKr~Ao^;1C9QJlbB96`QE z9S;zSf*>%Qh~}uH&IbsEA;2~P(HsTT_OIQ<3787F5Y174(9!<(DdBhj`Tss8{M!eE zUmguOTHwhpSFPZFHR%aFHaNDsqozkEeuShytE*oCmRnfFIam)L1cBX ze4~Xx_OHUHc+l~Pk6@@`gTRTIX~8lY$nb!Pg8T4zAj1n^kkRr1;};&VhUVEHm$?sf zfU6UfmKXS#@Pey+AfI37`}yye0x*QL@zEX}51x4NoWnB0;IaqjCzbKv(+{6{Q2YJk zL0-Q<;UI+vjPVd!9x$`<{i-t~3VBO`T z<%WBIfVSRmv4bb=x6Oh4VGh891_~Iu;eBw}st0%OANhc(56Jnq6mH-f1o@wq_^%fa z%Km%J4pQKKw%>32JqtfOxaYsL-(}#b`_3+hJ#?r!zi9>h4nR%~dibEP4z*`rE8y3- z0j)F??{hLA_&Q3rfIXHexK3vs+WYBW|_wWDnHu$Y84nL5Ct^npC5Ly`A z@9FT!3xTH`9JzQ7UdR2bz_R#>VNg*1{%%>NXQSaA3X6u z_VDTOCBtEZA3h(RANT{DNc+R*;ZN@USMtA#9zFZ-_dy>X_QrmH9-Ko!tVPhb@CMpX zJ&-s|-OuYF<*+LbG~s{l29O(kKnAOJFo7IQCI=mIaNj{$_Z#To&V%EA&cCVK;mQvO z#2efn)xf$Is0>)y{_7tgyaE!3N6<6}^V+@}K4)Sj_?5g7+1C9t7IA zUtAurH|7Rv307R-2vql=7xt^g#{o=tXu0<*%E__+AN&^H{cZ=#fA|CU&w1hIjkMeV zuH&QSh2OES1_v1fkH-DvgHr4tdG=p|gOYRqb`G!k@3n&Oo(>**FrFWtg9ZkEe_)q+ z&|U|rzuIBH#9&?nZ^?f9@WDey{(1^{{=wZ~y9Mrm?$2Lj zeDDqdi+y+vdBO0)3zi*V_XP$5Zg}4x+yL-1kOW_Cz#k4j=LO&a=YDtafE5|gc`zS? z!t6IPCnwmRADkW>foUobJSaOnpTo2Lp8CB;a4T#0a^|3)_WwUvhWysQ@YF+@gH#YZ z1dI*)EppH+`*H_w3H(X>*P*}~5cCg_;63c6{k!(B9kkHFef!7%l<$}II*t|;Y~?{i z9Xs-Xy%R8dhmYR-*A5z&2aL$S?&bw!4p_0m12cdYgr@^qx&6Nb30`1p_TSlmcR=<# zSq!*YYhgRiaN$Ac7jExAEs{ZbwtxU)Q1g8|Ao z@E#v%23)1a53)J5$3@_|Kb$=EA;1~Qc2i@`C85bNFJiHs8x-YSx2F(0G;o!gFov<&l z--+uCKnuX}6QIt#@VXzIgFXc+3BGIr zH3#n(n9KL?JUH?JU>^)|zooz<>TuF>fwv0i2pC;~?i@S+J>}rZAWQ~mtl!VMz$*HAa2K?)C8iNN<~@Dl!hKk!w6zh@cCeWHrziyymSBRevN)>mfzur z1M@&o7ck7?upj&aq=VqwBge0w0M7b#3fKtYl%4Q@IP8+9X0}GwfQZjb&(=uX$iTwT z2nXN|ht#@`eUI1C6%%^9FmT4^PeFxIs|N?Qy~@SL=Gl;m1_sZUmc##HV$Vm%LX7Wx zT;Ee&zp2)-P+*p8-1Ly*2Avawrig)-SW-;(<1?2pP@$3ttKXDP3`MT0s*-D{szQ^x zmT5L`h`yam8LV<{df4Rtz1kn_xO$jL9-n;W>Z)dH6}!4HXeZ3jbqz5%UR!a#w&CPJ ziXkQC-MeSyVBb(vY(GyhnSMusW@>x=w6LByw(j`2;ftT2 zsAx^_Z8>LFF-ezT8O7tkYkeKbo zOv8X*^<|(5FA2*Q?Mf-qV`Mi)j7Bnb)V&l*Oeq{iZivHnh-gz+UDKB;WUP%->ai5a z=9EIW63l}<2;4(HAzusQa?iCFj^86~*=}&hSX8q@3bGAy^WAFM3K5>oy-wNzyZ|I;kG-82S z%^HOiMgD{N@UH*vd5pMiOt;mc>H++u_luklgOGfL1l@#YT;yW%vmZxp2~D~c$J|y@ zSHGqbx5?h@cIlC~*&x!>!dGTUnv6FwkS<)Hz;)jltKM=O+t&8jd%dU3VxhaMX1^D3 z(bPa6cX*r7KV)_%+OI_?Tx6-cPZ4Ez9gVL)#0dlC;x3t+ImS(l)DWSdy=T$G*Q58` z3ihNT_PUq$D#`r$v@~`yUTlO^?}dD=>Kka@VGj&(vbW#t!Pn>y!O#C$nSQrwkG1eg zcI49D7nv($E@pm7k2Agu89^P+LL5-ZTjH;h#qJpU?e;$k8NNBmE$pNvwIakuiFEk_ zYVBT!>s&(UL_^x>Mn{&AYE?+&=FkNR^B}Xwdp!c_A@3-7c}YuaT?=Ee3E+<&amNWJyAg#oKv$IVIX^k|o8?TQ6p=J_13rc-7Lrtmb#6 z>Gb|V7+I+#?kVdA-7MZWw!*)ONM!P#H!MeJNA5j%Q*F$l9Q7D(mFZgX{Jk(yH}V6i zQSksM`AFOt&q!0uS$dej6TfOcKrH{YYgzk>U#z=^d54BbvYfjCkT5nPQtqyO1vwP5 z2V>r^49H41zR)R}rdW?Sw74{wswG?p%F{2{ZkZrXyk@6sNXEt7DV&W z-S*nd4i%4b1w|tj)uM4nK=-l!tQA@n$PZQqe%C)PQnCy6I;g`1jxckZ|1jj3?RGS3 z#VTS~EyI!;`!zBGWueCvAQ~|swMQu$9Pz;LH{<KsV^&s$qrBUo zu$}|GFpjh;^2TlcwWHxnZ6_E1YzmfS#5gZ$s;^~i<%ri{CZ@{REt(RJb7blG{lb~g zbRN~ek|v;*mtCbD!>Z2SMTqMmKN6l>OL83-6qnm`=5EF{OVx@l==~>!9+Yrx2$P$u zMC5sF2ThQ7C4wko~L$jk1Qjj z(gT86?1N&88u$2Mn$!XzS?MQ&JRWX|&gMtyC3YrbN<^MXq=m<>eS}?sX~GoA2%37= zsyoL-w38oceus|9Y!_ov%$@j_gV5Vh0McOc!sh1zj6y-)ho#@i!-7ga!4S->)iLN( zy+wGNd*AEgMJVWP6tWD@!8+qjD6lRj6OhT0_p;pxCT(mL1_jW)v#P-4%CUmctAdBF zwt;Mnhc%WH>|}lT68aSHvfpUi3-Os}@XesJ{L{YC|`BkB1t5f2)9+JKA`CRxma%Fg|Q$8fS zlKlnqeZVLE4z?UnMl-!>*?et^ ziX4q>S6c5!QTy8vy0O!F8-7$^gkQmM)O_V!HbV|Mi-|Rduo3sht5X%(5GF%4%%WS) zN%4=%UQSi!jbe}taj0PM@?7JXW`?Tl@Nj07W1~y7|5lbUoC!iZ{li8^oNtOXhXqun zs|`L4G61v(4qIXPNeiEI6(2m2Wdg5B4kOnO7!k#BIJ^F{0Io5gCO?f=&yWRzZ`KmIIGd~KYpdE7bU@H;y1Txi zpE5FLy$Ep`5omo+a&3_-=;Uj$YL*&SIf;a?T?#rr4YvFshWuC3A4VZBfENW0*?QA> z%Kt(8#r2u=3H2&8e>f45`wgbsv^6TKU1{Y3ay?-ofjpySCT}B^r<7(+C+%7R>_+0e z2G->0A&oN{#xuZ8Uu`*X-B7?P>2X z#mXQg7;yEc3j8|s-I-B;T)f~`9p@j0wSeHp*EmDxzFux;M+{LwdnEJP-R6wxd(U!_ zL{-UBTVrOTevPFy57-`tBn!kJ0h$_YZ_gjP+yRJ3P#Q_4wblJ6u6ipp2!-yVzov6%6C=-v;>Xc}rw zV+~bEPkb_ae>fzcLzE#9HpNYCO(5tgkiLURG_NQjYnLBUB3CDdmq%eHC=HcEGxDWK zOl)(uK9nM}P{r)2zzV>1eOEPq4;d_b!}B||8CI$G>qUnilSE!*nf9xh`}I)rU#Z>9 z$xCil9~nHRMDqTo9?5V94Zub^`vTWeCpRl+LQ{U(I^&b4GQ%*AnusI&IqxbVTp z5R>!EHNGhQ^V;K)ch8jZlXT7ulZItL{g_)NmmjJ~d36=CF`_T&S5JZ7^xis}fH8k2 z$BB|_z^>Sv2c2>U9?yE*^ZS+LgP++GB9hUTI+x^{H4;=cf6coX#2BphM(6I;2+*vp2NDc3CM?FNh_=*j*| z3rU4C&hg}Kn|MB=Z6j8>11B}T)#8!aK5ZX?9us(cSkw(!IM5Sk@TFptk;wyZG}9^u z0nV|Rngt}J_t`o=A^{GQsyp`1OUO=X$dhH^$D;6=p(U#fH7sBIb%(0AA^|Fu3eFE^ z@>Rhg?2tnm>U>gUkzZr^uN+SlwJfA4V~vjxd1iCPmqS>85GlH#X@ylX)I`1Q&annH z!F^AkO5Nxynj1I>T4KR#wOW$qzECwRDA}C(Wioi=C(RN~$V0Q+*@5%2UwCgFS|8nI zgp{$22DRvg(@hJT`(v?)_@6HvE3G`gP&h*0ulPq8ie^+#ikw4w!ppwxUJ6mVnRyqs zyxITW1P2JY=(!t0v^uC0SL`S3vuk;-Ld|E=l|U$jSA6sq7p zX<@pU=$sy>k;r40hD2cK%PnTK)no~lukDp#pz(T=`*#}vAA(ld=9RfaVjo`KBtH^z zc+n%H(OqC=E;`*zRx!g2j+7aaiROt6rA+8wrwX3l=j?V7wwM{%*y;cpfk)t^?fn%< zT-rLw*o)`vV>n2i3S@hi+dtV_vVsCH9 z-vtiH*=l$rf8LkMF=2QNsPinVrQEsooXrjVxly-fJ1|dMc<<$ z)}&HggQv0bszY;Sy5APG51=N?bb9L^q1Y)cOKgN-r2-|7)>BiqKCm}!)toCMdPkGz zypdSjp-)puSYN7P{bOUlS`&=2Su0Ja|JrxvIM)XL+3R7eQym)xI35dh^Ja*XM;>8N4dVrE<&7V$Y zOQ$X(4aFfst^aGCYm~#^GodJM)aLpr?X(EM;xV<5>Dk2O+U5}R@x@y0bIw-^BnYUt zjn-dZh*~ah zC>(IVeLfGVA3J1hPL^*PgnYR^fySu~?KXEq5Z$aC`M8DNMYA50 zoAL^raCU7OIJ0LBOKZ$j3ZJ>yt&;hI*Wf4N*!qz z=*38D6R6WYrv`JyxL(wE#GEo-s7CiIusr_TE|$eAme5R7WsyY-Xp20Bn-=nHB&Wj9 zlTw3rNR8269vtO8xjX=N7mY){NogHl&)kDY;7j<&+h2DXEsY>ehv(6uWu(B9Hy7aA zcO;Yi`e~TUNG-kAL@>7zg|Y)R&dK}X{Cu?ArOPbx`X#OjqT1P!G{u**0e7OVQrDa% z#vY<(JO)A!EOA%-Fuub55W2qCx64=6)%{Nk4#k5waI*Qb_2M@##nc8TQVO3lzMQt+ z_asr9d)@t#5q|y=k!H%fX_cSDqzB|i5hJM=Kb!832ViGQ@H*1m@}u6Ri1SzSq)0)W zbO_+711$$4JzWSI3$PWj=&v`+Cjf3AUB=Inr>NZL>lyEluAN?~_}6+ZuXBCj9w*(t z?Jpdk)ezq^NPy|T+Gw7mtU>JfHXq9uQnJ@RRaZ;GkoT)Z-j14rvl5*x-fq$`T`g*7 zX}iloSm+t;#>rduf1585|XN+~T6XXvx0E3#K_twUPU@4?5&3+_S>CT^ch6Tv*#GG>0?O}c|S z$hp%%a?4Af%>1nFj=_=0UW^n6Xh*iSiA*gCA;V53q08|+-oT!Zll-}oTjvdjxW#~R znYxyS>*y`TvzktcIWV*!ie+JEj;_BHI9yu5?X#Ps6L35<>Cb5l-kwBKK!=7Y8UH@^ zc9E;r=W(HjOlan*h+4+ouJP>E*Q4$~VZlLlYek`$#Y*q^DfowZx`66?R+Ht-`tn_e z73~q(tF|_{f+6?C`F$%(PW&JW*pDR5x;qb{T=}~N+Jf|0)|EKcB{>tn8-pkr=J3zK zg+_lddMrU8i?qcqG~id|_A{ESvl=s?9yRF34_V}FZG{pps;HCl7q+g^18DqNxeOM( zeE9386Dp#)F`}eW>;&0J>^34tsQoaxAdwWQQJvO7Xs5prGI$xp5sE}N4GZhF!fPr! z;Kbv^#8z(pP*z!Vh^sFPeY{IiL`t`H6Gu!$Y<`8Dcf3$d$*(CKrO+(Knzd#|7qL>E zW3qUVT8&u^UJSm&%sJsH=5MTI z#1QSTl)g0=MuVR8hkqCrrm9|Ts`iqcnTyqzk1K8U4erMT?iXMdXNe4w8Zrs2Nx+~l zYjCYSc$s)tIGwfTjJ>YvTaitBvc#E|JLbfo?@7xV^o})F7$5Vv|KDo@7HgH%rCimXp7g(7!#g2RGpfur0$aqdf_SvBQjwTKo=SA14s ze9_f4Mj3>o#pz|(>O5x4@d;G3FlS!eNW0mA&bRsiH5b!kb6W<=N}RV(**`DBpb|~*dlC1}N47rAo`*`kgNvd0&=lx24^0|_AZD&oeK&Kw9rA*}Wp~Ty%>Zg? z2CGN%B>CXnM_a4-WBd4(KA6*|M{vhEic%(!Lr72WzPc-0WhlCfgR~`5yBkBNW}?W? z^+8QOh$9sTbzZrOk8RRxzHLN))+$U@8!9bLUa!YOSLag?4 z)T1>}_f0kvDdx-rbH5pixg;XKIpZhy5CCt!SpBu^^cgeKP4s&r=$@=zfu!j+5tK|-Q3uhl^-?`*1` z^qt72hE>c8)-1eWkcE+4n4+o~r}%xhts8V)mHm$0D4x{T`p)FA1Ixa?c|I zu1njy%luNdzIPtrPt#Fx@7}3$ATq)fAY=&wLaEtUf!;wyI!OPy_RhgFao{$umTMH~ zKZb$uWrnZ>s_4a5h)Mj5#$~;s;X~A(1X7CH1=6`Nl#h$3lgjn|Pr+Lm?hPZ)xfjgVby-qOHo`;EYDlN{CR`}l@=*3! zD_BW~XE?0YBY^VzyWL7!zIiOpZjceSBsdntCm|jhV_2Qhi%L{_(*-vNx3CXqflE)U zwTh_yplSj0^XAjx&zKARWJ>&yLrcEp^EIp8!LLu@F7@PXOLuojdi=coH8~$}4s%C# z=^bU+Xb@?~*LI4T*Cs+GB6AK;H1Bj5^Pc>dO#Ij}m;}*Q12%%ew$X|9`_nWK-IUl= z?t$r$Ds8x8%4O+J4-UT_g#cil@fCyQC%qtYE{{mMgd^c~p9Bq0CwWW`wEM7f(W{D@ z+t38$->wQ$H;Jl>F=AA@Y7Ul)3_-ZhR?7`8))QKLKCQrCtVG2b1F0KdjW zbqBObMZYpns{vL8xWY}-hp$jZ9E8V70*+WVYzu@I(o(?LMQSg-% z?RsR2*QQWSA8iUhI)c!--xqR&)>B@R^kjSbHM*r`Y@uc-BWP?u$-(k-eT^ACyAcFT zSs8pd81{pztb#3@!YQt3-bHG5mC)DSUxW8E|Dk;*te6R+sSXa?xZKB?Bf$`k%YOsh z&tU9@M$-l>5T6K^CGY^n?lf2-5#p~oYpq&`vA1UIeId@9bx5=iqq zc@jpJgfDBsug2<2R2?jsMuGz|CRFmxJbg;gl4OU3bTONN;ox4V|J=wXB5KhS%3XCx zhPfB-LcU-f9jiZIsV)`#Z%kwBE==9~2Vj<3C$3TKqw@F{mqVM8a0C#CJ5mtAEI(=k z{Y{bh7Q0gIV_EjY%9i6ZwYJBAvQsxb1hAjsZ^TKp4w6%h%7EU_M`90e zRK`e}Aipry9N%n<=jL5b5x7qVV+yToId{P+&l+U@vMrmur?~>O@DNNnWDQ0h=WN+z z>NALP&$(@|A?II_02$8cmYRP|5W231IoEjVv#R#vwo~lJD6W}nVV!!jFI7z;hY=Mo zN2+#QTrgX3CCc7)2B@-a$ERzzMS7bqec@pUNZu`HN|%*h;doN18cK_>EpiVX+kR2% zWVUHUFeo?fw$0Zwt1VUdlkiAsGs>BdqiB zdL&nL6FhToO4DPm4`VlAuCoXdTitt2R*~>sRUTHZa-!+ z4jKO`gAAEuQ+UT?&(c=ry}@dfG+O;+h{CS45=PbHZKX9O38!D*VS#8T4Skw3J|8@Y zNnPY1=MWUnMC#it2ynb0vei`wcckf_hh3AbF*JetCJ@7!_v{Ek19qm3(JuuooIj#N z2%*HiUQdOLiD0Rl(y}k+(=y;w*Yf^|pl{m7o6V1nxsNn~>G^lAPi~%*{TA!YD^b%R>O7U}Fl9bJf4>?$qhY={NGuI&_MR9chEt&5w6r6YL+#Tp zqA0efFBrp_BQDL3xQD9<<=o*4`}hxF95@@gs6hTx`hI`1df`aILW65?_(Ye7xnn|Y ze7jPkc^yjG{&Iz+29FN}rlIof7ok^)cJa$9w8aOHxf@bIZF+-@DZCa8W(wx`5wRZq z?K!8VI2LjB-@K5h#Ze&eJA9J=SXo_sdt)H0xN!bbdu264t%&}N8h%^drn|~8oyhO3 zbGL|pUK2%ry`Ng1>(a*YrpR;iLNaCIgn#*cF;NVwHjzz?rF5IlUHr-9x(}auh{VP7 zJ_4^r=txASWVOu2lZL1?;f^XL&ZT2SGhlX&+PKMS{L-KwQGCjNlJ(A?A&1H;H3K&z z%4c0F!}R)J8N7b0f4=fL-O_oW>=pJNO(0A(pyqH*lH6uJvsi{{mOw9#_Y z9ydC;OJiomGY9R*ej&sSekR$oFS%lmEz!2m>c^3LNs#^689bPmas~3RI z`l1UOqJE9HapPqf9lAwa$aJ|I>vOqKY~kkAS`O!9#D6(gQ71W^Z7UZ_06k5p|LbWp0>LT=rio`16xwM?FVaz zk(ddm_q90&9M)nv+Xz$U8AWHM6-zurh9IB0Ue!gaew#OqAx@Yp%dmt3^Jvnckq*ZX z&U6}4O(H;4OOjW#8gikUpQ&L;=WFWit$0qNhZwhnlCS(3F4#lHF>;|xb#lj-EwjuM z_S%ToY`pX`5U8^0gGm@eHa>PhHL0fTWDXP=;UUIlnSr%x-mp;S=kHC2%=^)B4%Ry= zzM8K7iY;}iKtajVAU+FxC081v5%$NbXi7Rem;JzdID;{FV&=to?wTky z$UlyT*%eiBx#*tKoi}ca(x_xkko)>;DmwkV=&^AE#|KH0hSEjb?DSzW-wz*7v@5Q% zp0%YoeJIBr)2AM8yT#59?G~>!S!QrXy*9u>CPSQn2H^5Ta(hfxE_xZ7yld&|ZntX! zo1*W&9XbPahd_ok~I)2{3$AZQFso(vIk15TlYmMGEikR45gHGC$wI>KY zdvTlNj!`Kdun5S4MRT(=Wufc|cTK2;Q1LJRH2QDAaTj{KoC$E^V1xrL$Kfa2G2N9a zV;VfmM+rvfS%Y&V=2In1V>@Sj*^AaQ$S6%NHy0Ygl!%VJ6GK-}_TdOiahc^e2{jHt z7j{Th=#e=`+Yv@4d0X}Emj?7lNfg*%5v?N=94cf-`uH>q-b}IDSV*~kVY?GpnytQH z#rmepwxPb>#{FaE;5I(&2_?pJoP5k;OT*TYHT>|kkMSn1e8Yk3^>3GoPVq4rc*W9q z^8u%5>cMCox01u{U4yHp{2bWNpxNf*3$ShE3+u(w|$vU;Q31%oAibBFz~)~8jk-0n|q{SSsJ zlrDzYFB7d+IrXKEL(Holxd7GQy3!~hEq9}BQ$Fi;^t086IVz1TW=_50*u^TOwzJ%U z*r=5jS0v{-wlcxkg!K-fL<~pAMv?OiN6XG$)0$WZL+;g}ZSHU0q7JDUYYRi;Xop@6!mu~L_8Rm>e5zF9Jt^}vPM0HBeOI7 z`V3rK_fP@LjD1hz_&F*g7n0;ktY1k~Z@AkGmzOL)LmP4xDeycJ%qArpZd;3uJaa8v z#wP8MCD&Lyf}F-ebK?vov}xF}dF~#T@*U3w=+D$&NVCRn-3OBegd1GdU?n)06htce zA8%|{M?qZmd7Oqm1wXyT0i7$B$XL#D(d+U?3KrncAA1jU@xBx>r=&!s;cP6>Kj+H{ zRAUV&+g|jtac8}<-yQSdYzhr@@z+@FaoofB`m?uCB0f=b>(fR7i!F(vlFNEJVn%nc zvnCR9kn$o!G@g>VfN3*HN)@eD!wH310h`{f(pzOI;jf8}Tq?itj!O}STQL3mFk0JTDXrAcNn zz(xG1CZ-C1Cht-Cqq{jgDATKs(gHr_;Wp^m2aGC<;jSx;s(cLQpt{3LVvbKz52M7L zr_59dRxV1nBr9`e*F-R2*=Kkc*CDQ%KkCu1*M4RuM7$1=XRXDn{Cw(=BMp|c;&q8S zt^FmG>`8wfA-Om%dWjcAE)=Ell5Q}a+M2^RLv>c(rWN&!gv~lBE4K_ssp0-*p(yi| zY&+*p!7YOB1Po0$ACOoVh6(p;@A@q}$L0ZfrpB)416KzQ9! z;40=AfTsxXI}Hg@;|0$U!clt|u9hh>i=Is?JQead+Q2BDU)`3xj&h;MWZAo8aKu5I zrZ^kX-&FXMqQQ*64=|>2)>-6~S5Dv<#^HFM`%3E)SpaRAHS*uWDJOS*ImIR~y>6Lt+H3#MIbcE)Q$QvU0rZI=qF3Rf3hVoBlg}u!>GW)@!0%r|1TvU1O|p z<^Jw%6Nmk;qo9Eh8D~l5)T(~{v8X(V#-Mv5(oj(ssZ8tJgP8jPIO=yFM)+K+i!WFh z{A`aNKN(Fq=)d;!0w{BL_7OvW&&U#P%r6T@ZnD{?zj{6|LdX5U+QD#nq%*^wJ6NB&~1_D~_?C*hXjY+gkE^myN2n+#m9pU1-EElmO;L$So*X@t|jpP5iK} zcDzO>zTps=Wr-8S>19NM8D8mf$Jel+5XWxPZb#|CZ$#;h{z+-%H#u%x4xXP`dB!l= zx#Py8wB(#9k1U&PHbF3{Dv+8^8HuFnhg*s^azj#! zgjFTEzV#Aurzn?wEHdvudY~?(HQw$bu$cm~V5^R2C9g_a1s{DmxcZeYT7HG7lyprp z<%|8of(|4EpZ+N{uKsdC^8%gl4!};X%i$(TQ{@gx414##SbqYSN%vQ8gWAJlHVioS!k4rOX z0a#QAgeID2BI=<3G`9Ll3Lg@@NN_>}dz8{8?yinfe1dp0JW9sL9$dsuUh74Pqhkjw z5_Yx~{pLg0%PDHE|3a;BNjYUTz}?$)8EL2ldD37K>lCNTX4F86}hSP-N5n&Y?Kr#rKu3EwbmHn&2Q}{!4i#p72-fesM*pN_Twm_J`N0+Td zJf4+#+y>)f%~5KOFk_p~B*?Dc#P|w_Cf|HqSKA0MBIe}dQ)d@FqAeF}8uA!W)ehtM zo)9^X38x_b>iQhw#d&P9YnP&4;9Xng5#k|^uLwMyZzC!jGQSDVi3Ivt$b_p4FR5A2 zTteIA5KsJ|`0Slt-%)w0_{{#K$gv*WwuGS2|N96wNB<=5FTFpge=B z^E6DDl_MHXi_v5>s)il2Q+rz~rG1skJ6pxdY{RK+E;Zf~fOrkEfXRjlmBv#tP_zRRZ|1rJG02odD36(tReEN-!Q_MmVj4?~6DpMu!3;D2x`>WlQ> zzjB*VG``c7u@~&Mg$Gmj@=cK|`%i}(wbhPvua{c_HUG(u*_2qZ{af?In&(ldi&fN# zMxoz!)oLjwk;l;=*<@&yjjXeJIjHR24U< zY|REJ>vVaMSA|-|I^~0&>{v+50m1yNcjx^EacU5@LP|QWI?2qpL`5RKjl-BFd`hR{ z9^~%Arw+D>?s`A=C8%$F=Y7}$>X^0Y#~7h)V4`krEkX+=bozw1XNSt%xiX#R{1@5ZXa9D z%~sXn>d-D>`*_-H(s(sLzHEL-{eDbR8*UO!s%=4RfJ7zIKvon7GO1eN*{D&(mpJA) z`a;kkQ z{uc|EAa=kKWztCvMCfx`FCvY;)X;=3hW(Y8A7br_EsD6hK(t6W^SaV)zBSIHBRwXE zSGnD{1#glqs_TwakH*7v>0h=;zp101sYh*B_WkWA^u20PTT>&mTw(b{7B3Q&p-{+# zsnTwqmaqjJR@vuVJSf`Nzk*{bseIf>@?8c|-ire)YSu_vwJuz)_%Oc(af4BTk0L;O1;leAYoHQ0qlj8 zXIH->d4`atAb@<;wvuBRzmCiNt!PbR>#A-eqXZLNiMVU6V|G?3S?tS|gL9(IL85y^ zGTk!NaTpJBC9XFjEC_|rClmlY&}u2o!Ga z=py|~4wXz^yTYVT!Wt_=h)dSbZdvZ+WLL!Q~Tqr z_<{}ZBOSPRtcykO*wYl0jyFl=)*b#h^(5VvireBYjoZ)U3q91kTpCXRJj&cHzQ8;X zE~B7Zg7*6@He&mcJc6h_g8WI_BZ3K+%^l{TEUSB0W=QB`+FQbb&(S3wIWbJ z@3)d*C7Ylj-mfs1+z)vBwv2U1>mqX+#97}ijP#UG-7swd4J zA*_hhae*~!i;zc1BY&1i00v-(6ssvfUO&%ibWp>oA01Lf z(Rr?!>3;NR%?2sAcw>(|22+w|x)q)3DP2lOJ84-keq(E?)dCi@WO-Qy$SLfrFVv)6DO59P>uvB~)hg%{{`DTdQ2U9_c#l!4HTl z=e_AiiE;# znLjj)l8=-1Ojwj1<^`B3`a}we70bTleO>u%_9?F(NM4g|l6pgea+4JAiJfk3ITB$f z2e3JXNsdD8Dn($JxMxS#1a;}@5tq0Pl?26ibasB3S3t7WS))LbC7C)EIM>g0dLJ4qk$M5PMiZa!v}aWfZ$uWi zwB#vpDfbcj^0C^JY|eA5{ntzY&^|*!qW%P5INR6yy8;kbGmq#+2!9#DQoQJx)P$9X z?MRb;t?1WJc92WJkYTP#BDxCQ`%ZSB>f}s5Jfspm`7nWnGZwR5io#W7!GL6*TP*Wn zr1d22mZR{zCz0ui#Mmn~r|LliCdI96iBR>P$P^twO*~`08+GC^6(G-mjUblbBW{)B z>}4*C_LGh9<$gUax?MDE$(B)kM&@oC_Fj#6&e6g%$0C=05)e}pf4Hj4p#5S&Cp`}`_51L8a8LBf( z5Gq}|(th1SV_Pe|9qW>7W#x?{zn`O`^o@s z-K>k0;rz2G1K((fj_i-Fu9kAkrq)4*C1T3C)=&Dxw9$4{6qf2?m(+gsw9L*Wg-p0v zbcL2<6CloY(<~J9S$jtdhereZalR9#-o2I9>enz^eh(1OiBxOi)dBv$7#p5HVG+Vp zARV5)D*Vv9hBt^CCQwaR9N^fnX6m!eEp}x!z!Zchl_4Wg^<@|ZfEP}(~A zM~WSz!2f2hbMI#wyor(?hNFA-vu)2zgxnZ|<@UG;kYCPU{+LY=3R{?xDw0fT>U2o! zv5DYA;edYDFGuTnPP!#m|5l*H*Z|x&Lq~~~VTYv?e;=9D3^Omhx3-*}w6(uVtd6Ka z#iNuEAjFE}7V+1FUwD(a?1im4>Ar!NU zo)GI58`|V9?G>_b!ypY^J27h+!VE|~s&Kki{{xOA)RE} z2i*q9!6jMNq*{VjucL{xMu8=-?h+cY9BLH~!}d?c{C!V=0g5)Jq}kZ8_2wosm{Yptq|ph)ho@wjmiy z-#KNG|L>tpaL;RSmJPF5e8QEnSnD?A`{BDm)J9#?Ahp2Ao6k>|wsP3sDl-M9iWaw$ z!Z!gPH5XPBwcxg9HQVej_-OFP_?(;jL^UaT#m(8_-%hH~CGZ55bNSc7HxqZlLgAKz z-jfPXvpUbme`s;; z_itD=R@MK5!Tu9R_5a(6|6{QKhad_XIT+ZR**ekej8T;4Vs_0I2wi@8RExA`Qa^?e_S#EpM!yswd0TX@KaMj z&sNmP%*6Dk$i@N<_^+A&j?vKncTmhx&(h3*&)US&=szMs!O_S{`9G)z8ld|Bo%919 z{anLT&tAdEk$@Z^01yO-0VDxZ02zQRKpvn7Pyy%x^Z^C{Lx2(B|7{0g3@|oxHUb#i zIN1YC0Hy#_x1Y|vHNXsD39tfK18e{`);9%woa0ED- z+8Y@G99?VxP5@_s3&0iNM)5z-`=d1&{a`Zx*$?tROapW>Y`wxToztJEb!DMmP=D?tTAc!owf9)Q&E^vQ)cCN1A z`9S#m+mSc^6CprDcC2F@st-16Ck5a0&DP(v=4{my!lTwh?0WD}wqN0L;C!J^8DauKt5{ zv%BD1+)(e`g>GhLWoih|^juHR0-Ua?7W@|q$pJ>zX4dI1UX6tAP+kkN_Gi~zs+m44 z(+BC7c1HqUepO5$Pn8!NFX^FZw5KWQNNKbsA2Y)@s!5NGK`SZ2OG``M<|*kLpG7j` zT}TG+>vo9wZou-`($wVAInT&K-_pPX0F#vVN%E{24W5?3tj@<_OX|kQ(wM*m2!fH3 z5uNNe&;bxoD|QCsr;~4b2=|E%*|^Tp&pX$Ca()7ucflmUhf$b$=Wzv)^z{va?Cj}+zkJwae>?B+ zoP9S_{-XKP!oAOloNF$22FmscbG_d33HVy0Jtq~U((e$|OeddGs<@3Rd4Pz1G!?<<4I{50vdT_bL zI`H%@&&>C&Zi>ihk??(<;0)en6Ixr9_UN;2x=XCL3(p`|Z_C2+y^QdAjJB1ap|Rqh zc#%o{0S+nqsM`3MYX>zxGRcCJt>>C};``h*C z`Io`r4v=eI2cQgURG5A!hVTbWGeY0b>~{Xg9jUqU*7#54S% zZ(fUE5iJ@3vT?pJ*gleP@Ot1hqo2IjEC*i%ct45z-mpx}zM?1adZ09={}`_Do%57! z{ud|FSM&qky;}aRJM(tS`K=n7`(?Ec-C~=IJNp8`5p|y)^Z)|c>mACs(;O|d9kpGsz$eq-q%ZOKh3Twah z>+%4I4NT`D5Hm_=1|o)?`0Kra=&Gbh z``Z=jbDd4q4kj$l-pVf3VamumEzapX5grZpJhK#{Q3^x2RFsW$e~1*c?=4*8mlGE- z9?OGhHL@JIozo*|P5;yvGRvvKtW%A4tV%_6JdPYTy7^G-r+G?A`uIR2%q-B_g8{Yl zxiUdTqVIRneixKH;7|C38PcDH`0#4PEulbwd4;6x@;NobV{54Rd?Cx_DmbmDD~+0h zb9A&oZa4Ddm~V8e*|La#`||_@zg1>RC9Cwyc_3Ht18vKK^SIy!;1baPpx--ue!6*; zmR}(4eDMy`H((wAx%_$p>LAW`;kVn?eUp|J-xx5t(5m$2MODfKA;uvBhHFeqG`bhS z&M~oodr>XuRfh~fPV!0*h-=3At|weP5C2*zjB~fbA!(|b?R~w2L^N>h7qDI>b(=3z z0%t)@G#RIUTtssaexXc=Qf6({IK8yj4GBZ+m@{kVcFWVYgH=^#L`ciUiI)oAMKN*F zb}AJf;?iMPX2OlJGgBZnNZ8{c)#iNX5|-Sh)xs-oumTb$BXb!^_&ZXPp08?JB)-CCLT`{N3?YgrDR$oF#f z#kB$WPkRjajq2=C%S}oNP@x%M^GMT8`oIpJzKf?TGBy^|QdQktaWi1W;w;j;eDO%9 zLQo6_yrOdKLG`dAjR!Xj9 z#=BmOh*6$p^HCMvhUDANof~n~wtW!y8>&aaDcJrdB;r}yXhxsx z0VWq)%HbKu;ct})xootsnc8Xm@%FS4!cL}46=+_e)AuN{^_)Q%*~R12w{~vE1lN2h z$FV=?IGP~kB%x9ohID(N7C!8nkJTL7BJkxuTypeDEiRn#(XEUz+IDNPZGQRu=GvL^ zpmp-Pn@hD~ouy%|>uysWZuBJ%VdpV%k&kf_)_@V+wmo%|mWHK_=cw8gd-!jCf#sp) zDX(F`J>M+fh(S+NN_tiAwBj_zd!V&x*xY7se~WW9(2M`H8RHP6H@KR2Fkh!{{ooMC z8zm%}Jx7$XX@C;+6?>m6K6tar#@?(UqXbj}7AA7Sgu+`Z&dv#R)-N`X>x4=4JShuF zXXaDAn;KtKoitcAczdHB+-{YG;OMfZb_P7U4T!~yd-}}rDn0FA zIGN(Zbn`=Ri;SYX;|IKl11?cEIa9Cn)X`dPfiYOO^48s}^%8U^*%te(6SQ^cCDUVlbkM_+z{@rmp#hf&Fl-N5VLY*~e75|_WQpt!y@x?# z7{!+$C13Rp*f8!DTMZ^N7-?%wZtAy&JIEWi;x~|7RWu*o&!Ppn*Tr{((gvLx?u2P7 z`{X$gM7>eeD|5e#e6g4QbMo%E+Po%}uff3}ZZM13EWDUsIm|b)HIn4aQgA^xb76k0 zchExOTU9CTtJ6?ooqH{_hTM6&vz#9mjH%|URX$))H0Xs3u5zGIOv zk-#@HiE;n0iF+1p^A(dg@_1e)NZ<^@~S5QyelmqRQ^WEvy=#Fb!Kj;EN@ zf~E3E9XM`qK!pazX=BZ?R&~AQQN7P>4#SbFkf_a z#+W^hn4H?!Z}tX)m|f(uTl+TD+)-)nnE-eSW}w1;`D;&d*)NWL{v4&5sSFW}y?q|V zm2w{x5lCrf{a{xt)rX&=7Gg9y88>x>+Gns#C>cwL#GK$DUfO{#B5 zC6LMu3{G+RNm&EWHNGzwk;>I_JR61WH`&aTb%~ImIaLy}zQtnw`cWG4gu@p=xV<1O zCf5on9>;5NtNtvorS6+~(5e^xR!#OJrUezNA|C^Xg~UT02?< zbN8$u^ROG^p(B*<27NtmY9IylFej3E^c9Q>m+G3*+aO*kb9g2;RH08N^kJxlm8fNg z>s8|No|&n0ZTnC{?h>T|20chn3fxRntaN^*OyNZ&H7dS9H{jGKtc-<}B0A`&xRl*L zWzTB%QNn`8Y!y_M6H!lS827!9`Dy64$nw-gpcPqwQbacHI+UoEAT>&h2tv5)73yBgkBY(i8Ir75if9t4 z!-B%C3<66&@aq?%ICKbCg29LQ*dvdspOY+9xm_dihFa>oe<@!`aWt^*90Pj>B{V2) zJS}g)T*xH&Uj0@jz2VwALR~(n7|JqI5KV&AxWMxTbMNot0d1H+R-A;qx+yA^ia^u%?F;iEPNjFDMPKcl z8POKTwszmXq#UQ@@M-qi)`;74wsh*$@JrL+zA)Uu9;jg7qn#3Kru-;z;C=E=U#$eatBW_RJ*KNngPNsbTEaew%B;w>L#zdBnp)!x}BYrNAAXof@rkR$#; zLf}O2wI17zUkj{`@S70|Dep`h>R`roOa7V-B20AevdMX1syV%kVf~(R;coWZ!lJGM zUm`G$)}=9L;%Yt$Y>6GkW*Zd|tVsYqaZnS16hJRJFYaX>t({dN21))i?wrD;>_GP( zIR%-J4#6vX#y?xB2d#DrQnY0%w59O$4>50%Vh763tY4SLVgg>})FuonQAz_>s^Y=)qq=sx_<8U?NgE0{-1kEje z;NlUL0s-|x5=Sv31}&;iS~qb9$s}<&9!S#wb0+4{-wMkuWW|mu=`T`1Z}}q2&x=ku z!}@`nKmT5-BPBMlg>1%8%mZgf^3e48YDq_P_OK}~X-n4a^JM0u8KG8*{XLoZq^UuH zZ!iv5ht0tDnV)uWVnp0(+v{vJLnC82d&BhywI$bQNVc$YE{x;Fc9yfUO#3|R@M9Gl z%t&cU$heElxsB=gHg-1Bk|~dovy` z9Rm2B$YjG}W{6xhd6R+ygTQ?LvBF)nV5O~5ClmcbIApjg15k4wv-{w3tYNl!*Ln#j z7W^{{jJK0Lzd<{xiY>O9=~R4)!9>y@WTi&z`#QOT8`!xrfY_c>vO@zB+c38xjirZRU|q9|M~W%P1mUj2o?Svs&>X-J3HJu3fUp9pn9fFC8h-GsB%d6w`AE>TG<)^U8ON^#kGCrK7H^_qz2K^#@)^jmQi#N? zWJS;vh15ddoJT*)W-Qm=aXD-K&91OUPzIOr!ay724FvcI54Gse54tp*ffPYcBft4r zGe=WtQX}~JbCuPs1*p(^zcxxztNIMJO3z2@*owLy9&JB}uH~V1 zvwX9oC7U8fzsPF)FWzIbzP@<3E~yojJz2C#fI=mnq(ULIs_ZjL zYj```r4}JTG3zyjFcNEADsMHDUQl5pw27KK7rAh%&mWaIOM zFzv=Vr@bf##UCAzdj>=d^`xtyDzi~x`&u+!$!mW+*6iWyL5-iNCA2s954N#nD9cbb zCNhlmDJbEy=;kE#oz(0zC!-+)-2vt67=Usho7VO$BQQa5I%I-vrEb>zjDOXM)q1^0 zi|HBZo3+hSouH`M4Q)4z9@5h$kPZHTM%})9ufe1nIeim!M9jDbiRT3RW1#66?w}5v zU?|X%s|*c{%%RHYnncuK97L8GVXqCW2ePl7wnNW=gQ*~EG98q(`%SI^xsObugSu>P zH__0=*c#$Z;82$zX-A4z^id0F8QGw^lA&S4LD;y`OL%8kUwUk7C0K#kpFNsKvazw* z!C8KL`y*wSg&9Gg?81BpdxXRSNHUb(G@ zh*VtFog`goQs?zHy|<`$eTMS$&|vEL$S3Apf4nN#hGP1LQKBn;WMZenTd%y!V_fA6 z2RY>roOf9|I!~Rg<)tv*dAC+DtvR)q*eNRyj=2c!cPTH8Brwvm;ms$Y59DQLZBI;U z+Y<5&t4ggFkG5T!-+GDN;0c{~PFb>RJNFwBn&BQjVx?Q`YffqEqrxl;1eKXnmjDanNA2-g>Wu5gTS^MqN4^PV%2e5+2 zE~>yHDk-^{)#@e%yqswzAM5RA+C+w9zAHzk)u-)O@INNoUhVhBauSqFX91vtug>oq zQqkcTU4WO_7fAcbMVSXRy%1%`z28#%4daVqX9LMJdJiucZ4EM-hrIiIy!c=t*MZFo zTCs49)HSJ7_3V21HP=wV!AZpLR!8<5r%QM(eciM-Rr30DR6|x=u}8I`BQEYGOHpdW zPNtiY0P=)!khF>rBT#FuLHy`Ap+CM9mNKM$^_WmgJeSAKUrCRfEL`d@^DuS0GO?u{WWk-W zfY+O9#tswtQd4Bvh%8Y4Oyxs%kfEAZM%mpb9!0|}Vgj|-Qv8LH*lv+yTZrK+>awB@ zuq$M{wPw>9l`DF4HoF=UC3RHBxVrB)UOh==dFGDPu)AT}I&S2Y z<@xTcJzXf|u|5tLprascGN=0DW2bAy7N2#)N(AgFwUUK%C$h^wMqjoLosmWXs>62dRysxQ_k0wyOz#VJ7 zD_&%C7}@2vy_|HF^W>JuVA&l*M6*v=lJ`o|ZrzP4mD{Xu{tf^BJEN)?HM42HCajpy z*f0_ZI#LFMEEr=PP@=%*D$q=#0luMfX0Z1Ur6s( zm3D>mHddjX=dw?to0A#;sl3VPf-vrA*GiTsqws2H%Gb|+Kh1`A%4{Y57e|%Ht%c&f z-I3FKrgJ!)>v5_FE`d{-?_7qXxkNClPfR72AIwn=CT(GzYD8nqj;BykRjlWQHYV&6 zf0H(+-X4TDG@`d>m3=d>MFy|Ym_vS%5~-dDMOO^Glum0Ar}R>vSL6>NshE8ce?Z~f z7^XUS(fH-1nj!0ZENRdafUmwQKa$Yt^9RFqwb_0jOgoR-Ekk^Su+j%Vp}eoPytDI; zRL9lgDnbh-55SFrQqH;Zzec)eltC~CGr6oogys)xna^kIW5$X-NvqibsM7EFm?!6^ z_T`GkVWMlH5@2sTJZYcx^*GU1(^-lYZp4W`d!O$ur#vEFe~$#WF8wfJ3bh63su1K^ zuES3$LQq|$?Yo~!ssZy`v6K4$%eA3^tJbXrnFh z&e6Z#pJ-OZXcI|ti~U7i1i}%`#pUr9Pu!@6=W!cgUkyG-w+CnS=p!DH(Sf_Yy`x!F3(`%)~K+uL0igz~b6ptBybyAID?$;$EWw5V$(ZqKax38yx8tbxCt7 z!Fo&l`8WeDj`r=*#*sP@PQ@U_dxh%ajh!`NxHZzEQCmqK{9aA$dv8EFJ&P%Hx7Wr# z_x+YtgauPbzV4M~IVt_HcGcn#V^T7(jaR6AR@yqjBK`=tNn%y|rG%obB0S7!5uV64 z3y2a=5FvbQMD2Vkl%epIk`A6XmYgBFp3`g+O5_ihcT+0=3ux|3N1|>0epNw>i##Sw6QwLfXIy-F-yyy6ZmNs<1kVJiP=>qJg`B#% z`vR?U!~jB@e^wFMYX#Q+bH&5Rpt8p(G!1Ytz*P?D^?0)5!xY&C zam8Q*ETF-y_k_@fXj!|M%IwN$6Z4VZ(xMn9jJ9%5|hqS_|! z8w$3GjAzW(?$cdwUSI93fzgJ3Frhr&-aNS=F*zGV)`2L`A&@b=4OwIOFZ|2w!4bfS z7(onhN&JUEi->#hT<6LgH0(MHFn^5oZ;;)NGq^C{wCn9I7R&jG8)gm15 z{2OWFM}4T+M2!Y^)muw$_cd}}jjWh^F9m4L(MtUgQ=tTF7(@qpt6c1i5-c4n*{|R% z#U4eE0MMfZ?JVW;JPmyUMJa!mvmYdW=X*aI$h|nXjo&Bjg2FKE7ZVh&S8ZXU8L)X6 zXSrgevYYoYLfMVYIHYbWl2LBMVXt3peW(`KS4vC#!ZL^Jgj!yvyj60aFVE(Z!$YuS z5w#?3@dGkgMi4qC4!wx8T;BS5PsW^!PY}znV4l3YqBiuu^Z~qP8HQK*77S%xrnS1^ z+iurwVXGIU{9)MZ+4+iAAKK#HP1SvKtWT$c8wkb*==3FSqmFP)v0uXRur-je#>Jy$BT{)++d(#@3wnAKaRi-!OiEo~GA zBkmfSr}#zwk}cjB8mVtKj&x(3_2q#~OA8S~AE-7$vw;Gxv3yc`e9Vd-Uoi$88UoF& zlROSAew4cA&jMLMzk-ENQU^^f`kZ#kh0Gs8yeJe&@}Y_-=8~|Y z?W;`xoE55o-Its+L+DHWUHt~G2L;4+ocpuCibEf&0QT{(8~39iiV16l3!Ywz02Dr` zsj47Nx9y|V;fzV5cHyq1A{B{ODGi0IIP-DcBJWTsnl4Kb#BW(&meLp_$63OvaTV*# z!@o6RUl%&l#j$#yNd{;3h8JqVVioyEp7^409QnMTvs9VED%0et$(`k=xg?Z=lV!vv<=)ncP z`iChSp;5Ke_wq8L2`T^|nq-jR0b6a`H;6)`9;Q%fNHSWOMh(B1@hf{C=-bCTxoq}H z(M^fX!!Ey-OuT_ip?49URzi(>Vc*^lCWB&G)G#1D!pv3?qg+N~-aSPTWSjK0agR|~ z7v5fbKQJcopSciFP~=E@4)%w|VexUSGfQwlf$vi_LSeV(Yd6dg%fZuxq-ej!<0V<+ zHaA#oQygfeD0)TuwQt;`d67B>vezOvkq92uvd{;UK<+$!Vt98l+CXXroe-^t9iSP{ z$!;YcEPYc72XxWUsH7MZn*P#~QOLcG=zQwR!)Jz5QE7nKu`X-Bym|tNW zrjIK#A+3wypmF)5_U{z#F+-0lep{0&Ie{d!s)yKRsIw!EWNc@lDLmAkFW)~VE(y(pRj z^_nv2FmBQApDdVZBMF2lnKjSQUEzd>6EkE9Z=rN;h_Lff=02w6PES#a0Q(|bd_lgi zE6Tq*!FC#v2JtvBeTuHi$ns?HgG1jbX)xOlh15W^0*}h0Qj^#aU)kM<_eOhMuHOJo z0YP{uN|@}qV^E*Sc0#GWk;C7Bj5lF0fDty1b@B~3ZNpT(4PNmnSsi8K%&h z3&%r|#l5pC>SfR&s&FBZM*Z42bi$vx5Y znv&^jOmBkRFUt5k;3Y8D>Mw~LK~9g{3ant>-r`O7f~ZJJ{)>L)gI`UOv44kn+d}k` zVAi@zaGYIy2fbi>$#S{%C{4Rxa09s~v_lT@4#UDZUb}xtlRT$KUG5Wc6PL3!U9MSS zG&;^FjV{(Z>_{}=VWRk)HX=DXw32pvG)J| z?b=;*>{)y4G7JAOPg=_Kf9&%la8Oe{bW*PNX1iB_Qm{l=Eo9$yNOEr?F;yEhLED>+|Es^#}I!X8%viV%+mDWhJv7C zv{qrnoga>mPEwyIt$Jdx3x&{nx|lY_5MZ@B5g+bEp!I|^0_~#{Z`)1Gb~l|i#S8YZ z>mQv?Q>{oipnxfwki+F`{NtFe4Cx{Dw0_(ko5MBroj!rLK01qjMl_X7j^NYM6*H7& zXDx}eYo@tpagr~Ad0+A%XxR6PF$rk+;T@`1L*zisa83kdJ$?!3z0bF%)Ly_+ZFh3j zT!-h7YANDC4UoB}yX<*8yLdk*d%wm7Em92dS$7)e6j-C{l2XgXv%!Pqi6AJ*w9g9L zB-y*BV)?%5U-`wfh%FlOV_q2ex-aB~z-59~f+~s>!K3eWtSK+0n)8e~cnFn|xlA%c zPE2bVYSaxlS2|nG^podvBa;DK{HMKh#kS{_x)S+>K$FN}NDy%}XKm55zmbyv2y1 zsoGgV6APbK&DR*4jN^`)OoT#@S;HA;9gz(D|W zCg_t=p9Hz2ajDi~%Q`=iE5$J`&c0@(=gDf+c)6wUI^e8l41WN$WQK#8`g`=mqmu9; zVsy1#0;vXcODAq+OPC>GiR#(iP++iHVzxWrW+xI$>o^+uXFUmY3U7ntJH7WST0h zv_b^YvBOh@L2vO3-}A5kso51%{)z;PTyENER1*bnih?h=AP46WK7s zUzQEvY58#|ZjA$W9klt#NxJ20Fps|wD5e_h{*{LL;89+hyC}2twWSN>;~mZGB6_C~ zip@F>I}2jASbIAomD(+0W1B-NgES`7HIRRXddn}NL)Z51ENy7FUB?GxRut_*rp59# z3GqYklgtDhgbNCewfH&7-sT&HYrtI4yyHp;%Usv z`elSpMNU{be3bDCte~$Bj2byGuG7}4((zXiJfM8ZGXv@)u}6VA`Cs_k=_5IeR}7mJ zEcB&mJQ!~s^1EG&2A@}G6)m0z-VWWT8KJX%)O$bKwZVYk81Q#9^17!*h#}0xf|OH~ z_upv*HXkQ%t5Z0*zbs^=hEHd)jTRi-kla5c!b7$b;DKkY+b~`0%Zy*b@aWzLX;Pp|8Dq^D*XPROX4Z8qOmYtuQ=#T7G- zL)tnfUYPW@2G=XBIIMZ0dXG_q$hKz)3?g8E*`VR%tFuK3GBU|F`FUPvM^7_C)2Wu} zQGUlINiBNwEOP_z4u*eg^M{T0j{!|y8$|KLnQ{-_j^+rNoccsnICy`ayvDF8ElZk~ z*7CSi3gLW(oiU7lK=RtT*1+XPBc~umFbFlU*4-`i?#nx58etTWm?-a^;KRDcJ^B|m zB&D#C9|#7Q%FreniLJq5Rvtk5nTAj0cpsf@Ms1<;Ne!uQ3Yd| zj4)L{lwXAXU=(671mhT*gWiaG8f+cu17_ZwcEIr_m{)!;u;H*=T$J}h=mbg&;9j(9 zEyg1pK2Fv@R&c!hW%nXYNmF)6PCllhlQiwe-pV*G3fw<3&hQ?;+o#i%(Q|dAYfx&- ziFu;f&>?NQs)VjjRt(I8wNDm{{r(biOLIeb`4kZe)Q9U{)G&G$>ExuMj^4b>&w{Oa z3z>%LR)!ARR;Sovoq!TK1%l5ARE`c-G1(z#Z+`vJQa11DjggQX=^5uV>QC-xHI*$B z;a?^ynMCr}Te(%wICFa^6s)vDO+1SMJ5=t-EYeoc&saJnw-Y%a9;v<7yd=GHV+P0P zNAzBWFI<++)sKrawIEH8hvc|!HkL;;?R=atC+yQbC2cmFX_;V4U*mp_fh3!vKRWI$b8lzJjd%{5~d{Uzxk+_QSp~G7f$jnlx|Sb zMP;v7vVvR761$Z>YBuFgy}}pLcte?RH~buzIu4ycng1M#Q$bkc=m9c@5uN2#c4%GvV`^yY(ZSF+dtK z*>$0a)3%G;C?gM*)Q|Q>@9Iw0i!LoA*0&~JYLe5cjrCI{dH$HV9ISVu*xA2kIUqIy zJ44baFBA-C;nwydH$s(sLo8kt15^;zuf^pADP^FvGcbA8fzSI^xa_1jWc(%w(^f-u zBHWY7ZW70#)N7qIGU4lWAR-nf3B^PnnCUPbb?zoQ+1ckiBSP6vuEXcT`zaIVd{kX3 zYA5xY4Mqthe|DqI)bVRA$1K2E!BbvmE1Mxl@iBR|T9{ zUAkgwyTP4jRnJm>pC}{}cj!(}exj_Jf$5Xdfh~#?? z3{-T9?UL@2vHh%XJeW(ohxiVx9w;NmdolidckoVGZ9!ftfs^cr$tQ8NV12#M%`r02 zJW(sh(=DD4DSJ}E<+qcZ;{*g$cfeYsNrq<}$-uF)Dmq}Aa=bM@f1I~DQ&pE?E{VDZ zTPSVh3AIQgb(8cGQ)UjH0;Z2wc$vom@v#`pxJW@?8YX#>dzu=gKEKg+vq5?#JUYU{>Z{8YuSGs+FUf|*u- z(zbxk^m+u{)TRvPJW=}KF6;gYlcEJXocq!N3nAxEw;kw8PSp$b7D0nM#MRigsY_T~@)ECLhg;egCDN z^KA_|WDk7Te8%j5AHn5qr2!5zmSB{BVM@OhHl=rnwsKI!(LAyopP)>Jg0NpAwYp( zxTqp^rle2SE0;vCW#zm*;2K``Zen+Zra)&EpysYT%gQu}@)rtw!kxJk?LNKq1 z`%0&vtMm(FU7TC3g8P0Tz%P<*D*u@XtkA@uEQ-asq9 zbQ%^!%JUsf@t+Ol(_x4~M0@-@iPHTQ&`zfFp*4BJJzK;xcTG*Xf&@SRc+&%-Z&c6F z;FZ%K399ys&wCcru1?wLW|wgV+p4Vo8JyBd%znh)hPjuS9(%)$%n5z%t+f&0ji zL6?;pgI{K%jS5ZmKhpmw2i0AdD4z){n2RguYiG?Ac*QN_r*?AZ9Mr$Cq-GOk$%3@7 z_bB`weQu{y>}eg}iWy<_4t1t3`?_m*3(Dt6p)Z(++`MB|HZ4`iCt%^?Ks+qMEQkrh z#(TgSK6|WXJRwU^4x4TY#}~M^gf&rdC1>A8xpL4qTXv@0pB6Ih{e-81-?Y}L(A@4- zDen#IWFi{1t9Y_^E{*27J*S{j+)1{N#7#8Na8w+{uUK?|G4Y$LZrtmm!V7BE)xPFm zUTtqogchK}_;aMb;*101zb+#*yFU*NC%mHvBrC+-Z`tL8h?Fo$)^-V5H2UBrS zlpuFcse2?T!CbHf>`pYq;p>p;`r$oVXaye{fOqm|Nl3p*#&kf_Lc(`bN;xsXnhXE_ z_2&crN!I$Xq^LS{7(S8cA|Vf`EWl)-4T17e`;J;eV7FY^OEUh9eAmH7Ui_3@b!fhp zZ_DxOn-%m*p?+bz&nFbCUH2wBRq9dkST9X$gS+-YYo}={DkiYXObP>6cG`rbc~D|& z537;K9JpyZa8B-RA6R+$uH?T4R$i=T=3!cs8cFn)lQ&Ni}s{=IDuhK)jntC_OFTVJY7vf1ODwif*o{{zTc!ku}gBw@oBt1#M#W z6{mtxixBSUK&Nk?OLt=HJu4l`UY=1(cX`j)i{jwm(bX6=zN6JX0P zcN0xS7R%oxxB|?C0(5P{tFA;E4+M~o*P%V{l=TPooahml$tsBD(OV@vY66dIS(onDB_^-vcJ^YB0Vq(oNQ_b65)Q05)ZoaUL*jPX?Zdo zDq&|W=PJz+exnNuS7u3{ok7?b48DKg*GsP_e}lahMH6no)#Pm`j)uCJX+ z<0~OFp31SWKIUz?AH&30QliCL2~;Jl|0zI1Pjanp;KSydjc4Lha~!#L4>;%fRdMXW z_v5%+Dn52|nbspK&0W>(0+;I>I~QC=60~2kk(yT;U+X3G^b=Fiq*)V1cXzn?%x(ZH zuby2Q3~Xc+uSSEMcG-O(Zg(=sod7m|#IsP{JFiO)r-C(`K8n0-nXcl!w^ei)5Q|af zMPUYZSAZpzZP5#yn&m5wG6gDfy74j1{|N36h2+pg)|LC|i_1T|k?Ta#x28}w=ZbVC zbonLvr5V=yfNm>PGi#ITsH0{BCz7Z6NN->D^SQ@uG}B3?Of1JcDfG;~LqdOkrXlRr zoUbw46C=@b@&A{s3?j;ZJdLLK(|d)%kv! zBP9CVu6*3qC=ri7R0bBq&R5h`(|vD4X!Ax5q*A9~+_v`73|%U|Fy_Ph1@MxGlO7boQ5q@>K?&oqf3Z0EcW zSkigHJnX`q?SU@iK+86%j+$GG3vp>jba!me_{5~^g$jMfau`F9Da91 zUD`Y~#b9%r1Pk(!a@14u8MTa=5EQ&?My2X&S4hqhn9gO^cpDYH!$IFVcj#uAOg(kw zx+GfP%=+KA!IZZyii}N3Tvnz*j;AK=u&zi{sdGp~+Xl8=C8dke1IPXSoTQKHj-bCr zb)N=`f2DNtO$gv3@5k=2>mI0ICoRI)_=buK|8)o3&095kT%my znnuwf1`#z;L{ETqHI8r9Se>n+1O7zyf!9LN@X2(Rad|j0L|Uz2{WZg7XgiD8P9STd z{&x#dI^cBwGI13X(3kp)*es~i$k&B`CrmGTwEEh4 z&~ynixb!co%zG=SKyFSNZ};EK2X1Lo!#b#l;m-NrO_3|Y8kZq6?}&V7R>*M_h9w^| z8z=6rZY3LSF|jVR?M952MR2ma-K)-*BnfA^xKxT?e2iQ$lR@ymK>bh*|^(dhr;{)Li<0r_SR+P9^-%l>NTZZnwzT@^%T+mQI=g??Ac;wjyU zAIp<0<`%$Ou7hSD(-L1k>bZ97^45TewV{&ni0;9-B-aP9*JXwcqdyNSHF|}sHHY80 zG)@PnO_%O?)=TZ6K+HV_hLlgIDUgDBH;~}6kLN)B^vDS-t)J`#vi`s>!r7);H!4PN%K7a(&7lHm_}I6 zRZGm$pw=^CIb6RSPeiJ#PvKhWVCZHBT|N>H!+5m%268K&BSR}8XZ6yQAPGwF-23s_ znqLav^_=mFDu;&)#6&qcrV~So|6ONe6`0DhA-$r^y#c=v3(32{vQs&|E)S8f%>`|v zdcT;ksR7pCeWgNtXy0d?n%r|_r4?y(yta~ALLMD}_Ebx>TOZ>*;3W@nAcC~r1`Sd) zK_8=OlRAo9m*Dml`1A$1m(`^GKlygn{|DbLtRN~cBlMrXo$0^u?acq-+Zq3{bY_nK zKfaxTHM){O## zCDB-$(br(ni6d-So2DJFKi4k5y|&ekD^;wII_x!{?ay685*1Y=6c#snP)Sa8uEs{j z2K&Ha)MX6~0BUM$>HiJ{3d-ebZEOGEFhmMg{~5X!xEC*9j4&=>87+Z^RLh! zzp6}HzhvCLiQ&CpioJwyHd@7(-AX8gVC@Xlrqet$@UOFeiefjksfyC;X1mL><# z;P+i(zmX`kzKO}n>AO@e{w26GD{B)2czFi#3s*F26r)d2tzWUjs4bVfpXprz_6?VprN z4z)Iqv_HUr1pd{{m~%UzNBbtWa86);0l-T}M}U$s{GYwi$G>cP0AGsO0My8ry-vSw zzeEi!zmw}jQ&asj^Fuq68#_pP`qt1O6cQ86?H(OW0Mb{}zL*(n9e@13WVU3gtYxGH zzRv4SqTs*0gZQl41tgczf#nJv;nhdXlS;& zt^o3o0nW@#hQA_pwkHwaQWKt2F_QdqV+#X``+$-_=4Lm5AU*`{>>2IBfwZ!>{d{sp^b ztbbH}(?xbC%ql46f3xpzWb78!&JK(lfPENz|8@cR zwtxL*e(KWv+7|x$!jqhvSbnBvoX~&&#%>JFY^+@31J6-(wg;>T_5(KIy!@^zLBG9H zQ3Fg@Z(se?s*EgyG~pGzq_q5|%x{P+Y#^J}SY2C~Jio$x*FqC`Xj*#aH3UXJ*G_`< zL0GK)&ikXyOo2J&xA}QIr$Rw&l>UY!)v-G={5HE;WoZE*o0|S>O)Y;Z5Qe-r2(=;a zn0KmM2&-q(;A#ij4#0o@4oHKOh3Mm)6p73t(<|&tOb5`oW;+C{hxQxo1~6s&E3!oc zU^2cNhT2E-j9m|yR_sgc0?;^RI|Qhg@*T}Tf9yjn@ASS4fug<74kV)b73~H%CHYH) zH>aND`>(S6AC>F>sQmt$%=&LKclEy^fm7Wf=!NvJNHqaYWahcJua!Vq(+_O_3jGT! z0~277Zc`d9-^umg3}lV2iPg!J@4S~H>_^8LLx()z~FLx{Y;`fR_z0fIlg zaArtp{=eaU6F?Oa!?qAit#7~%UjZw<_w;7p`o14Vvy88i3cobpYc(VY5Jzd)xR3N^L!YGpouSrP)D@y~rX#{fB-iO(b*-wGLfC6Avv z=LsCh*}+xw+RLwfG1fVJsDGp;W|gBPg#wrL*!;UW%dKC(JV&=LMiqiv zzJPlFv+f_iyaTsiI58`M;s1I2R`!z$4zANhG0;~4W3cr7LjRZ*fpoKehj zOX-)H=22Dmsz~b~9w5EB^;e+09hX-4H@RU&=jq(GXxju;rk}~$NPh1paB#2Yu znbVP6lq>(Tlvu)c!p52P4hmWoU;j4%KS030Mzh=E-6z6D-l^JGzznjE)lpzmx6fmp z)5_5BH^$rWPc3&tjl)~rep*Gs{lbKn9;|c{R(es(OMK}>pP)-!MK5>(C{(OL)kzX9@B|tg+^;UXPye__Rna>(f#_ML9vjqKHeMi{mq-QGBHE!0|(9f zvkH$$v7rwe>fE6@?>kfjv$|ZAQl&(rAqsD|e)Phdk{_#!xs%#8#-VDd3qEX(b`?H( zFqF!?rKB!cQ0SLC5Qy+yFqnT^(2G|cD1!6;x-pRLYrE1N4H!}e+R6vYjNK(ja-;U4 zM$PjVd@%ww^}Aeh?{%==xv9}D((jX76h5{U`b8XlO#pt*m{dsH1S-a7)bG*(r&xO{9I0^#Ke7A7^)YM8Qz}QrexQsXEedbjx{7i( z`3vdXB!WB}*qa)?FKOskTLl5Mq%js@+QD#U`{>bdU|Rw|sIdmW#-*IAVk)ys@^nDeV9RrhfEd`_M_2Gtz=c+*<57M0Io#;CHF)RIpAn7ui zxnvkca?a9&Op-G>&f{DylESy@HON6lU~F&f6C&cIv44X=CNV2Zi7#C0t3d04-DzFp z{d~sikk#30cIaBgK_FaxeRXxZ@DQG{@FjQ35e}l!NH(4 zb~%(d+)4G)jc#RHa;r~ktDdmG?V3g7v#b%7T`0)jD`e@gl#j%@`*5w{CeP~M^#UNA zvz&&~$k_1&Zy}R2)u(jin3m;m4~J;G8Qw?@%lVi@itCC=eQ8G^Ch}UML5Y&14)0}C zVwu+bRLLcyOhIA$c<@l(#F+GEU9SuGXa+bs6n!^<4~Hi=GDpQmX_;(V%Hohn3^3i!$p_YN>_;7--BE>`O4clR=g(MmnWBuV@8Ynef)Mq|I9MW zwSr2xWb4Ct-_@f%jQWvBd(v(jMYg%3zIao5{@9|@&Fr{Hffk!5$v%%0sl54AIR#ELuv0Cpwj4B zSjOr*s@r~!nB9pa%p1OXRus7T6mz(eK`*Y`;I7400FfkeaVW05J*V1*2UQ8<(R6jy z7b)+%V%|es!9nW8ZJLqiHkl_Y#fQ3CpKT=!0Lo`pNO^a&A9mQ#*7b#5RD)y+KM(Et zL>jezgje9^SJ*9^QnD<3hNgQkPCJ6_%Sl>GVz#*M&9rT&RF+`N;Um@*rBxG?XWkVk z#W~@`EEWGEnzweFY0F>f^Suj^hP-878`@qHCXoy-8tgMzD36coyh9>-cc1zjnr$Pk zGYC`BmjF3m2L(hU%-QKrTIg#pgbD4)UfT-$uUvs;*)@jkw@2SdVg;Gr=U! zNs=4by@<(Ex6Du#6y_$R`gNaI^dRlZUt7G#V+8$?aG-<`|a{jlYyRhP=&ZgdSlv} zk?3y*F0WLwtB}=|U$5OmvhNXq!wiXzFN^pg&H+|Q4^2sKIOp-9F~;<^KKO9AK$Y9s zcq0*uH(c!a(rd~l?vvhl8l%`o)mfuh-*n4ZiRntW2Vya*;uPoyOdSKm`F&PON8p1h zRM>I$H8uI?bJ|8Dr%{kGDwUX&zN}j_wDIti%@T+F>ZJy24BbnX|;98P@q6oytwIX~w@^uBVpDdM>*nhi> zpPt)MKi|U>4?|~D3c+xNQ=)Qoc|QpogD}fzxj99u{&wT+AdrSw6v?&`bMl1Mc$vqI z>C%nJh}faQx_ zLTtUKrq^}-BKl+|nE|=CKkla@NB4_vRQgw&h){$eI)G2ZtS*!E32;uYeo4}Gqs z<|5>`#XMjWHi{85(Q?(`+0*=aU57JCwn35)G%$$sF^ZQ_h2Z?_8wKVsT#UYDJ7>8*demtuxZ>lE{=$4c0@pGv%@uX#IUN`+aN!=qZgbdnebE6jz) zUZpWAHSm!`$@(fEdk7@yN|&wGan57+4HW@5=07aaC~is;RR- z^_&aRp9XcV`!SDooPd69HS>f>1<|+jIuXhbR|sR0;2ILSKQCWm&Zgx;x_+Qa$54N* z7XsH+5g9|3Sy*?a%-eoV$>`E6rseLV>Uhew8ne$ts=+(Zp`KYX>1j~!J*U=o4wzX> zWwtl6{|G57pM!%4N0TCg@O3Zy`$QT-MZF@CkDO%v+R~Y!O}go7kNu%P&att4Rh|Ld zl1aWs4tR6F&r>9Z`{t?q+H%WoE=ST8>t~7pOlLdM*AthISUuk^FYI;KAn8(D1xs#+ zU9Qg@(y>fMd=k875#dP1#Yv)l-k8BLX$9yu{5&PzWqD(dxNhngX6d5**_?uLQvarE zY$lybUcj*v3Zn_t78A+0*+0FGXa9j|s4t~~-ePRP+pE|;gk;0$tC)A?a70%46`Qd8 zOdA{w#NlPz^;|@+Hn>S1DG%O{d^?1cr3hS0j|Ea#1h_ly9Z7f{5id0Z|MRdch}4RE zTL-b(gYqPJl9Wt$QkMJu#wf|;V5F6`hm#VCH50waV2e9tPmVz8uxxDKLs+e+I{qao z;#n*-9ZWKIu`AAn%ctGD4QYL{=`uZ-JJyu3)MGPF#XH_oM+#nJM8 zs$zyjs$wR#okyOvM%i;ZnS5V46^g2$)^<;puuh|3F+a3cpw<%v6hAV*%MV-cU&tZ# zTQyETIeJT_MHo0(x;?9+-An-^y;ih`I^rsmU(p61F!+OML5J{MWZoXT%sBmaC{DG^0GSeMs8cteeL>^@A`tIHU_Za@7UXIxFV32z-3Q<<`V;e0ytJe`FnN4alSAW_xyllU=RP;6mD#(*GD4Tkj=Kz=#hf^LN} zqNfrrZ&j+pxD)KJ=KSJi!U<4N){!dtF~LvF3l&Rf097*iMh6ThI!uH!FmYvVk_I2) zE+at*F|#+Map|oF36og%-9-+mF*{Z6Xahp$-i?)6IR4G;D0(*;T z)fd2cT8qhTN$+&y#(_rR+$|Y1FcCFrsuY1&=(fZYD4@GN7!PJprerXo{+4Dmsi^s-}y8>))zC}x6MN8bwvw#cMPQqU{*s4Wy+ zCShktw6!#z{hn^>8=G|c>SGNN183$a-;EBCN_U(_D@nh?4UK*vF}iPv=HHL_I(89| zuqoT*o`do=$Y7Zqfnou+6m^MO+)6lzGgTl|4fmO-_4s>r_qj+?1#TvMnn`(GAR|_) zXnWk%|#rHGgxC0`I7P6guRZ>yCq|GUt0)wqDtcyY8l(?=YaJZ(w(}e zoa<@jp5dQ9$+<8RRi94<#~e-e4H1Lpt&WszAdNE{Ptvy>?;emUc-*{}DV#4-RxUrf zAz1jCIrY+Wc6<4gKCc-3$b2BU>-veJ!B7F-;hIgmYt1Kpk=>yb*0)4cX#`XXIv|qN z?09jSfWZ+eciUg@W0c~H+&J&^4*3$6F0HFi8K-gVKHmjKj6C7JWr(}}T`bm%GEh-{ zv#Ehy5VunMXkEC?4of!i4u^4?J@l5ydTUNvWH~;_Vm##8rb(6QDE<1`ojP#9jtPT$ zRBfy0ZR^N_t=AI?E_V`6E|SjmtaxojzuiH-VMCRa8>f*}I_zEj0&C$Tsw;EM4C2dr z?8xRB!aB$M8rBN?NTbKMLVk`g^t%?Nmb_LJL=VON;07Y63irnIhEvT_ayR^(Wia_3 z14pe;+cM5hr=rE|7NWsxI_TDJ<$*mb+r1afI=mCAIP)%*Ec5qD7}c)#7m)EMuH_h{9LrEh;O z*X0{K-Rm3A@6TZEyr{PgSO9hr41gQE-HAZp`$CofB*C6tj@++H`)0VvMR3CW#cT4> z*yJn+qi_&8O0Q}x3e9+`V?^RhUXKTUH}p>vVgjTb?_KK)d6UpL7=G`DtM`UP9`mAh z{Q3htQFl+Z8lYiQckClvK73}er$g~Usj?N;E%CmL{y2;gE!4Efb4=pMC_hOxnD+>I zDrYPNFs>`6>@iNsJz41-aw!#VasS@>%~1d8JzXO9?6b=7MzNx)MHu~3TgPhX7Y8!< z*o7hu_%`p!OUpycQIqWt@osgJ*^{XPy_nh$UMo$d2nuphTRiR@<4~L8J{(dFa42j3lbA2xP^Ywe#^g1m9~%n0?|@jA<9j5;PWQ3~21)8Phb*F-NF zo$QhtH%ix{4sjJ6;Xd@~yCq~Is;LFheOV;>vfaqe=2ke2MGV2~6vdn!3NH7rYWV6p z=g5do$LvxgN;+){JibG50HFgt|=uy%Rs+}!dLpv6#aOKvdL980hU>4I7jLAB!kFVb2X?3&(ol~8KzB$cJnl=yWSwsHuD~m z)1d=RZ!c#;k{^vhk*b&))4C)|zeZ7|TjoM~X7p-;q)S+x?^tAB^7PG~;wvJons)aJ zON~G|ZL8I~)+|g=JBLNH!ls-bkyzBAHi_Qk8aoih8f1`BI?${7WjW52@)Y^&l0}-K8 zBB&a(Xk0Rg`Xs5Ld&@UMPkcj~Mvo9fLO%+5>10^^aHi|^$$aLq;ZE5#7QMfn54mki zW>`RuEaZn>E3Xv~(@Mlg@}LGkX%u8Uc+gg!Sz<okB^ zkkRJifXvt|l87J&Da9SPMONXfG7$l>Tl%mA(7o_>@eK?1%j=W>QKyC(RlpZ$QToHK zt*A$o{WNa&ObwB(PY^F*RcYl9YOcn|XCQojN>>T3(_3B@(CF6YBZLZG zToN{;zoA^Ofj?GkT^3X08=HjE&W2)JKL90Yq_s}(6+K|Xj-Dx4+pbE^OcSQ z5aR(;ez#AH9Tk(b6=sN~Na|eCtK(fDP!LY_#`zP!sJV6|Dlb9p&iJO3_j&>X1I1zU7BEwG&e#5~pnQ6Vl4u-EXRh zk9D@Sh8Vv}4q-?rB+MD44T`mGdO3X6i{j2-Sppuv@+Zv-Z~ihSsjo!K)yKO zV_xX!F&Rn(X8mA&Na6s;>zp*I;bZUp-H%Jn;8IZ8XzLg!=zYC9piM>HQKdjpRj(-O zR>>j%Sxbqll*#E7I@eNjXF$~Sv*h?UFYjr^3Z%OkU4t<2E7YV=K7-N<@P zm^lFCBP5$KX)$usX%++$f2n&!3H}eI#Dl3&il3$=+pxQ?w#^;x?ydUY&U=B2H%has z*l+G2j0A2ojG$QQ;fPZq!#DJ2fmvtyzPwxl59(akLf(^eFh-MCMs5&SMQ)bPip3h8 zWXQHA1&QwyrNmGWO20eJJv*uYF*13BI=$EnlR^-!z9sUmDWB2URwYK6N2`+vMs&bE zrtvd`ZY|wNdwYE$+o$Ri%*tHrVBz4L|a3u6Y~4g*9dHnY45Ap zqncf|KYOSLwsZKj>>b~S<>Bj0PG_SZLLJ@C7e%*Q=W)@^=2(h%YQDbXVKw=I+9Opl zq*tAQyQYG!0SM84nA_B%Ch)K27Uo`-Q)&fd13W@TtGFU}+{|5U3q90u7U+Y-lG}!* z$K6bS%x1LaU*H(8m*|EPw%NogkL<+y{a0fFLfNDCKzqT@Dm%c zKQ)7IB;f^YFK+`Zr5pH>?9@0@$tWMBjYh<6bwcXMrc1`jyi^nG!^KMGGVKc@p6QaY zir@7j%_Zy##n6@?nK*uz_r>-?9_c^f5?XiDC!?sM(GqK0xwsH5qw-xaDMD13qUUK~ z%4MEva<;iPFW;g))-Cg;do&V$wb0|&+D4AO#LV-FFr?E3vt{Q~^V;z6fm-R@d5yl- zjx^ajd1U?W*w&P%T0>T+lc0o8N`JvdJz}eWemel zvfRHg^C#gv30uDOfoq9Nw?IZ85}Z@k!R>GeH0(9=yT}t33Y)6Qk%D(6LqkoGM#!;H zSk;_zfKA>CzK70$t)VFoOhl4w%_)Sr?M%_E` z3QRp~IHq*uKHn!k6qMruuC_iNd0Q`Uyu0;U(icwfJEqt~H^BM2?Jqc}8rjU>!1*%s zbL~YxYkI87bRatu&YITL^v%uHi_)4rA#zmn5~1Q+0A8?KR_na}PN8#)nhno|dXe1g zh0qwxv#FWV+-ETxMorND(!pT;#uV(pCM-{d#(jE(n0C*UajNl|>b_0c&U@y7vtIOi zQJws)of#DD^XW5GwQQ|qrt(^m3Ntrut`6el#Qet`zs@b>6Y~NhTIuW=-SKj92_Md7 z*U#SRf$)CY4J0PGQ7~&i4(&EA*J^^Q2vuJLiHjOg8?%BiSLZwJ%i;)BJ1~^0u6mp1 zBpD4=?L7p5!a_gUkJr3BTxXwcx@A_02&`WYI>rsF`rOMP@gE3=b$*tyPUs~*1x|57 zO#Z|t^2`#-V8cb!s%q^edfR0)qCLlbJH>mnb+VCvAJmvcZ}3K82)Fw1ryoTuXTst- ztz4gCYC#~MMjv>6LaVwdzj6>UE9^S8CP#wtb*H1ETelJoc^SbQ-c-}|YC@g-5ArVs z+#^KuwWMszTClu$HHRV$!}al#>?{-Pl6<~A8psmO!R{DYI!`JH_H)7R>F-7R!TE@3 zz)sLrer(mvqJ^9-(-pAN4Zl;H%dE)?eILi>oIAAiD#fUXo)6s5^Y9L+~ z&IH{NT0g55Lw9Wkk@f*-E{W8kV7P8e(RU58ePm1ti+s^F3|ky-L)yH65KS1p01hiuzQG|;Ax&%Fh>k(OC6=FX=Q;a$DOawl4B)?Y~ezq88A{wY*&pKKag;2a7 zG~o8tg~wl_Gb{0#v6g4W6$sX6Y@9)D-1TTEGb1=OsjeG))fui|ZVYadG5DL{JKzSO+$EEF(L+`^OH-(6uaAz#(Bog~HuUtEF!{i!Z=zY0DqVCzZuZr_Fps>NK~(r3%9)w5evtsPu@e@TAO&PP@aIE3Pj9 z#wj1T)p=*XFJv3IvtVi(=5R=FJMmg--*gV^Q!h!rhR~NJEuxNx8M5b}BB&3HAITma zo{k)Q6fEIz<(_jd_I0c+LME1QbBZ}!)#6(VEGU5w>kQ!3}dV z?7fFpFzH4oz2`(WI%OzEv)iiMTIq)XhYRhsizA(WODaUK+m)=5%f#9k<1cy0VsyO(GBb}%(`e>JIo4L9!79HJ>&o`1jpT(}n?cvgZ z739q&{Ga)<9j7Hu1A_yfyv2Ufj;+73vvKjcN>O!5N^YLYr08Z{hEJS}bLSX15Bnsx z+|88^AW$e8%MPZlc2u7fRx}9VHu#qLhz3|{8!)}7=T*3}>JTIBXFc4m9i?y?@|q+> zZ@_Kj0KB!17|TgkYN{mh3lV0-i#7~LQZ&T9CSFi?86b{%r& zv9t|Z8tf0Om<=2AJkUodnBkY6K^EMS!AYChheh?!sq5tC$Lld2I?Yb$jL$WzGBPEr zxype9A8mmuUUqG7C9Gy+`8Xz-bYS8)UH8u1FO@%WZjfBd&l~yY=Nk_Dlx}J`jW!qO z$*$tyR8OC9yUJ3v$$11JHT(SpS)NjK7Vs18d2xkT(v4#xcC?|>vILzWUE7z1%`Eki zE5`Rsk&1jzqFH_nm5qrM!OA#Wc#a|8WQoamw=q8&Ay0D8&;#4kewbAZY~=R(Y!>-2 zHlD|>#(=SU1Aq93(wU_R`XA-J(;V0!$LedFo=AS=5~3L_!&x40F7~sm)?ftdn?{%E z^Bg)M!9U3 zrKIfJb-XO1-DOv{Ymdmdd zPHhLZf1tdLA-yz2EGI2Tt9pGe5qxYo215@r2CG;9O$^(3B`_iSJfUzW`pDoesgmFz zuTG`DAx98UOm6%11=`k&Em%vtKm=?Msf=!}oYZCg&D#s!beQ_)6s_w$<%mSG(10)< zW0Mg>q6+D$Nj9r}_!Mpn(d(hhq-z#lVeo6P_v*rlE~3fGn1|Klo3AzG^}810_%!(C z2SApQ_W&5z{0UzadZuNYK&rT!j~|mIch1icyK`CnxjfNUw^qBu6Zp>)%^n&lF3dmD zlrZHvbM8@TK^BhzP%B}H9pc})yL+#89k1eSJ69%@lub+31wHcY4zl>cz}%LxNmD7F zTViQ7Ky!NCxfG6-|_wZLAaK)xLws&0G0pw%?^`} zf3INm0Ecm!U3bjlmsD?Gzo^-L&qG_ju$G#XsR`yOZ^^}q(Ia#(FNnFw5?;;Gycin{ zIRWt?ML;5dWmmYwTLN9V*C>%kYm2u$=o*TiHZx~uh^K@Z-1hcJx5H6!$hmGuqHLJe z(~p45K~*HzG%i=IO@{E&5zESK3*~bZdqIZbb~j~m0{Hc}*UyHiMrxsit5p8+B2o;7 z^c&5PF-ffZnYcFb6XvBK&(ovRgO7PD0t=+8w)t*u-{->ygw?j=rzt(4seP+nBv)3Z zg0L;G$sV@a*=EpI|FL%bPO+kct}9eSWG|mK9$fDLPENp8$l8$eT$rWC4p#Kzy2Jbl zMyQV^^}N3%0<1HKv&sl2O8Kyh8vQ+31@6W>iTUIl)oZVBtW^W%-$Y4lVppl?*0=hky&@?u)n__~J3hBNaM@k_y;-IbVJ zzFUVddyj6E?|dRXxLp&|_t|}jn{Jw$9B*<%bPMjvHJ#FN?tOFduDj}q1PK}k;>j%P z%PZgewnIA=8TKzB{Uf1Ouy!ny!L__eM2p6YfoedHDSU*6K`!?4@lK*i?%{0MO0?Wv zVcHXO zB3^VIPqKO-NI;!mg0-(*gdW*m4e>c73D2PQdFbSjc!AeWW+$~;zC2PG;zL3ct7>_P6(TzU^{v5#2|NI>DOn#b{Mk1zo0Q_s*Ciy1gXzSfhWulxM=w zc&As#=^YCBVy;E9j23o(JhNB5W-;@Xj_AQr=RhSs;jqZ*u+P1kPD|)6&PI{wOIAGv z>xWqUy0fCQEg&%Yu+H3j?-oZ0My09aUo#d@0N^lUL8~VfukGxY?}vXTUMnpBpnS5- z^jQQ^SjQ#!TZe0d`7>jS*;>;*6rrXh)k5R4#x2qSkus$e$_57$&ia6kbk|Yvsa(hw z7*?9x_MKB)1zNLW>bT8aT&*LQ;3UO+_%{Zk6ZF?%Vm`NM0YZQ>{i>EZ4s(-V!Gt@1tYt z8vTH(r_afxmU|&^YSD0snKKb6(cs#U> z=hsvMEPa?x@hWeuD-;v9*ZN91 zVc!QMQWjlKlHE{S|RsxGeKYw~~h~q)P;<6q^dO&&c}>DJ4B8A_Kb{ zU*1`Aw!U)Tp47Ar7{Y?6m-!D^T_~`b)CC?Ndx*g=e!6y#~}tVmf(iJ9^Ab~!*Kqs1KF>_S2!h+9&C#ks?kn}})aN^#Xd zX^OnF+If|ctQbZ@2zba$vAZRY6|Hjv3=@_)7sFVPG?iDPZJq>uge0fk@_4h zN&#)bNU1HTJvbAKHN(gyFpnMQ3dPi{qoDBF>tzp_#i*`*5ielnAYHkwHecg0B-ckt zWPjsh*azOWr7M{1Z$!NdZdeN$x~_BnlBlklia(4B&YLZ@u^6m^4e&$|Tud?V{f$n{ zF1w>`4!KL5ks7R78f9gE;Mcw3Z1D~WDrElD$a2ylN1d285FzOULq2IUc`9(6kUduI zobEfsU-8x}_~xxIlsouOGUygsV;mZ-ag8K``$I)3dh7)93o>&J{UNduu0+~b;*BJD z#d9mt7+PzY9jVlq(eJPc8Q4pL0$MTQqpk0fMIyiQj(ujF?qh(8M)1R0a51H(D$nno zZ)z{utm%UY+uyAJ(K(~Ytbn}VM%kR~onzoaKQAt~Er>|~mKi z-k=Qo%5)f^rMGdA1}nLDS19nRP-46Eia94aBX=Q-DSdO z-3t)SMEEl?=+3R10+z;oi;oLx*@&5*SNvq%zPI9w8lw;KD#lE$i9%28IMnK`MFJi$ zr5EkYOHIQUv|5d&Z$qTYMt7T3(XIJb-KwPdz)a#v14oS~r)iVj1w>y} zxMrgQ0N7iuM`r<8+FQq*9g5+T?p{WeyxA{Nmt z_XW$E(z^%aM*;EmuaNampFhbR@V!sX!Vbb4F|xuTtj;V|q0m7~nR6H%R*6Q+=*{42 z4V%wle_ZX8Ei>)EB!WkTR8Uk?aForPt8Cmxr5|28N;V7s=xz5I_q>Z%FiDJk91IC6 zl%-QsuXoapP1=gn9qi1Y`-{1T6oSbxp_qP>Q>QevHbjOo zSMU?gk$bO$V=FlH4_^G&G_;sj^I$w#!?ss>!Dqd$iT%=!e8RD+tlcM}F#nwV`sxpK zIFCW%FpNVioP_9T);oJ^-IlM!D}(bqW$g(lnA++jW5)M-?cQ?f_`Qp%qPN^!IBJVT z{8s^9@t85yF<-rz^6#dUYJ$g+A`{W_P~PK*nX&NeC#?<#wuQ^qUpYFj3if2cv`u-# zX#9LPi0478GRa)77Kh<8G1{VJ&rC9{mJm)_8F$&{Sw4OFJ$lp(+k!{P%c8b7T%W=B z>}^(%4lG{tn|H{$v!zH)d#EBmefQxBGKLcs>`c7n4X)nfvIur87YraapLS*RSt!)6 zChgBFp~F6s1(n!18y-klG;2>x7npXL!djgTrll7`g|N3g7{eekX+!Wyetn6WrppNg z%#S3apTqcZ*2*v%&kVbMo4Vu2sdZZ2Ik+vYN2Q!84O0F|9qdjt=Z& zy2GET-(yeQ>6r zEmgIju=))=spJ;93xk?*N5zic_DD4apBmgpMRzAZIVm>P_Cdp=I)b8Yk z%FpNDG&M+77a~+kUCc#qV03lx3Y}V!U^b{~5IZgo$}YMQ^YhyKc>y;DKeJ~KF~$uK z`nz|{52o-*O?R}Yf;83vlhC>{pp=rih6~_M?wQ$mEwNYSaioGG@G;RSK$Fm z>{s9_eQFZ@UM`jE-VPKfX6^T!drUvsWfT!sC8NBWcXp(l)XOGdlJdvoP1DYM&-`*3 zfKP2`t8u`U`L^?on{l@*&GhK4`{C8adfi;UnD1+G#|l^OoF#@gL~E7prSM2XpT9*7 z(ylcg62Z9F$BaExHZOz(tj;tQWp?@P6%59xXNU|K4O7&YP0b8DjqWWXLvn_fy3dC2 zr5iq7{G$D2CehaF*%slD0{VWV+*i24yjk()E#T8ZCZ;N8e7wWtdN}dtC;SY?RY`~t zSdTTnsf_Qm<2cM}nKtEt8>7<1F0M6~MioU|W2GA(3gdmB2Oe!oCWMw+l#wUiiuBfW z(uYdlqY@4urQ_8S(4G};nKO~P?Hw@*-t^_WC-O%=DNj}UPOY-KL+$n0d@ALYO5&;P z?sRpZ5(UukAd3PsOfznJg_&o+MZ$)n^nJSNNF zU_Aw3aPJKIjW^U+}oJX6&4!5qa?zS=tpO=th|U9Y~f zie@w&`fIqDE_=MbQ>r@hdaas?#0o@j18tjSjBsN4_q~cJCYSpUHU_@@UzvE?kGbHKIGwT*y+P?b0(6WhiP%#k)x%G;OK!;7Vx``v?pN7?_AkI}$H7Z3#E2~f%mRVx# z@)Y|+hEsO-lnYPpfD7%4h+BkYrHQUN42BttDY|z{`=u}Lo46uYWoK55f4*C{GOS*F zmGj(?N6uR?hEB^pA4ha{mf8qu0qJseEMeN*44L^l1%VhMra@-?3ub=)+72`f#7gfC z5iQnoV0cJ%77FrvlJC<$u=PD(G31szOS~uPY;eWg2K$xtzweqophh3+2sX4stOWP9 zHp8<+^p46va*PHD!dx-sZl0kWF~-|ZtXzZlvm)?xC>}a>JFu(GxABB_UBeT5WA(D` zxD%dzRdXd(pXw>AUS@#hv+S4}tUg7pZnhTskL8P3H-S&8;?AMxhc zZn5=qA)665lmR{KjBr~H;V=WsyFoGm5+xMo+XdZjq_32vIAhXHLp`rqe#Fxm5DyH! zR=G?eDMI#oIi&FQ$b>!m-f*f=uZ>G?>NJAxJ%FKY$ z97z-nby3zsv1o6|Sbx>SG|cA$4D)s6E^oI9i%-DJamhv{PGZz(XQm+|tTBA*cp>uQ z3@yIu5@L?iPZlmAclH$-<80JW^6Ykrs043N(q>Y>e&KBvz2Z&&y10IV(VbadYC|sQ zY6+feJXti`jMf&*aC8&)eRCRy#d;0y9W+U6(c$)wlx}cH8jXg@+1WruwUjG-l%lS} z>Bm{ol)%oIgg`~&tj3uL3WG7*d!Go{UGZc7W4OE;ytEanj!x&6bNw9~r6l<%U&R;v z0G@)(4>=)&u*3Q6+xZ$=o{%O^qd=ikj0}w|L=<7kM>Cl{M=P!pLn||^&DaOtQ?ji;1arY^UC^|aU z4kX!EeZ;I^3A%_Bzd@3fX|J8So4ZvNsHvy`N8+8$2~?6;Dkg+C3i@B?j=(~j7VYDa zzIZ|f)5`FWXG(}O_0v@P3El4%PNm9?=hwE!-H&k!eA>qgN?unFf83g&PA=zu+`5P( z4m}c0D#VQ~PZ(chqLf@j*#}z?XzXUBb*<`BBU(FRVQyiO=G2y*;c`8~GV1b>gc(D& z%O2WQ6`ic5(a|TX?mjxf{^%obN^3Kt_)w!aI%jWc;f~U5O7`RJgI;gW>-y9B zzUv|%g@O2!7^T=^pv1R~c%fW2k*8QhZMR;&v-ppG#Iir~ovfE}uRG*RIYTZG}J@%Q;8A;?|tgkdFdi(i2SvJm%S;$zvejZ9n zV(Ck8xQ0KyA@kKfZ4h}bzg#2IP&^qDJnO{isxe_pmK_D3E45`jOoJ}`!u?Df?`?US zIPqMVZ%5eeLG`gv7L1BtuuJ7MXQ7+$2?FqZg=0hM_HnmTyOdBDLQl)lqcIU)IKP_} zRaKW9nE`0hn|+ZHC^cBZ%9Z4_Uc}o#h4drGBLA|_E5p=a1&jc6#I2Vbt>QP zK7_#4=CtdESz@YKw%coB?vD7CsB44Y073=0(wm7F5;e!qAndkXdSvAKvt0Xl1P_|W@QX0I+yEv#Ir|yRg81JGgTnCR^ z1#Mqmf!m0La_mm;Fyr;)GW6(oY%?p(99Sh`7r1^c6*oHDxC9>|cd_&e#$@iDZeI7u zXRAKrfN5H?gT|`P+khsVN8%WO>`^@|@Qf6@Xi9fixNEF4*Oba^2Hi#wyl6Q}woOSU z)WcjI!ecYS>2P})6&E^?)S!wCDCwx$Gy(i_Sp5TaEvTVne(sP^+Lw@7q6DaXlsZzk zpQMQ#MP($OpQc^E!N^Fqvk(QC+abC{W)s7{kuGOUg{tTExddRcgf-}Ne@ zKKcIy<{260mSV-&41BW91e|iJiRJjk6e5U|YNp*rF}YU3xTCmJTP5O)jih{012%^M zEi_H>=#_b?ZJH!JG~+21%4^}jg7Hcayb+S1`Ddj#5V}ZQU;CE+dZr885I$or-b|Lq z(-$SGBx-c9ST!~8w6f!qd55V|Je}27Ch9U9l>=AP6vzmh!9VF;DrCxdvm3cIg+*RTd7*BpE;`5M z^Y8KuT3gl38kB{*>g8v@Vqv_4IWc$#&}T9w9ke{4YYV|lQeE@!G zY&AeGsdl*b-zaFR&TPq=TPD{$h-kGYjX+<v;L+c-wzrxHGS6|&tsoWcUVwQ6%p{GItCp+u<>=UMZ+z%l?PoLA220V zkhlJJz8t*v1P;&b%>CDeqm(M?_W^lz;N_iBV=4<-UFRmU#k!y z+2^yDPf`hYw1oO;)1JiqEaNO&$8R6aPus&Nv~~MGz-~7scWewx9}Z7$U&uOa84k>b zq5VE7TBW)TB8_cWONqo2#_YQTgPg57=Ze=N^7P?Rt2B8TXi8|0`UdgR6W2Rw9N;t= zdK(*1c`mmV0$X^6O}w3w}0_x<>rfKqBh*v}dqu9nI(YUxa(l z*t11`jK`&Q*^!<)9NaQH9f~$a@&x3kI0qq5AuYe|Rrks4s!IqgzIC}}avGY~Rtt4q zZ*IXekEF9$aj7ylX>s#Q)FRX;wFqWi*LFt&B?M5{c$Gue_CM9x9B%tkYG-2qXl2{# zK&`qedWcKqh#L6feg!58R-481r%_Sn2|LOjc3o^=wdXu?wCKOlS1OWz*Z7mVIaP|q za&8!WT1+$lJ@FwFOfWdpv{H1ZW>?S6Ys$dEc*NMvj`iyBGE6s6d7_t2pfy-p?rcZE z1h?pC_%mCMNKP(U7I>q!0^Pe_yACr1@J^Tc4N66461yxk3>V~tWyR*Nrb_2)IZC)e zBW)qKsHTP1Ldh0xO_&^E-Uf}+caP=bo5sA&(V-O;b$%0?C#Epr*0>I*!q%sEft>}V z1F0)kez48Rnj0K8F>L=xu%n*Juhg0=_RR7or%<2~*VK#G$($rh9MG`0&ZfA5#~m=7 z`_D$EFm`$^c=94Uq-cnq zkENRG^$?;3cl0A6VY~0J+rA0<0qYHGc0;G-o^20MO=O{^1L=6pT=dzpl^P_T*j7U$ zmA+|&um%ySlt!h`lbaLLd(UC617<&ha8E=>vUt4+H`!!ab7!Kh5b|aSJ_h~le&+8p zdoK9?N0_&zBbIpTw6pPMS|5s_$LoEsJK)nB(|b?=I(>0o&e%iaM`I0wRE9V=yvx?{ zY@@uahSVkaF(#}R6K|MKU9yVlc8N>?>`@+UIfI=z0dQU|3qL~qSy!iwodb|0(Y~kK zwlQt9+P1r=ZQHhuY1{U+?Vf4dwr$(n_uh9m?(V*beGwH|=Tzck<;kds%J}}@50&*v zp5aejTmW|iDGkE9F$gC*f2FD3KI6VAN&E9}Bc`SkYd^UL;Z$5Z5(=Tt@Y)4C`sIV< zn@w*)As$WOJYBGGAvE&7-(9~i7M#%QqVMV9F1;iI-{5iXy29_8IU-tL`HQK~%WwLM z3Yy_9L(uFkQ`$Hb+abo$&;Vg6!~Vr@7&ZvpKDB&f zX*J+a&HcPDa5ZZ?-1D>b&evDg;`0T1JWFYvbsk=aXF2;Uk{@nr+1#Za+dt6$pwGpt zJvLv1lg04C??Y?NNk}K@s2O`seME9O=BR1Rvv>+6grDB+YV(FmE3Ly!8SDh9qIx>H z$tkXZeb>;+gmoFtu2=zgz*RL<<0QG7TZvAL!mg@;yF9VQ-je;jQ_1R268#d88SFAt z4W;2}6Oy>vTrc;V7;Lv5RJt3gHq6(?)6PRe793~08JUis)(TnQx zB%5zYoS>VQpNbUSI`i2Yq({nzJoN*+&tpAIT-YI7$79oKbDTvHk$Xu;21q4%>$xUO zK_oKDjIGx=b$GqQQ$%}{YTQf;{y+`JQ1$$o8;N-Hl^-c1klGggF{zRU|4Q?^NG0tEt3Ry2VUuVaBF^|y{i&BZn6Bb>V;~RMl2@6piAi0( z3$D;5QRUOC%&$!fM)%R0cweky92-36wS+;YeU#$=zG4 zTqo|gaPs-}(B!94$LEHT)#)bBF7U>};aM_7p7aozmMYVnp+C2$=~iTL48uqjF&ew- zFQ$MW#Lwhj*X~=VO3B@8sy^suZt5c;}1AH3FY8<14h<;Tv-Y! ziw2Y*B@#JlXFH3W?1}hWJAx!|%r$0-6qxB3>nj6l_l5%PSlHQh**AKB(Pk>)ZGC7f# zNV)|}rE6`a7?+4Fo+1Cmcf(v%@}O^bhjI)g9Q2daIbxBuM_qY7R_OiKd9F##!W4Bm zZrAi}d6bKAzY4I>!Lh(9)>If5&FSz*a8PbksvqTDL$D=E_jns_~RD^Mg)n``?x8JItlAOto!9uAbOBe zRibo2*%1-*)C+b_SPl5ep~a}SRS%7`8_;`L(NOS%aL2D!id@a->bkZH3;aZ*ON>L2 zZdfL^k!hWfEM@y^+#VO{jMW<6$ZAP;9Qh}i(ZarhQ=`)Plg2uU5hhZ3mIV`jS&fM& z1knvf9WV;;)VtyEt)D(%3#wSSXm^($Tr}l8LAjy4EcK!4_-sB-a0d_tZq=-OnxNRz)hq z48^haVBfo7F9_7_>UV^PlF8ztcDq%cGM0GGKKq}VnIXgE1qh%M(Q>C9%|WWzP53bT z+e`Z=uNT)=QXIW-H;;OU8#XM=qm;{>Zt2WpYI-mg`2<<1oPfse87>6j13uB~88t!_ z+C>|`GZ0bp5V7jAmNO3;$)^Ifvm7ilcQkF>1w4w4cgUq=03pL9ubM8=MC}(AqVm__ zm5oskn^6@gK$c|~c+jxZ6wR&lN7m&{T~XK+mPpc}_D(|q*{UO~2q*mT#$f4FAUhZ+ zNyXtgYRm&if2$k;d$-t>^GrtyYPAOlE~GC+YSE^n@6Du=8|_rgeXp{m{#U1X6=L&% zTw9H4^Yu{~x~Iu5nN54=K+0Sp9k7Vx>k*-qMqD)XTf(d^-r`aR<(_faESJXq_gm~5 ze!}B`6(Yvyh+g|PP2V_{j=z}rrepQsy%)vAExm?3G`L}Z38!BfMeZ3B+3(DDASgD{ zlXaQzVIqMqfIn_6K9~NM_$I|S-3VB>LO{t(ra~k|1a^@A2D&PrsSovxaRQs+eQe68 z#p2#MdSp^Xipk$giABE8QLa6geSCUhHS0ID&;gLRjzo4D%xe0lzO}v@or^=U6K=40 z=YQEwVI*IMdI#2)p1eo-;A)`w8viMW-(!))-S9tbXNy_EQBkTSl2|CCfOO#V=hA|5 zE);QimTgR$EI%7PLeE=sb{&{P&Nw-@j(ngg`{`d}1sur7t+K+-4FOl!=<)Gzwk{;h za#TrIF}uagXG0X87%<(g-8e&Ov(feO>L<0pBe^#hsakfX%}BEbGfvjWS%$l|^T%|k z?zuR#+_<1wd>_<&MGL|wHYw20G4WXnxM(EB z((t`Jyh##+DIQU!D)#`rAt{cEW|-;~mRviNfHxJza|3T@AWUPfpNkI6C6uyf9+liZ zDvJk-AVbn?n#N?k1Fd(5-OyAHK?cZre~d_kqTepoY>9FRdCP&iAceBdwsVT%!|nH$ zx%?Exb*Z`E6l<;w5+2I3H;8h5++|U(=dc?5$~5yr)$l%8HiCn=dHVn_ zKq4+*)N=-;1KB1HUhCUKi`hG}*#2kwL}_BiypRIBc&?j!qzNWc z_Sb26FxFltfiPL?8BW!mz zsB2_4q4sE$95_cUID;=rCley^!E$irbW6YAG&ut~5lrk_zaut(bHOA5U z4UgV`H3c-{dg~9v`v~Z(wkST(z^Ee9_n`e8fb*YSz4b=WWL)GDdiSO(Cni z!Zz#J%Y7vKxQ|=de9TK|4F5KF;*cZ!d4*UJ5^VzT3u2Pd?S{aZ1~^YtOylM4^PJ44 z5@J0<otYAwPckK zIP7F5!p&zhxU}@2kWa}si0amBLB_*eDjwk=zs`E0o*ni9>kHwXYrC-RU2TmG_u>KW zMoElecYgPofzF{a!A%3aHh2~MyT{5ntW?$0jzqjBw(bc;%$ z(6nk5mu-MO{6k%p)_cMtzU}nV74qct6_};u{TqfAka-(Ltv}u4Zm(HWC2RxM`khe7 z$n*yWSGW>y<_M!PgP4}ODS6w;B(2?Smf`Ggn%K74qnkH>Sg0*(ep(J*2L8{7FtZ-V zIpUfs-J|ZnLh7cvk^mqlpRVm!S8lP*>QIxxhgzs4lVv1PNX zeQ^tQ4EMl$X|hI$kNxWC!uG&|HPw-D{ujtiRnM(DW^{g2r^46ll!)phXY#wQet5O_a}%u@chUUQ|kC{#o2X*&#(F4)Jc$ z=5DR^C=?beUk5sqPZsp7<&;3YAIe1-wo{Q*F&jOO{d^2v#MYoJpje6fkG<2E&_&i_ zVi+@8;!*?;mMY3jc<7?z*eFpp%~u+;Le_nWYt@KG;_#G$p^4%){D`Bn(PCaBe$49QuUKG~m>rCmiKAvUru#KZ{+hUG!`I;~FouB%ubp~Hw~ZNO!e zf3wo`Yg1N1-GQZHNjF*oy|_7ove53rzT}OvBcL7cm{-m%5|9~x$$J=)i4g;{ zI!l}S@wb%Q_c>+s~Xl$(M9DV$?j?fzjL zC8sZqPvHT(o?)__&m}P~#-a;rneNZTI+y8c`S1Q~H9I{kA+1BHy;k+qy0`wkpklnV z)1}@3&-<=L?QKk0CiBE!-?D;>B2$lJAx4SQ3UluD*8^1lpF(uFl^E!3o^|!7&WteO z@8-MF4THIY)@YX=F$2#64LF|C<%?G% z3`{>UXA1kY#PB|K2q)3OZ~Y<#rARgWhOJJRJ?qSqI}RdIr`4w%4LcKvcEmRp7IhVo z=xkwCXt@qyTG%2wz{VB`jtFS#XMPUG#O47i{e}6Om4W4)X)Pd@8zO;&fM>ACD zGqaP5Wd9Vh{VFd?U0q2Jlj*ys5TaUkdk~z2@E>z>8U>z|ND zT(ZfSO-d0N`=1IoajMujbnQ^iHvp;R!8{BSnlHIo%0?SXVJGgOrRIQ?WUsuDb$DF%1naw_>{mdT?Ql_xUgr;Jx7`hH_LD9u z*cwhjwdp0d;*pIjtxOo1Azn9kKF-T9BholGjf=sI^*fg;S_Kn2Z&Ci06~y z24#^#Dq<)(p21UF6vw0BE78W0#wr1%<-D~24#?E)1mR~o8fr&|Jmg&zV^nvhkQvx< zn$<*vc}lQM$!?AlJh`jcoIXmVBd9VYWK3_9U6i2Vdaw`o+lXUon3b&;BkfFBZb8kg zhpAIHV26nHYB`ocPBre*{Inp<9L&ZH?VB!Hl?H|8@TB}10v?{uQk@y6Y^~}n9bG^% zIL9J)B=$QyS{Wee4ql}kWOJnpM&IdJaNow@Yu?f%TcxA56AVNX4Y{^=iPcNyA+0o( zf{pUF$lZ(c9A;cmOO!{Br-4$C)6^QC6kPKd%6&O!{aqD7w|X?F+SbHMa}b95%$lVN zUV>Dsod7sYyPs$tBb)rRf4^;LGkNa~BeXbA*4rti~RT(X8C%HCN<+#i(aW3PaZrn=LJ z^^ke8Tr}l?s@Ys(LC{EXj@>e;oazS`MgY}oInf}{C2!)|(}lFjX$pK)6c4xI2d%Om zAiI5GlL$tt%r8=s`D}3E@FH~`5Vz#|VDNq?K}~wjetR6@jF;)QT}sZkqh0q{62srk zT?->E@Lgk;jtlTv!4DAqmRh-2YK|Nxda<~G!SN2P@g>g z%=RVzK#E>T^)TM~%bUp%dhwzsv`3_zE_kK>Dz>gAy7El|=hM0Uv?k)ejF;@{~-FYu(;o7y78MUr-J4gF$?S zIGH?L07kYSE~;V+OJxlxw*}cxnF5Ibovgkc6>*CK0`DOcBiQ+}d}j55Fw1ng`Pufr z^RKi2hap_q!`_4tAZBOlEMnqhe0EPfV zM*|}(6K87^Q|EuT9WBhvodHGwBRgw5+wY}~jRC+IU;;4t=jWyX(|^1yzSZsjWpB3z znA*8G0?YvB0CNv}a}!&D1;7&UZ-u+9g{=v|4q*4av1{xy=liKB&` zF~9-f;9}=&Vr*#r&kg?F`PVl8?ES0h2yg;8nb=tT>-3yVT)zi&vTz4D1DwqrO-umJ zZgv0{fGfZa;12Krcmh049POz7HECiN-&c~A;~x%qMHoIlLK9nKJ3~ttRt}E;nDc*I z;ThSO|F;I7iI9Vp>3a(PweCNq@SOiR-2YGtAKeJ9jJu3MAEmUuA>`mjhcKYI4nrsF zPY4a)v$0XtiW%`oNjnma>QdGrRA{V_*~#p1^GolnBe^Nz{KJNGi*Jh$uJKg!$1DaC za~=;E+}`%iJ_h)3x%uriNNd{*M_Zf63^rDyAOrWdo~<*44&gj97;xk#jQ|D=O9=1F zzO;dy12qzZz{&_hcOT?7GTH$$%E2MTwWCwyI|UL5I{0upR}d`_brz5b6xMOrBq6MW zeNbR!rGcEy=N)FZ^(4qPGBUE^7YQDr4PtQMxJ(Zax>6eJ^k-RNTN$1JtRVtO@A_v2 zSVI~s+#%uUz`^cruZ88+Fm!;XWNj^|wg7{bKlwB=lnaC=kS{7kX~rt(m+@fuB+zs- z1n1|;QlNUTwsgKgcVZucF#;Gjp9x0*oxgmyl9PYRtd)NTDAK#x^%+0tGO*tSM0elF zom*R1y&on>z?TFYD|_fNcUs_vfIf{s*)Rf>e4^h3v{OhOsB{lT7pTm|4gvdO=@2BH->WbntHh5-}%DtS%BHGe7jaDI`GquHi=N_=z&TJPfb`(pM^NCgM8 zK6;dUCU_b%$$J!2lFhx48}u_`VnR~$hlC{H_YeAhCnTnYLqgexaQ|>i?t1wOeIw9y zQJU5>+xslZLs>=vL3&B-ojd;&?t1~Kd^^_}Y5l)0^I$v@n2@^PV{f+{VC^&ceQw_Q z&%R=lzW7(Zs&D<2KELoKHb*8e5z}4}-@iaJSA)*iKVjSz>ru}wXp{-%{s4b&$@6aK zW>$hU0&%W<0m{LceO3`HYLhp%jKDZYgR}!MP6^Z69&%A$r|5W+TR;N>PLaf?uUa6w zd-^6m_?PE8)7SVqC}QN?9w5QIHA}v1Ur?+O>Yh8?{(=MoDN)YP!)L!q>iz`*0Yc0v z0dE3o|ID`r!lb|g@sa}OnYjZ|7s@;CvQw7F>Lz__=& zvHVr{X=hOT{gQ)edD|yplk1NussvL3qv)PJm%{8@p4iuh-syZdAXPCWw;{*~ZirZ|x z85ZGcjYIa?BT5E@a#1Xn9(dd% z$0KkOWk@yG;^bJo#*YcflBT>7uxj}vR9j(d;!78(9_No~8!alVcKL5dVo`8=1>?p= z+F`*`$nh0)5jT&bjW?9<=_Nl$E2^cAgeFX5&Mj~9#96uXHGyT|;xDQRR+=uoO2is8|nk3?-JVx69S3_O);2d;Lo`axDiDokxS$YCunp4o*FNim*J4-&0z^cf3?n9a&JXb}SP~V^ zqxWCKwCixPA)8!u_L&tuBMyQ*b#KbAyk@^uMFL03;D25hEXy11*WJlIP+945G2)YP zvF_On9Rx0J3clddl$7U8kQg?wW{R?5NnKwU33*?h@TxXg zTV*jMWZpn(&r>4J%2hB^C(quvRh5^TU@n`@FC?^E3?!0PC!W~(4;`W*bM60 zfZqPfT@D^=%o|7zdP&ur5Vx3Z1hgeKx=QSg*IR-UX>fGzu z???P6TO=Mv8<~?dht0zDY@H<=l>x!Nr3nqS|CO1{sj}Fw9GP4q!=H**>Q8;l{#?x* zy~d0=aRT+LWsgEi=k)n(2=}bU9dA-m(;HSXlO9`-m1tgb%djL?(FRSDz-wWT2~SU` zXgzkF{NswHY<)F$e%#D28_&fOngdLeL-phG?C?rV^*aTaq-+A%#Y5h?y%MidVHX(u z32_?LyT{tlh>PDo-@a9fsyVRut%94$nnk~fnBw1z>Q0Mo(rdL=N>9f6GkE5`&HOg$ zbQ49rLzrgP%%WR#B%R7Jmk#ep=F-Xhim15}=NK2va+fFhC%Kqp%UY?dS;UDbB*ul# z!ZD}fDBsnh0qh~~W>r)M%fiT@hkKAzM80rk;v5B6@8dT~Hd(vZL;ealiItL8FiYJ*)}HB_N-K4hQ4{ZG2u{=ROQoSMz=XsuvQhD@ zvh7v#=_xl7_iWLX+40DuVM{`wLte;bDd8&HdoUTwE@w5drJT_@JM`2$(_l_Q@hUFF zhgGzUT05%qqnMIpLZA`a&@a*NR2i@lMO7fVVz9R3H}9@SQ~rec8+^7}O`p~Tr)bK>fMO5?J7=6Z zW`j7=p&6v#?am6@4F$I!4+Zdj1xUpfBeqz9Y*L%!Z>Y?IW*@twWlHvYLFdw7pdPuM zkLZbqCi_5b6QtT~#=kCi znmC^eV2_8z3%)A)%-N|#h?vhh@Tso%OW}kYV;a%`nQ6{ivW)!BaAd)(m-4@_=bEyS`0edV`)Y*#Y)iZe%@5^^utj<`Wpjc^`W6RA-1~ z`@D7X!`^nV0;y*oIF(H$YgJ1U%U+GB$SbPYov3$hZsl^pCmkkEK7KO(k_qQ&kQhku~s~fVtrLg{pO&TA2VbeORgHI}y+I&ZcEAJNruQ zExBAHmgXm7(eH(3Ni6i8NDec(f%ZDZJSM7@zKq}0B6P|pvWo9_sCse==V_MhhxgME zyz0}fAC+;5KF1sF+Pe)Qc`}decGDHpgnF`C9TKxD~pSa_CM+bL9nCWI08eS>8Msw2qSQ}YWLoqi3^V<&K31l zCv%-Q<6&;e>-mEee@jBurlDBxu(v3?P%T03Td^R2l+QH<5is^o>|-3{V^I0RGP>MR z44^%qA|U87sCUDS6GUkT9nhAaGtM1<#p9IxlFUbdXHltj=`0%-1e*W z(SAkr$I~GVLk{FDU&~>>tmsfhgM^gppq(%58ybts)$rSxQEGGN;mzNaGHSe`5~a=Z zfExabzt0O!iy{XCLcKC9FoeOlUZ_P;v6xR%!`n^kPIK=?KgaOMatx(LEO6Bk=i+K9 zF`bGOQ-o|EL8xKY?K||JflxGtA!+M?n%6VrrmebdepxMMMQ>r=OmpRqs>a9IJmD8l zHA)b?;pVvufG@{iCUW#qnBPY`-M{yvfO_K5VA#c2o z?s>Aux%0J}poA8zr8^Hk-;xP6=Nbob(o;Q-(-HkXHyjlxkCTTF9qH!bRWxafxT8LG zE5GW`X%dWz>4^W%{0y`+_o_PX#@HjWL)E@+2Kne755Tyap^CGBnvjWim^L5|#`IFM zZfgRACu+=a1ge0A4B+ZlAyX~ugX;LGf2ZpR$$E4P!d~YdAHmPu9Ay0hiz~r7y8MZZ z$xIiFF~op%hmQ6=FUANzfvT^z;v@mW-+Uztodw|NaT zityVq`~frBAwI`(VR7?%7{RizE&S4`{yfR;ba7fhg@6W&Z$EX9?ipSAk(A^Dv-nfr z>Y-#B>ac4hYIX5;uXVcMjLk|VZF?5L@{;rEZmQpeHQ|Z4BtNlVxnw!q_Vz%)gX2b) zyyfbqnNwyw%#Zv^x@-+G58BIxYbZSOHAa&Es-6FJwws?PlQ4ps)_KqgQZE>pwXg%x zYXF5hxM6dVrNh^*T!=_Vy}3Ip z*6vMHtXS&p=T*#LRlAT&6bi_)t8={4OSG;@MHZ8CLJII zDN!D&5Wj8wbdgaQ@b5|V&%1zBX`m(sNieC&w#1s9tkhi{n)-DLL$>DPs&b0VfGwKX zcsvSG_q#g7GQz=8Uv9&7sh0bHt=GD*krzjgS1?G5qtRJP4J$TRmScH*Fu*mt)9uao zpWhnP#v)(K2&SVS8NW8DqP0-$kg#q<|EZf33qwalEifjEe7;SlHsKTey0<-hVL3KmPuShUA)Fz1d*H%SLT=j( z$M#Nr+pGsu|I!*$vg*O8)qsHRgXb*d%|}Yx90>B`t-)5U+nAIp*T*K?>UAFKRY)K~ z+t~dQOTe+*)tK@EE(mT@DiEFB#Jq0l(&k5y63%kQnJRUe0qaf$E(Oz zNlntEVK%{qm0!L#6UwFEyT!0af|g8JNq;`QuQ<>}3*3yJ{Qi`P3hHooD7D>HG7iyhjD0GA+}ZzVB+l zT0FxGI5Zo$HUeiC8`96YTuzGy@6|Ym1v>J&FF90sV#>;&O{S z9g+%HsR(7xv6yt;U5Xfitn&D1WYPqyToC+&x&*mOg$5P8T-`1ioAYQ#W7d}Tgp9l9 zmL_NV6m(sDd_pL=!CsUZSBAI<#$H&g6LDIYabRdpmXupI(if}0^i}BPRQAXHmZZ&b zt0prn=bnuz+U`~a`-GBi#~Hc36EXYsB+w2uymEHhp1&J+il__2`kbNkyl`Y@ODfca z&?Mi)>~Yc_e?J6{4UOF_+ORNRgn7*T45m0Q&Hm#w=I|+O4j7F_bzGh#8?jB^6X*m< z(K`MEg0kXd()t5~e{ez8E1BV2Ju#6Lk1*fpCNYbrqbEKY^22z{@m3FW2a|e?#Ysi;S#4%xWcdUU2OGfHCB6wG z&Te8{jQK1{8w3n2W@~p3nPJw@mBOa*Se+F$%c}X?wzjaHBiTOeT+guJvvLjY$UX*J z1(BcO9rABBYv59!?@<=p&`Ja>o;!Emdube62uFP5t-cA_BTq&xTw}chO9ix)XK0&T zUAl37v_1$B#W9fR;>N-^!Clf=1K@<*Olj{QLb8_l?PcMsVMlKh43UV#Z8T>_-f#P1 zO1yOUXIpLbJQOM{ek_h@B8rtNhQ6Let%bLJ4S+vGqi^d^Vg%dDx6P}US=h5|Utvra zW}-QkPbf#zWchVvR^)LL?6X5VvxfPP(Rc$ns+y?<%Jqf9NCbPpXAHj@IsWH5~|SDyR>4DmcS$O%GYDEmdP@)8YlXMI9VFOh<@NT_jXhjd%be zE@LT)cVSq>8RxTZ?Nh77;4I>um8@nmcGeBF=6*AKFnI7mUJIYKM32=TB+I5Qn-;+_ zlxu8~%sJ;Gwe-WT$(gn_)yM0~>N~xO_I-@Q3D0L{qSQ=}mU2krUlS+xqU=qI?U}1}dOrSkiD;w`2a-Ts#Z0*at13c=Kd_ zHgd`Nh`{@1^x$bQ5`%6(uQNg$TfK#50a$spJiQ%o@>!&^y~WqyJa1GcjwDuBEDu>( z#{0r#VmtME&qEC9q&@M;0_oJgl|yy>nXfUk7avdQ*kQOnj1h=yKBa9^h0gtaY`i6J zQu@TL1eXxz#@l+?{wbZ!>iFKt*Rbpe=YQd}P;63&A?_PZMw)RyD6pERk%05+;QqNH#T^ypzwpb%MonBt9U0tZ zb9ANspnje^JQ74})=L7aiuzGheJAMa*ABIgXCZ*cs=q;$EYXLxmAZG)LW@fp^ce1A zt;kP)zdXifP|Dbg(GOO9N!cp0M>Y@|w9m8|1*yf_4<&keOsX>G6 zKxSt-m!;{`4}<5zfBuJv2*38)?=viS=} zL^4sD0k~XPL1ZlTv)hUJb`}-#vJuG->!?L!f%ao|y!52zVfH^nHal>Ky>g;opllMQ zkWPCGuWzy(?3!^z2sy+MnoA2<)yEVv`mis*S}z3|b;nod`h ziH|`8fcGQah|;wfT*1L=-vNQ(7EDJ(c9l(v1A-&$jnRaO+Exiia5 zhD_M|E2rF{3e!1wgus`h+Q@f%k8(Dt@^RGe^c1N;3Yv%&K2vHmM8WUJm5)b>(H3T1 z)^423cn$YkX(Yb9AJm0~*Dg9l31XCgW};S^2>YLe5r}eos?mPaqZaOJiP?g=A0crR zmeQjh3Wi8iTV;6_PD1m?)`F1Y(1d~;)rWcf8FgxM^r$2M^x;Ryb?dPir9gp2$&3Ow z+?ul~jf;7iWQ<*OnsA18@^BklwuqIU+T2u*0h`1J)5@PzRp{pd!0PCurAmgMk0rZE9;Mu5hOxErQnwo2ai&x{|bFDOpT-ZQ#d#Z!+a$`7DH=W{8D%z}};p;Z0$QVfYiOR%L6^c)%C?PfAs(dKyCZnu-E_c=-fr?|AH5$j0 z^6g7(5fNV}@l{*GmW`QTC=1U&&(fV354II4HL}mFp4@{#jG+Ewc`+nS(CbBQ?rSQF zphaXSqWhB!f}ybiP)wRzJEUz<$HJT$S~gra%I)JKep@(Q=(e|ng?90=`$_b^H!^z> zvnRgeJ28%OmQVorxx;C3xQL-hr=X}i5$i)<^KM1)uv~#~At?z$Pn~$(^cV3?g$9L# zvfe9JYbaa;Xbh5c2xP~S7xtWm$5`*x!`=|4zBf^RX=)tTY3yvIY8xM z>*!NGqh>2sVU#OVJ)&~(f2Q9#J=1WC0G`7yA!a8SoBW#M8t59%{w_xX$sfnkvfP9%|!iXwvH9RM;z54K~}>_#?lP7DHm z*5AdDjkk#}4tJKk)xANSx)mk>2YqbD_xCJ*OE;dT4a%Gx82m zBLY2mpLh0Tz(bmMx$b>}^(b_2zYhf>z;rlpA{1x_*KVhHC^$Pg5v1RB$Qxv^{;L%6 zQtFPu5mza8zZA2l&F^WQI$;~2v7h0^40CTauP&RZ+ia*?FVcz4VTPWzEhzQ^PoB&J zZGz!~Y2*ttM+kWUUCvbI6xvU&$5oYvSyb<7af*v4=7eTr{R3A;zg|LFfT7jhzoYfl zT}|j`(C%TRh!q(Ai)5aMh%EhW8pqZi+YR(U{m^a*(BygiRNekaBUuk{ARU`blPWNt z?mIfftF=q)6$*EwytBwjHu!AmNhK z{h)IDwHw{a4~5w8m8Ao2O=OY}VUmqn9D35_nqiX?AW<@4;%yhur+7vy35y25kFEZ4+d2Az_|&FA7+B0-ad%aWSjyyfyXGhx+cUlD!CUbY7o z8^1yUl3aCtHdeR1ER%;Nd2K&g!0oe&$L2i0dw4A2^Kx94(dPW#8k)DWwI_ZYgHwu) z=vPIWAgQJi^WR3I=&@U9_8eK}Lg_Kv*y;@2wMoM=U!4&QQJh%1BK^kQb4!?K@?Wjm z0m{G*3Wd((ES0@2;`l6(^6uK)dZ3(4UCk#~42KIfty8}}c@(CS@#8+Sr!gD;^f_M( zi~jQbu13m%b^i^=-we@R5PDs4VabU*MlRk04qMv0+6;RQZpz%hyvZgZP6})fml2_I z1=M_=fBy>25$QopBo1X|oN0d#w&lBCCt;+cKZNZvV21LBPr++8jRhav#df9Q_bB-J zqa8k!Zztlmoob09G)AHNMp5V&Eh#H1RE)4{>yUlk=Hhr^MBH@KIL*#fF0&<>yd8hZ z)pHuw_ftghfYexRmLF2u9wPn2!k&^0>&r@KP_cI4Iyfm6J7n{J@pRfyv^=|Q;@7t2 z?>~5+=u2(|(;TE_B3X5!>vTo#0whx`wQRz<(GkE|PkrLG1+`1C^8 z47yCrDhEIEDm1kOWqL+V>s59cGx~b@#D&ndP+7iysa!^<;Dtu3$JvoiuuZ1zjTzj?$4XtcU-iIwi z`1Ea!35}==naPR9xQiI5iA23uv;CWkntU>x>o(Pe!#ntR@qY6V4T_y?nlCOJ1snNx zi-*eINEYm*<_%Hod1y-X9rSUQjB~VOulYiM0{bv`B`&FY|GL;$Wi{UtTNPNQcTBcz z4@!ydyZzS+6MEFc>ix1HY~`11^l#eSzrUeM&=R@IE!GXdlf?_sX<7;9)?O6BAg9tE zzJSv1OqKsTx{vceNU#4N-KQz1t|+4MPr8rkzo+|{S^h!yF%oiq6J+eH3_36X!G8gK zZ2#c*gbnN^{t3+yvT^(m;XYOvfck&!!}5Q^eIfvq#-(3G2>g^wl+y6nmaWeeJwfNuE8|!~kZ|v->-{0f^rQSH$*%8A%nA9i}Ml?D4g^()kg8`1|=QdEFqahDj^=kMzr?*($|&N*`~{4hEopv zQ^V8UC2Le8&g!}1BGk`X9+1n?$$=g!xHyHmT@)aD$6I@QM@J(@rc(j!{B8aT^(aq$ zGfXHD`u7?jY%_-8hfQ)=$BtMf;cnnjTX`T%ME^*=w4VZLiKyKZBUJZlguNPAgs_gG z>Y(!+K%-C`%ixg;5Ie^QaCJ>i9d>t16#gp_;N4`Tq}`9)c!c1f+`^Rt_Wn4-3kYz3 zuFSy$K^l=&k!mZJ{G=EnSKHdTU_b-#@$r8Urolq?uBc{(z;6RPG=Z82=yXqB>RWXK zdVyS!;NBsb5opEyWAOS95dX0C4laQ1!$GX$<{{BAtRL|8!P~;SLaehxn$whl z_<>b?B6mYPJJ|tg|IqeJePe!8BZ7K&V;UZX0d@lG=^(V%@`ne5f#6A1JFtInHUahD zUhD!9l*jD%;Ty&S3kamW0`;x=0T!1!3+8_b{V6#$Fp9lGM67X37^{#U0n|iRl z$OMH22j}L}^V-Cx5yrfH>butA@0V2x`eO(9=>>IJV0)3ROG5n*Cy2`q5(Rs0!g(&y z6M3bdb+f)25CH{6i9Zqn&^Z{8m*xtvU-Ht8BiNU#;|J3g^Yw#+2nUGurKG-*Y`Uhu#GcOr`0_W z`%ll$Po|F4R8|m#hgXXCrxy^`Bv$w&<(!Y6XS>`+mR{8DzR5mN{iDM@FsPebU@-R( zpw6$VTlTN6)~{wue?q_N=)2rNDSKQnfn!9NC$A?=_$Pjqp7*2vTAe?p?y^% z1n1@9_yxRTbY(?*VU0Qdzy8#uLoFoL$ zPI`HKcYwWHFCph~&R?`vfCwRf?0Dvaw3Zyf)(UbMeQ+rN`vS>7q@J*&pa200`jJ$7 zp@Z~%1qK2U-s{Oj0R?}6ws8OpJa-WSfR5h*!;nDj@35OKE+3eGug)F;?s_YG?C*$b zH0)+aZ`|80I9KeufcLjv;2_=}Rdpw3D4KYrw~V;ONNOq=#K#HbI>|wq4`mG3T+So5 z7MdSX-|X6Wp2-n&SyAkUJM5X`cuB$?OAFuH)fq!?CMt_owcdK#kVUjzv%U{L$t5n` zdP@04v8TjHHOb4vK-C;K6Czgxm;=i#G=RqwjmOICXO}lj=F0rL=15JT zj}li8eg&=(iaN_cnprxlj8y35sBFlHl>K%%x6A*c?45!{3&J(avTfV8ZQE6+Y}>Yt zQ?_l}r)=A{HPziQeeaFwj_!HPhkVF~9Xlhx^{>y9O){R@Q@jx81!lsHJoO|dZVu{Y zV#4BP*b&z@O^ykSiCBp$SvgStK!$IAC+Qbn^NHLMJ79HyaX8tbGE2V}G4xR@F=5+) zdEGVQFPIM@>~v~D8a{-Cv%-G&#M_OE_1LA|p;8XR{8Hs#ROoM%uEH#ljF9*YpD_rD zHgjIS+c#XdQTOPg$i^_lynRJB`IEzt9_pXURxcMq>xGkI6iH(-=>@!shyWB zKNRvR`d97rnpDw|eWBy~ahcL?_k~$)hP5+d*<}0HlZrIXcyu)Au3)VpkQqFb$CG4d zYvE&bXNyYFX)}16U<8fW*-B>Vke{V)i^lGW{i1ag1i#^IQEoxw*+`4V0p@%)Px)4F zk6Bw!k;(#+P%^S1d3qD&(-=Dcaxqqt1HQ~F)d(6ZePz8+8iCiJ62!RvRavfPc|S4D zEmNA%0O8qF?Vn(o49B6hTP)f6bB_s(m}Q$cvS7fPntF@r^VO8sKZ{-|X`ZvkDYH5s zT8jr=+;2>BBiP4Ol-r!CI_@NFMbz-2Rm)}8fxM<;ZQl6G4>*bBxJ}QyrDtrH%n>-` z0TY&var#>dsmacvH1Oaw&sdZ-#Ru^+})DKc5FighYYg*g*W_ zWYOl-T`UU*$|m1S>UfZ?J~IQJf^?e}Ew_g%+Z#IL#BR5Z zvi^rpD=7d!k=SB$$?ESZ_ckR4QmTdI-6(0FuLpC)ba+jL5s^h8GnyfbVC1Lql@FW6 zkVbMlPc@N^t0<&{vOd+LdZJP@D~ZCsE&WdJNM;bISE5KpI$IRQi^5Glxz@q&X@^M} zsC?#xw}>);jIpVil`82ocM=AHvrxvOOtLFehF(MxL%8>P=gU0^+?12Te|yjMoFAUI zONU=K#X=iXX|oP?&>k&Lnn6iX`ChaUW3bo6a-xOD(Q6{}%@2{2jcQ6n;Qn+ZuB`#F z@x+o@HhBHzD0E~Qaf1_VD_*)3Bd)W-6s41ddOO))T^;3;m#xHpA>&92J3hGxX)=Yt zuTGzF6&;nOmT1nt+S?sL?Rr~HRJl|vvMXEYUPSN0t2>eMdNi~gvfaf5quzMEG9%Oh z=BDpq@}tHZVSjZ!>qL~buwb1`Ti4BK-3e<>Svih+7eJS#$`LjtToKcJ=>ZUUyCKq4$ zT%X8SIy0};JFvLXJv(#*e*sxsIa3%aTnyPfhI4kMg*JER(89H>GMP3g&%G!&eXM)> zPmH!WMOM5K?xx{+8rNCY+ysFwJFaX>9KpK>fV85@^Pnli z2MyfjO|3PiJff8PG1`Lj#G>=(8VBvuysVz@ zgRrb>PQblx)R%H0D%ETYSQGckTH0v}PeEj@!4l}WgV@}~fvA3#8fE2AhOMWa;$0#j z!Kg;1#ig|c!@g);{1dKTb__%%Asjgk6a%j<$xm`Ojv1dZpumI*o1Ohi`g9-99VQp~(L_OtqYroaGaSQ*8d92?EK0}G z(AL9wE>+CyQ4*tRUwGB&p?5=f3bJ36^vl`|&;-B{*p5>v`H}l(4rLYIHuIskN%iXW z8-E_9t){cwyMc%uaFTPEIqDT|ym-|~L$vV1f2_l(1u6heo)dCaa=jRk>fBUliy`C1 zEG@x;^XAVMP;gf9(G3WZTu%6-=4G^PE>V{CuoRjd07dE7d9c|WV6TnmoiY}m2VhlJ z&bWr9mCzp){O{xCfnhN$@w|^i4+P~xB5YXF)F2XzV->t6Osnrw6{9wjnK}^ll;>Ai zUhfDMb3(G$xo)ox2o%`l^47_p)U9t29BWRCEjF)9fONgHdU~+c6FGs zp^?kkDNoci#77Zxmx9&15^`m4hmzYl3P67l4Xacz;9Er5ZbepvSa*`S))2&?X4@f?&|CIfX zJGn zY8_DxiU7ekr|8N>&Uc4cL=e8LSdHZcn8Y(@`VdX8+}{1qe3%@1IdhovYo(d_B6|(W z4JhWZei(nYTue_%<7yQ6spiU*ZG?pO#@d-oRjPm;nL1_tJP@`L35mrs-pG(tN{j^) z*oklk=l2uT!nBTpD~1&-xh}%K$lP5k2<>@F?&~JZZfh>d)^`$Yx}wEEsu<36KUdquqc@ zI|`PgNUQ9d!#r47F|!W=-oi7G+K8no~H zD=ywvG#;RZEw6-2*=%(ZizQ5v;1#()$v&$S`{+$im9w>lwR4pog?whiSa@Mh%c0=Ip@YClY>+Ejxj- zE7iZzu2EWME)Qqy`SBiEH|FO5eq(qM;Ddrgs2LZJt7>X3t7=gGe@eC)=2b!+SQGBc z!OARHN??l*AWG8-?KTrqUeryNuNC=nA(!IM@~@+skR8q< z^}GJqwCl$m5!BP0!#ul5cX-KjcKd=^j}`cg1&tJJXdk94As%43pR?%uSaODKJLmJY zF(ZX#A;L3NMlr(k-;O;BM($QtH z`sd))y712X;s_3S6y#{~#L^Kf{`iV+-6#??;;1@zH+Pkp=W1=9zbv3vuL5z|2C=2S z4=XOKU5L7M2Plem>J_-+S+O{fz{zE+(@~8bJ|hT2BZ0E)GzxMqJr3B_5wV7rN#5T5 zHM_7=t_|0DHb)PD$E$V$v#P-J6Kc#!@qr&prC^^E&<=n343sH~!i-j%2`cj{4}GKn zrL@Y#w0{+nkF3Fa+H08)GGcpAI-^jnM%~>gu&4Rph#h|aim$}99)-uONJ=;|I z%ed>x7ogv@;4CCv>>c&RgV_Oi=l}T>g>zSB3>5ifaMgIA)KfYSW-P4(Jj5U9liwyT6pdxyR!1vSSxhZtXyyR$)zk=GlbeUx#bkAi%cuR z@)0!J*Xohqvyd^NH5dO93{@h{n}NvAH{EvGZ{8x>rXD6gH7AZ+__7vS1XTG#0sUo| zzSqzmE8c67J-~M=b;^(uD8t)RN(@VxcohymP!w5|oxQ=g>!ZF$G!9gosF3eZU6gQR zm*j>0?Dp~4>aChk2XG{5>)(K^Zfq!8`^0j)H>Zi$1B%jJrVrkU?4jeW2%i}WtKsS9 zb2~bB0Tp~z&8|}3UuS!d(E>C$OFoWmAl;UD z=Vs219)B0dzqE-R>5~qHDHXMmZ+})f11ynvi@}@~DWAuBZX6%myR3@nw^I?!@mL{= zygIZtN8Kt?qzQqY)aD$?cn^>o##O50(x*Mm@RDNNp4*3`>F?M%%lQZy78-ntmsfbv zmwf-rQMDc~eF|(l{g~3pe;tKh*HD}>QK`s%fjnM3&z%3jOe`>q(h>{9rz~PC6=5%< zk)R;4=^7-z?%AY5-N7c)`)noUPl^BMvAQwqW78Dm3zhk(Ys)~_G)|6O1zdhDFJF_Q zI!20fp8hCOooj#ABJWVMB272|cCC-cYPLqtwHUejILSwyyq_Q@RjyU|Qu#=EGc;+q2fXCNeZ=SOCMWwd0tbMD{msvjYwTdT^%N}b?7$W--OX^q|Gpuc|Z@s8+26}(g$mR;v5VgU4o52pyu#Cnz{gPUNd*8N|RcpqYNa;T~p}a`f z3be9KVIvNfvSrMu?g!EpSB39Lm{Y>Ysd?Aes4PGVe%qVx-yU`oTdmF;Rkkd7_uuC- z7~Hy+3nag&-*@x8L0|2``s2INto(iBiJf@cR`tIuwn%L9-Ag0j6nV&e&{BePoud)W(!{vI5N(2RlqxXo< zcvO}whYQAKbue`M+_gA@W5b23fx=w5yo>2t0h3&ck>MwrN9XErCh$}+Rg^X&<__Mb z^YZ&cUbA?6jg}uEFOLbclx(vWCNX}GNXmA8l$Z%)m|2AkNGZ_^6fy^4#!ZddHqf7L z=fw=fL!zK?3u=xHf8%hCF#P0`SvK+6KQcf%r(RbLsEY80*1Y+v99O^@({}|-S}Qo* z(6ESum2g&s1>v)eQ(-<`Jc+#vPwg$3noc|84VT?QqORmeoh62{EZ=M2qoKqU_c!gF zXz_{J6E+qCAF-7|PHs5C{8(ny6obK69N_V-W=J)LF~X#ygF#xv-eJjhNS`c^DFOS} zCDjRexyF4{sns_jKqqEaaLMXl@NNyxsFqvkBSSW06x>PWd5)EKqOR<(T{ixv9P zt&Abl*fIp6_6BEC@d?0k5s$=ub*x@fRD@sr$`ug*ycQyCSk8g?|-?4+=%u z3ixIZ!?~pF9q}tr8?%F8?GVkLDWhnHuftUH4zY_Y%4D;^5P`&dZ`SHC*eb6VZ_zJ2DH2r@-`<#yRuiz;}kwef{#e7BU$ z2OR|-fj0?iv-qITZLe zoMV@DGpA~kqgJX@Wkb?3b}e894tj6|SK) zwJepo2jop-sj1WtsXa~K;cM`E5HYgZE^gP>g<}TCSf!j~jA;|yMconzCpmQ0tQGES zm;ChckTJ03MF0*pXow|x!4YS{)oW<3#u$y5+3;pkDT_QsTZ zKGum>=U*O<#jwS3G|{z1aDQa5kbfKrzuc@LY{v-efKV*qY1OqjijW>K&C5MYU4w3p zxKw^C1#oXgf?xXjvr@o^-hdma9aTWvr}#Q*sHCSEn}7&>o1j zlA38pCXUJB)gGnjXIEi7Cua_8zvh&UA9}@p(ZV9LhiseU@42hsg8SzotyA{tGiAxU zLq0uhr9#7(aC=V*0IMh$Lc)WFH`Yt|p~x`U%^CWtv+>$H4qQ?l6<@mKlQ;}ogzHa- zE32{o>R%2ZsCNTl7cfS;gDtG8Lm&oneIFg%mnDL9e3fqj&Ls(2*<@GKmBUTe51M*WgM@iKupKH4r zv*k>ck=%17q>HXud5%kL+lVveeIIaiFbf>Qys%;yhe*^(rJP1syhgQ<=ST^Yljmw5 zqQ5kEa5Z`U%cUt9B{6#eDr*bTS?<7Rw(lW?{>$OEGfdo6Q-#a^|HwZQG&L43?*KDLnS7Ef6BK1KoH(_nLmA5!7{0+F!KJ&_aH%H zRjXFego-d_QFfg>lX8MCa=q(%n^@qjH!ErVY~(3y7-$L+8IxiC$h>eF?IL-kNWS$S z$dEXi?_#u<5<)VXn$F&{9YOwt%%}JW5;>h-*>nGoiU>=NL5cl@!Gx*Xu>IuKzS2DhIzBn_!f0^}RWrL3z$m*Q#){*y{wSMq}UY##nNa zjX8sOW2{Iwq@_2;hSnr2?8Cp~Ka?-`l_B2c^c|kYU`VLf3uPanoR0W zq#hK!vu@8C-`){Ymaq3e0DgsNcmE4^hm-L?@hbl(c1J- z)qiJk{wtls^q)@qKj|D6hX3TGVq;+Xm4W?#=^Qpr4)*_RI>#NHCF^Rrg+Oc3d@k(N zCG>R8>rqYw(}*D&bMjQAcFqf$kPEWlg#e;J9KL{D3L+5VPWJwo_oVCOXXU+z)r$9F z(@W3m=41V(IXC^uzU~|oiei<}Cci=gL<@ifA{mIn0y`tfAAmqX1OWntY=4&_Fn@2h z_eunZOu-EWCL;bFJ~)vZC3<8vx!)W{0XqVK=hh!sfCwP|FN%Z?6a)waa6qCTaKg0` zfJq(sBwQXXguB0pfT9SFl!Q9I+utB!Eaj6MZ2Ql#?G^I0gHFjzI!_5CQCH z*WeC)Dxp4me?lanpaP%oguss;Vyr7FQj)`?BT@)gK}e!4Tw{+{KwX9=;y!@Lzz#2= zD}Y`KVCO!%S^h7Rb?8etP<Fj6Gms4uDGodkO({RcVB)m}78% zMAu$_eGaII2ym}J1N%B!uv@PSegBF;K7eS0*D!pjeK;r4LJ&oUSNd3?-g*7?s=zvB zp^i2IM01q6+Aqq%&3puz9iQNDoEm1Jvyj^lFB5p-)wQ1jgOfcf<7oeO4*}NXAAJV0 z0>2HMJac~v1tl376cGOoz`Sh)@q9hdXm6eT-t68f3^+jF8VPlO-cT?W08{v3Z^XC! zz8nRB^(|nm-Iv^0znX9X0)JeXK(JLITz!ZFKeN%l`OkjUj3+m64`3PqjQ7BR{=IxZ z9gRa2lW-CKAD`IYAK@X3DyTBBi?81b-)YKpq;I}hSToTba`2g2`6F-Ow zC=mTR0zW5&uekR=3*WUgKb4<9Ug8ya_OEvQFM9qzqwuZ){XX9W44%&dMyA5p5$Om+ ze!{Z(ey~k!i*Uz#_dB|>&HkW*fLOd(frN+-1L(WC)xjf* z0sc*)=z|YVSLH5yv5No>20@fyAp`N>!vLrg??C?I(uk)J7(-hij=p4cE$}-Gb#Lo5 z8o6nOU;yH+8w9CECMiG~#@oAwq6FN`6}N@`Pg_?m zSYFXd-r_>voPmqh6GqPj{p*zne${+5DX7DJ`J2s$g8U(2;ukdXld*k)rug%9W_A%7 z?A*c&3RxGG;i=Y?rg0jpypZmIN}ixEUX8AHX~v_l$9TI#3kWh|0}yefCULb*l?<+s zQ@MRe9;Ks_)Cv8O3_W_q&^B)pq(!P^5(E&RE)IWJepPRpfNrO+bnnTBY^8|yi!h-9 z5cSmObXY7~F_#Yf>n5d5%N>I14D7PyvjDz9&{9sUdP_r|m2pkPnB z(4R$NcW28LTijX1%zZCs+Go8?Q=soveL4rFFP+N!Yp&)In-&WD)I@ z)c5kj7~1!Ktt;{=kZazXOKkZb(5H3h9TLLpDga?!w`>FhU3ub3F;>z;vbU0?KVx{oh5Lp#|4MQ%|=|X$}z$ z&8do~{r>caFr^$Ks{3K3Ib&gQLZ%&tc0MTaf1361ZfvzPIv6R!%v*Ow(|5Efd1K8> zC|KnG`l_3klscBVkapS9ZaQ9wN^>glPQ^ipT<}VYv$hQ`EnN$q?1YkV@^>>V85l5) zsY&uut<6|U{vF_Z>rd~F7ZGq6AiH0h437&$}szAJ{;Bn&?CtbIom{1Q0iJ8 zltmahwcw9|Icmi3OseeeoKZrz2TL;wzNHhd_wg`5HCJdh(cD9-7yQOk!z$6t=jOni zsc@ivURtcg-*D@}RQPNXlTVj2bLsxb;M^sg@o5E``lv~EJWsuA)ZzbmvfFtC?jy>q zFtN{Snl^&8+oS^fERb|==qMM`oQYyR<5~tyI=agxk*XF}$tN4@h!&k$?&>yf&*@M> zJ6qh;O5cNT_%!&sC{D?aTczq{FELq=!?@geWKodHq#l`CQg0&n6&naqbVv6!4Q0eQy(v0*@kZUMg%9qe;nlsG~_OSx- z-xlvBVQLahBd^LSf}-GSW*ryAlEWww({WC)-u=kBe_j1<)H`fL4QV(COZvbL@zvC{ zinJKyW(GvB{Wy707=ACgPmQ4>NP!f(&t(s3deyw&flm(D$t5r;zs~ETt zS3qfI+Bx2dnaAWK+x!ip=zYpexZ}f#H7ul{3ibfK&5@J&N>gL_Nx^k+LLmI+eP-F)eBK`{92(S+s4^_7N> zO^Z=Gt(LwVoVJq(2Y)V=5oY&7Z%jdSGH?QTfL56P9NE|%k_d$UwMij@oU0f$Jv zNc3(W9%!%yK%tr@9Vw$5ZLV>t32P~R0+IBvMhmp&LKdr7t4z?^<~0UK^A1yX!gMljyPLeZy2 zp@1tBR6!J7?9|VWGf>%-v^%(GZ>QH4pDKZ%X$tl27Ry`-mD_Y#?7o;Ont1YudWw)I zCOio5;U3z#!o{=lXaGmh*tfk92H=b{J}`Ck)~txYFFJg<*I(SV3wmdID>as{*T+XG zxarzj`-e>Qsf|*ms~@w2<`MqPJIwcQUMyc?C-$&!u*DQ4rvis;=i#@KJ(-AY(ugwM zU7JaaJa@*)TJcZ{aH(S7Smh{ra-%juA>ALuWIe0}TAJ$mkX|p11yEbzp7IYNLh@NH zA`1}6ug7ty>r#Y zir?{xw;0N9IY)ZX=RFX+`xUt#g5FCI<;yQf?-)={v!WzB&vq)mS;yb`$Ix0)g zv3uz_uXoJFhW+4IBCfKcSBrjwOr?EqMd{?-H)0A!kBFQbR4Ihu2kX}w-K$(&M-eiw zAMQTgYO#M9^mrZ`%_(*-&_5$oVFCjaL_63w;M^p5ZD|G5LV#U}p1hinQxl~^e~RgB zG&1~jIuRsc-0dxUrR90s{InN4V4Np$mcjRQLMLjPlr(x7mPi#+%@QHUBqC391dx)O z^X{=#)k21h%1N#Ewa>7m>UL9ZxLg{O#T(M_Z=({|wsr(AY+OT4mtKC;sxQtUmPQKa z2gtMB%|$alet_&USw2 znenKJ1&8E7^($?wDwMA)`T@YMR@VC@gQEM4>{`A-^D}9xr8uZc@(A?pJ$`p1;3MuG|0MT&al?c)3Vcxe@z#x~Z&Z=4xi< zI^os1wAdDg@Npa%WqHp=s{Es(GovRb_87w7lqv;gyF^o-iauY($%e)Y(F3yAF7HoC-@{pC%a zPB(*^y^)|0JDm8@C-h9?gqRSh-O&J@E2nFZ@gphq{HtlHdB7>RbMs<}4F}p673Q$G z>gs*6T}VJ~G16@!;;Y4wRBx&2BMCSq1sM8qC@`po%qZ*I=^6T2ok`^pU)a>?$o2A2 zlz`_jl?e6mtcZIddO-uHYaQ@By8BTxH|n7%So$s+$qp>o|{i2*xtIi<``{w+zEvaQ0G_k|Q%b|4@ z9+$G#8p>S1<)UYJ#RJp)!>x3IU~_BiQr5*0?;i4R4`Nr}tE5=COjrF3gSN?0qKb70>o-F#p$wPWNp=b}%MnN`(^?b1r>8T|CwiFUlb4;kYog)>^G zvVTn>k1&taV*Al%FsUop<^1auB92;Str5>C$L zRwVO|3(ECso);U!H?4(q+Mg4S+$fc~EU2L5Q-|#DCo@g0=Gg~PG!r2UrKc#6L7voD zi;nI!VF@rq(npAyPrcmKe*s1BTY zTZ_&ITpKCa*V6hsvF5y_6#c>5ad&oPOXD9aLyhjn*2+s8po|quGRXBTdy}%_+SKOA z2{%f$z27zX&>{D^>t~?t9&I#wy}i$zKj3Pw0nfJ)8n3W690_Cm_6?MpNo1D2^_YD=!=Y;pPy<$rjgLAZb68+%k{lFRqZy}-TK;UxK} zNLLhCKXagmgM_8wJRfUDG`j9oZ`sHDW*aRa6xBRnJv~=)(_if%0Di|ZY7Q< znb=XeKoU5XGpJ@;LIO&6D!IjGW8RBO=oLt{0*`G^^Bq*xjZ36^>)vMs`_` zV#Ekp}*olm%S zw9w(-7mj%mrO7@nP&4BJ03|Jb^4W(o*Ij1wc-q^q1NyVaGeWT^54~csIZ_!(Tf+VX ztLJXGQdPSJ-^gdh6}>#{CEny?dQn-@j5t~qp5mc=(yXM=@6XE3Luh`>1kzdjeHem{ z`RgmPLuA~^H|JGkQy|3)g3^t5L6 z_}-YZY?tjVnML>yAEPNRXFk$lax|8`SN6{+a~KM$TZ!&lx?>tKf*$W1BAQ>yOW6-( z1=dlwUR92po@$bz53%F*@mP=1S#@fd;ep#gz0PYIISwqS4F0wp!7!$eeOP7rv9&~r z^+8bD^zi~0LzfU$#+Qz|v#1^MWaWw{j}|D#U`0C(5-;DRX*1{DR{vEgN!_w;ajy1y zitO=8Jg>1D!>A@~Gk-Np7j_q(aM{P#Ma|R|VW85=p-k^_3KJ}&RYH`M6O_9c&89S^~t6m<6^@ z1E1jxKF$dZ^pY6bM?5CaL=XanD@>+VC}X$srWC2}U-?PG^#w1je}i)T5hDlrajZ+! z#M~{(ktZ$Q8(STSsZO_+H*q?Ky5bjxrnSjqoyn}}E_Y`g#8*yjxQE>|SJE;KpcXsczU6q z<(ekwqP_qZ2j*TIx!SV5GTnpB*`&KGMVYfoh1^brGPVlK%JRow&kJ;b(#gK~{Sj#e zgYNTMA1QmP+PZKX)}TD2&$o-}9mQr(&71btma*YVc71Z>g=)ZnPbMB}saLNd*xeCKDg=^5XWq6aSMsFr@f_xm6_#3( zeJ4KKY_N-eBEJvoMi6|tcgk;2;w8jyqHZL^M0;?Wp8pERD=oYvz^Mw#tUe#TW5)c0 zgwp>*8(M+8kLJ*lyaJ$NP%~9GD?Q@;%4gHZ&jYUF<#2e>E+$rQ%4Ymv8XB=DS|xu z_opXnT#K|Gq!8r7CAfytap80LBypDuT@|kL`=Y`VY4YsBGA_m+7xX%7|M#2heUHD3K@m@S_-4rzpVh*`Dqm{#RDt znyv72UR-g!-5M?~oflss$wgvTH(BLhtDZOJzB!+00zR$ZOrS}+4?eEGa-Aun%#kx^ z{~?hh9>Z9yL{__fmWk?0tlT&Q1o%>-nWH?VJoFbwob0we_M|5?{9jYb|CUMq*OZdw zKOOOZrj%@)zrKY3v10mdKH}hD`+t}JxjKiDk&}(_|3`IB@)Z`HOt`ZfgfP3Xw3{20 z#3%qU1MuW5CBZzd(!3JUpLyE(Em)#F=aapt?w8h=pIVn`!|J{6>x*l542x!G&SIN9 zH3Coykm>QkVOpSg)fMIAJurKx2L}hI2SWy?^MJkBJil>947~sy1APjSLwu};8UpFp zB$;WX@1ioe5CD};96%m#06am&oHU}%O#oe6+dV%@p+BMkj;YuB*#2DTzt2H{{R|i; z`O~^J`rKZx%2|FsKpIt=fII^O^qk);;1b*cI{nM32>uU_raO zKSzP0lX!4$Xn;VxJUneQ+4?#P>c3hKIDc>qTliVPeu0{60_;9~QeYOEYyrQtk&u3f z*+%feZzAXX7JGPUb%b5XU5FMiL4A2LTLkRiz8Fd_0d-B-yfc`<&*G}*G$8QZn_~d? zHuvwVYr6}6oB%>UENv}q;p{A0LS6lE+&;8R2q1H+GKYTNJsbe(@G1Pr)L4eor0(KQ z($%^7bIHA#MOr|p`E`JaQmCIAc+)E=*U-T>ef?2>OOWrqT+BxDGnFoVy8 zT%1)@d>0=^%i7X9#;D}0mHHcsFtLVa}h_=e3LE_tHppRvndvjPA+ zdn-aM0>B{-pI#}4UFW^zJ+Cy+PC8wfyF7tkgE9-gjm-$W^V@6YqY4cuqt zJAbiO>TYl2N0_)tI4ugnr#hni)~}4=+RqMbV#jO{>h%T!Yqrz}3{c~{@tbTDXmeSf zpXX;r{I+!bXXpB7@93xF`zJFYFthL=muEr`>IZ*&9`f?^sdZ$5ud_ebRv7o)nK1rG zl@;L2W%ir^yDoF#r{SOdL@9Pc=qm3OCpkPnI{S~FBZCa!C1k@K&|vk|&w8;R>;Yvc zF$U0l;6R^W7q`6H=H|~JZ+1@e;KBxw7uH%X%IR6dH+K!s5SHb`DC9j91Q5-iKeXKp zIc&R-kO1E9Ikrn+hi@m5!2UW26rbZDws|) z05;!%9smNfe!mU@bLemI33!0@A7Cf|{~zNJ0D)1zzET0Xp8)v@nBY%fKG5GO>U;h( zKHj>Yyj&vgAMAVHIXc_f()KUToF8-Eql0&N3J8GjFds{DgloVr@UO$+1N>&*yPO|? zc}R~h$e+r$W!st>`J07Y^?R0dzde3@VT3Vc;}}MM;AS*f4`tkWM^#GMv;KD8fr+>+ zHzbEp(>hZ5>z+bf5^7hUe`)xf5C-PlwlKh&(6m+1sKW)X%mhg!Yaq_ zdO8{s#B&K{#zI2g8WM!n^Xb)k#uY{6rR&L9QKpo3G1(N^)}quG ztE^N{wS+GvL=!c`bGX&{(q>*-jCOy2leGy{znH)B%hZp@$oh0wRMg5ODCz>Em+8Xl z7(b{=QzGSr6{lLS>O^Sn>#N0_Z*_|Y(~F@R2EO+BkHvyfu1 z7%}gr%X8kG<|w+wdb9H}mBHf@QP>XN(%tg-j}`v^)a@VjB@{8Tq_eo3p{)(T*nEg3 z0IrEuaN}RxHZ~6h%-rQZJYm3yr%(qyO&K}{_|-HG+bicdwTUjai|of^KB-g)N8T2gbT?DtrU*nU!!F zV_}r=ce-b5u^M9H`e+`or(7b~8jsz{pE%dZt4tN@CVuQynS?}JyE~dnN4~Otvj!L) z;Zb{?YRr&?G`XZNOI>bVM|^`faxD4*$u%>+ex+8Rq5XbDX#PM;_Mgvlv|!lt`>9Wq zy@%(kYpQnxmpelhZ93|}q;WfwOccPW)yTyp4cHIT-j?lSxw-QBLuDkIP2;o@K$?^V z85YacbzeM-6Pj;RVKSsE#s7!2a|#kA2pj9#-n+JK+qP}nwr$(C?%K9(+jj0B)t^dI zdC2Qb)l^Ntb$@-%IVy9H6%*#4`OXY6Fm~IR%L$yuheGYHd%iNjeE{9wxf9S!E{v~Q zO*|pPY$Y?k_&q3*8fUe~8E5(Q=%FKGd{=qad^l7cld>ibI!V79K;#0vMmYoin z*|G?UrH`+eaW2-mnAPkHzaL4h@pl|Py|NZFAQWmL0lz`OvU;>aR&MqEQRKd zadF8?DfurCuWqIjaaGcGVjOv$ef-6U%QrB~tW?jE!LPAoW7}?v9#b%dp3V_YPo$(OS0X7v&>USxTEzb%y$V*1_+j}E@`{J zp@B>=kOwy&T}KT#5O;-n&(ca6UdO;*&D-E zS!wU4XK!bcH(X7u=62rYxwkusZDdKD5amD5Mq>-E42U{+`+=Wa7!r9s(Z@k@aks?N z^j4|l9q{L}HZpS*t7BPn_%c<%q;xcbjW^w=!^D*A;C;&2y>2+t$pWkt;5_W~8x~k? z+oikUy2t`xLgKUxT`aMSg22L$`5YMuz<-4IF83>N!|BY>yq+xKsbWtX^=Ocy^~jR zQ52GsK%g)P((N>dtR$D_b71pHxsf4+9Y%hkKkxksN2&wUvHm}?7+7XlNbKFSDx9xl zr&W8&2cbPNzRHjtZk-BxIj^1NXXktSepk`81n+6gK=>_o{w9P!#k7+kYUOrXv=-!% z4+78`(ru|7TiO-iv?7^}?znydh8El&TDkiwGbM?`XoranBDiYIIV-hbk-sQv`IKul zknpaQn}{@J(3L||Orkc5mPJxl7r=nZV(s=z_=*Of70u;UmsD@H;J6qcy?96ll);J5 z%*uL28s8#k6%T8D-L*hEmhCgEN*|GG?xfADZuR@Skj+q7IOW9E$*9MJfySnyvsdY59?;u^@PjCBT}i z%jx`?IcNl5#k4-SfxVP>+9R36nA`ZNBlW2Iz19H|4q)e@?0!J_<4!v!kek67$RAL3 zcH}bbAeb)xj$Md0;j+JgBI|+e%+b}H(YrONAt$@ZMzNM=jz`LGjKP7@3I z@PmrVSf#kfJE?g~8QyS6tNZ^#jy(+t`7D~)5$kBSs_=`ozPyPr-YhmsO+TQBHtkX0 z0;Xn=5p4$>{@E1j?{DbcPGExyP)wljv!xY~SWwHg7_WJB!JjNL$V+FNY9?bPi5$tacIi zUWYuB?qRvc+#dED^k|5GN#Zt`YBl3N2767*1N(f*~*ggpN%S(Vta!pADG|Q&jTX8z9bf>C#Q$#Wn|EFURFy}XD}A`H zWkT6)?*yk&pv|&ukODE0(?w=@nSu8gyT|c&qtFVXe6G|Qwbb2~0d*?PFQ=y%YlTUHf-7%OqoSHqucmkaDxo;IO*NbP6aAI z->0B;XGJ!hwp!P%RvB;+LtIahSU~B+i;(Wzs)ign8iqEsof=6JrCpERC?yGyr6Yw_ zd=-!xCwD7JUpm_>y|ViBBmt&vmDaMy4{lt7P+9I=`WKOsm9Xt|`_jHno1AEN5%)}{ z3id*Qe+`0#VOO@S(7hF`=1sl2?Hqm=ZXlrTj*!KQ^2ty+&!$KE`C-PmX|mRLuv0si z(CKd(^F}mDl_M*03-d~BHQ;;>=giwdL3iBKHf@O z;eyqQ=gukFgFB9*Kh>nGuRV%y^@k>J5M3QPK0hxseRo!$=VtA6-__&IU3*1x?$O=dBtzKX)BS28Fym;W?lMk@z1s1 zjyaGg*cIWz(0K-UE<@+R;cnqqyLS?duII_i`FK_6ALdBW@SjeX)K-Eq=Q#d#SpXBW zXQ*AYJtEcEbZ&1bAxn&RoAfhHSo8-kSMgk?+W105;i?88;e1Lr9j=WnZO=>9qG;id zt?SHJRfm0ukR_YV7~z4Ul4DHjQ|SzL^myk5V?&# zfZ}!`;*QBtE4hwoFQ{{TQG28zGK7A*CR$ zrJx}NUhO@=>Y(f?rFuicPA_~{zd}i_X(=!=GLxG&xMP~v|NKq>lHQ!zwlHSKg%dOH zX?@ph7B6SdpPCo8i3UcDXGvnDus?PojqaVORNcU;>v4YEsqlU>4j2OsvT^i+RHr%( zKX&G6;5%rs=xy-=eA=zBkn0+!W^@gU2w4o?BsO{h^`jp5PY&{Hc`v78x~efoEsf88doEXJC?R&*&^g?Z+=b`;uKKgudHr zFpA{*$ZK4D*O)Y##~3@$Vln$fgmzuU>(kt9`#IaTyVMvn*!1&fI`;1d`2|HWV780q zGuN4?LK=q_VQ^z^#rgGaVmK5b={H@7h>{@pEUuyR$JUx;R^Dlu=g%4nX$_=%cpy{u zJmQ{tDUoTJk7Z%7vzYTQ2wW26d_*nmZvr&scBCiYxXX(_rKy6`5NJI#l0uF*=9L}a zh5~GQLUaXG_H{hxxGuXQTSqLT&BIhEJpv;(IrUa8IkVJ*cKjJqQy=^^KQ{|O5ah{m&i!+t<(8&3~uy}`gC0DulpO^!uR5uLXlM3w=bf~-H=sUezy7;1o?jFUmQyLirrWAXhY(DM3I zv~G;8$t3e;@&NT|4Ag(4`PIFau%roFhv}E6!R5H=j0iGLt!W+;eycO8upSl@C1E;Q0>!iVbYfuXi!xq!YddZ+RHMuft=Cdnzi0PYcBZ0L8Y~eZsR?-|HMQL3- zZ#vaIH0MDsO#i6Y>A}xq-VSPERn@)4N1ScPn*hj8M|hMOi*hhRHr1>{;qu!78*jSx zy*vgVchEX=o6MXHuUY3D_9J=eYMeENaUQj^8t?;ChT0KZ+om)EtoOL$N`qae+M5M~ z_M}!XJ-1mf?M1tNUdVV?ZD?nb;n3(sO)wSeiR%I9Tww14yF@#|Ea9rNwXZ7Ch zK^8ef@W>YRPl^9NYb)vFAsJ@rQ^Xoa4h_(~0zzJn_3^wn^vt|h1^P+*#L^sf#SvJD zm&YdbdM4;?tkTi7GaVWFN~Dpwe#a*9r-+^lEP_N$xeNdNn<~R?rvo;8ue)T)P4~2) z{3G+M&dc!+NmF+GC|}hx9{0@@E}z?yW2JkP-tU)v!;%Knz&^^H$S|J}BMg<`7wy7j zMS?<_NC#H6rTMs&Ur+#Q&=uILenoE4Cf1N6PwdKuBwP2|NG!d^s61Vf5tvkL!>=OsUvk=$bp zKZ}adQdhToRO(ODYj`U(wW|SpUQ7c1*p~kwmF=O;9o%>?s=1mZX7(7rA=U)Yw2SQu z1SK_($V=sKe5{)yKYU+W6gjkrOdraDrs-1VwIFL$a5f_({3}un!F+06WthyfR8Zx` zBpe#!&T+5Aiwi~P#f3#W4~_PKV571VZz2l%@@tpBDk%(1&|jH=z*|l2FkjQkdx*+N zs!M>WQ2EKud5^*mYjSMPDO2!vP`8zPtVOuW-#7XNl-1_i%Dc2xN7b`Bo$LnV)QV%PK=aB6_A*PssaZqYuaRT0PFrMx} zpG+4s*c^>>mE;PJ<%u|*liTvbNreSgN(mu+ctN{*EW+r%8J0(usurY11NZ1l;d_lN z?=0vdpAJ7685mWQ`5r1`kWk()OW|P*5dg za1U{IJDmcgDm3mS_t1SSH{8eYSzNtYj8whj1mtvwa*kaY^-TO#CE#s;AyR*6HxMWV z>K{Rfh0!BWx`0~8hFd_*uozMUcDBY82&pT>`~X+HPNY;_qqZcuMLm>nf@%>YGG;Il z%H+$JiCa+=cm}qRNX%-Aw4hmJm`DhY}({sYrWrj+=0s+i}G~O zD84Ggq|pLhD2#d%cp{;l+@+vyY<8*&cT~+eHCGnGm_3%_ra0N9|FOkp``F%eDYvxG z>vKv(>`rVwY*=csW>0QSaP2>fzyK%m@unl=inj`Hf5 z96!gJ7%n=`5bNEt$fchIjYMnGKtHS9Cih2A9Pr)J>F4`Yd)v=TqBo zDyZY9WbLYP%%k>;$WD+sg0V+>%0itkIddUPnDfIWmg|xR)y}E|?f~njc~giM!HRVi z~5+p(6W-$LFEof-w`3 z3>d{EC-}CNJjy&*!)kMR4&vxfQQ=$GPL08Fh$Rgdakq980f3ls?=udO~pizo>amuP?-$53PQt#=X zCDi`Sq;d6{r8GT|T_EvKB`acqUK zAcJ7Wx?|_eaUv4kj(WOFLARxzbol5CLJMkWaayiQ)-wvTtmUK3Jha7^fJI8v&DJOy z2OM;BLO&ptI4z5NP0G#XCbBVY;3XdspVc{XGv*07kv7|&XMZF-PM)mfyW)(;HJVtYb75;BmOm@(Dlai4bmOA2tS^5O-MqUd ztNzB>G&orgK8?i8HRdpg=z+x=;xl=TYqp)^;H@&|t-R{%;KwGNBe04Lwgo;5MeeW; zgIw$pe~MesOd{D{XX+3x`_+}!iF)A{Il49PvGR-2Q0yMyU^!5VcQ60p)ew)i=A(W{ zzmpJTKr4#8)2790{mO8dI7|zT*=U}w@+du&-1QpJo7c-lVn}`lWs~rP4gz9J_|Ghv+>= z&w`#1PlBzn4+5osFk-oFR3{OCVCFUMaLF!e*3h7$090%oXQIRgg;qKKHpHt;A1FkO zf}x%kJExRLa0!8+{zES=rRSa82BD}O83u=%>OVz9yg3+58UxJrdgX!rk z+2B=OTlPuKAQ%X3C;x)J)-d=Ci^|^b>>3TyCNYdK@Kf7LL{_&6ypG;{;Y*Y1YWQ)bnC|h|9N=Q<% z7k(^hH&R8&a&;$=dDH5`L*JC?@91DAiM%-HU9c8+KyEoieHC>{OzI?@0*Cy&%-X&| zt(6!-4pNmBJrOFEF{P`ywHv7t=0b6F;D&rU#eXAijCvvBs@#7XYSe261X9mfqELIq zDoJwRVTRZ{S#0qt+^tL#pof2HVzGkrX1!l6YOk&83y77|EqKrP?o9#sqhWwb4Lf!e zqXqbc>kR2UKM`%O145;dX4l$E_4>4;XytF03NX$6x5}_%e-%|n+FJVHtt=-egGy@m z3{$!=E1+R)UwM0}OZVTUlzhiXG*?cu1C{hTmSu>G3ttXns*)jQ z%_qMQCGS3GT}^Rim3T!!-AhX6e7}F&QGOoM(>XKRpE`#jqm=2&;ad@odUvPV2uj*T z>ZXtwaiXtG!7CCE9pQx>`Q5?23kbV%QJNJsy_akZtsxI03prJi;9-JJCofmnaLP>6Y5v>{|$ zWy+X(xg$&C6o7wnx29YR8h+#{8a`*REf|Ps<<*{nqRDG|;rN6xxT#q$Z1#vN zrOg&wc>HpRliM_ovv%YGgulfgr0i%uTZ30c$0@%=(J56?xUf>)Ak81v1(4vhkW154 zZ7AwUJW}!0_w}&OUNQsk#p6%*Dt1P7db5-D4LwYsG8^4+VUoxM2XwC+hvK4~6Y7Y+ z+Qf{Vl;TZmZjv=$6zHx`>eEVtT=#iw*Iwy^S@9}~zKa`qnV%geSM3Z|L7L98*&&LS z0t9nOzEBR{$!xUJ(svr{rXpRCs1*6mPS<*75S{FRxT#i!XGy9l_{ZvF!>NE8$2H#q z!G-@^JWe=44I0%*O<Mg|)>9yW02Gebhr}FoTUxmrEL9M~ZW{&AKx4cj5L|x`t zK028kT@L@qFY0*CcNIBZv+IvMXfs+4UPmqMqqhR{6n0p1cL4PM{rqI>SU`Q@dt{$= zLi;zd@ZNjSLzz-<(n;1$tuep!fwyP0zq0TKWPlsDI(T0Shavf5xRy6WcYbbIgcmF4 zX00GsBWyP*fl|Mk$1z*HI){!rJeGPX$PuLH^I$;r(^k-{g=O90kDnF<8NLauwrC1E zf%o=hj9b1=4{0R2!F=!KmF}l~!;D-$#+$}o64h;EKtwo{zrbo2y*CKbd`MQZW=(t= zfmtvYExEZp$S$SOv8yds5z~LKgahP^d5=-x#i2>|6k4t4EoZNmES^qWkh3_r|H0fP zeI@G{U0w~()YB{BmWwTXgVFgA`n{9M6xV;W9YDPc>`!o26XYiuNq&I(t zM1!cPa&R;@@yKBWDcQs_)Xv!|HXz;H<%!6D)@YUTWrHKho-SRBFuK^K)oUH38{CPq z*0I}!?tVtnK$L}Y9Z2Sj2xr~u7oz=FXmD)4qeLP;jeW~O%7_yZRtRB>ZIyED^?FH% zyk7i*SkH2~JUo;FpnYo09b)sal7Pu<=qsyLy}@G9nJf*^+M!I=>I@n)5SF&4E3|>J zE?anZAh{vU<-5DD<&D}8QKuXFCtqImf`e{VgUJogk}M2_KeV}GX6+2h^3F%yt#}C(33-3z{~WiRMNhx+M%9Z)fZk^;8B1C{pY9(_0>ZF1+ne?GW|H+J2T z(xHKjtV+_R_4X|wTlcTIfbvYV(C$}05l#^lVVZzPW)aaC;7ZwdOVH}T!(MI8J_qlB zs@RrZsqoe7!)!t_+Zd`epJq3VlLX1n!Couf8CgokItuu2>ZA!1Z2PsDY&+tphN19< zAgvRlOe0skG@H|kfiij&tkA?-SK6JEH;E6z1eIdQ{4&33aH@R-3_ zSagT3rk!B7kJQ+?51j32jUO@gnybHRt97@TS=*XJ$8v0p57>Hf>Q3rTHKe z4AN=~@Cxc7yU6PSq92zX{Lc9;4P(x{Q-a5eE2%mM6y=|H@d*JvzY62tul;VyUD_*G zIZwy@Mx0Cqa!ukjuMdL9fHdDfdLMV);T^jO8rp6P@T4@C=pxhxgGgq_lSy$@l;hDT ziKil#FSAFU_M?qkx28=Djv%whEmjpiGy^+wI@PyerZ<0e#(@45qPK0hbfQ6?+>wT9 zT@t#ptTRjaBw@p0p~?Q!4p$fQ72o*2T$NVYli9aPr!agGf)#crD2B!j(IC=KHV~Ls zJmerE`W%=WCP|(^E2U|z1y`EcFHoptxYAGRf3MX3@~Dn-QsVIXVpQ&a2{791!q92^ z@3L^A>`3H{cXZ>=MmY}{cLh)q3L)rO=YLXd*lCDHNqH>)TGcIgtTz)d*13?U<*`i_ zwlBRE1;)Vq3MtmGrQt_`55GLmR>a+Z3^{?EM=GZ|L<>veeJ>dZdD0;EmezWGsm=Pz z*-R-FEB7Xp1tZPJ-{rK3T-nvT5xZ@R)$M1F%=}DnHS;fWlA{zN7#f~Sv4yKo=;5hKaX#hs$fG%%wB+C$0UG-6{ymc?ts$qqH@`__Ce}QoFk%pNdRD;+@DsBpzQ65=b75P(3f~z8QCELn-w^zHy-G_0P@n33*UxgBG{1otE9juWH!lw54O)?MHzR8~yU z1shx9z=(Q0O=_s)WTT$e@fVxmUfe3*#XGoM)C+1x_3fY1@iUXT=s0Mwuq+aX4lWtb z49@ygkoyEdp-0&Ad-W|K?5)@<d67GLO2ad2(OhJFFjJyd6J88k^m>gL#>1FDJfzofbel{ zFz>#R-ewHlSjt6y<*7~@X?}v3D*KaeZijgTWA1ZJbX_`IM%NyRomqt^EPp{jOD=7i;y%7-G_ z5qVPcUT=79dVOD@u&r2JjmMCm};Bn-7}CQOKxS zyYXlRpjv?atlk44<-ke*OFI}G(r9iZdPL{c5AUP0&_=5;>&}xzTF@C*!E(kI^4kYm z>wBYKKXjva`PNeTU}pF@(Q*+Zv~9I0p^MRV?9d6Y$W=05!hc%6SnQJm*AM5wbX?LC ziG9HUzxXa=?xBtEnE*OgW)*(9WGC^ijmP18PFqGMo>du5q@yV;wJ_`6g_A z@svH>^NJbamaDe9E>{_6{j2dRS7gu_9v5jcxnqn8ye1@w>}*BoDtU4W>4-?58Sha! zY|6<;p@p2pA2ZK}s1#R%R?UX^zo&>3gp;R*9-BdGDa2pLiph4S9;kU@?Qc4ECMwop zB8^g*%toY>oao=S5mN2r-O(!Mu<9gP754sd*XdegJ6ZKbX+Cy6Hu-A>^414<9BHwZ zh8D`En(WbWPCSv7g?Lq21K9I^6TFkLgPK~`={vs5d9g+CZ0=HuEi{W z@jIclR*WAyN(*f5M=c4&Z@!QZZ2s`=Yn2mwjssUhSnUH?<{->DthAF!DoLKspN8ge z3rkA{_>s6D*NR6}J&w%!fKpWQr5dQ1H)#7x{X3#f)_9-tQo%m-XN4Z$p|f=2XAD&l z5)nie<~W_^!O-;@VOkb`Q1!{zz$UbTLPb-mf=W0bm8J70n<06xbp$3U?MdaHREi9| zoW>D~^mqDl=Z+vv=j6R-2rt1?jxNJd+5E7Xzf*wE*kQ-WCf793^?Dhodi>}lzFp>e zx~KqF^@|mukonQvtPL!u-0#=h3!@A%kjdDAPrg>THFp&b9jwa@f%waxRA*qNEJ%8} z@k8hkdw;T&dSvq>$UIW$>4v3RE6`BcPmVYEBn3dq8^%(Cll_<4f`1h_eiYe3< ziD`yR4;?^K(gOD)Lubcd%%HZ8cGE9**PBnwD2l(j;mc;srEU4;?c>}JDT$C3STxZo z+i9p&0qTOBd(5<6uP2u4jbTowx=XcrM#wM2d5pHStSk_Tw)EQW?gW}@@2S-NOjtIX zN3IPdI>D$LO_`!?)Y--AyN(kFF}kve%50HUC#D?xnY{HZ`AS!wP9Tpzg(}uMZ>eT> z-Zr?=*#`o|>Nj>Tf%GV?>yA~R#+ zlYg!4rPFZE#4BLd6N0l zx-mN?s!5%B83|+LN@;)^V%&_8WgZ>k+GpWW)5jAI60%z+R6K3DKE$1sdc)9{TW2Ww zx3Z=^(4VpRWVNlh%F=nc_T-c#8N?xS0Hv5e@Bsrl5&tJBfaO2knE!u40RrO6nvydA zpa5lw{~Hv*#PZ)XW(*9B%>O?P!v6#Xu(JPOp#TFqBRb=ME;CaLI&(UU|E@H%qqDO$ zp|huRaIteXakMZqcc%N7A^fi)LN_{hI*QOGq=~k5gxuWNBwL-Cm|?cJ1I5`E@E2m7-J~Sam>0wcv1U15&$@S8SG=rN z3{PHfx4eX8Y71wmZQ&R}C;YLsGuAcMKmZaWF)^>K0a#gOQCV5xge@&$t<<>o{LaFc z>;h(JSMb3D_=t&f0!VB1Gm|5z)a4P60OFmRfa{%r);vJgJV4jh0I;pCzkU%xIG_QF zrMGIP0VAmaIO2ilKoc~Pj?Rv)Z7hzVULN!E063XE0l4`1=oa-Z035vXn_4m=fcfW# zmZ8kyU(8Jn!R5g-G=O!wenDT?5)rY71vCm)tyuiyR zDFKpk0^t0hslI6XK;FvO0bEgE{HDK)z9-{b2K6RLO-=E=#E`-1tiYxGLt1bU@~MmZ z4ld3oK_?LjhubF6uMqyAP6S0C6N9sMar|CM;xD-8x2`xhge0@Xj+ zI|8wHdH`~N^8oPuwK?AX`c3-OQ$|6)^fUY%%&iUrh3NZrgWB8pCWC$TI|;nWD=7f~ zY6T}jaL)_?=-3^sn;n@p1^XHN`RxMotN8kr`JtowUETlP4L9Dpy81a-{HD44-OpOn z+VuD)0?ajKQ@b-I5A6Hgzw0g3?CV|CKs2|#HvR3@)=)#f3k~N|-}u%Nw?f0P`iHni zwp3*->mfhpvHI8i>mUHA@YAmJ&R_vBaba!#-t|$LnL_g_Y4=TkM1g|XE%|vRyV3(^ z{A%*R+2Z;~G&Mz_5n{Rbu(!1X@?P!Xuz-91uxtRRqJqa$se=N{%)sjdI*NWRE8^PT zF@F<&$G8JlC-x%Z`Kw&89e~$M{zkd415`8iB69gZKidrf>iaxmIRL4f_z}?pRBhRT zywLt)-2abk%sb(YjJ4ka;M%a^TYg`H_{}`le$Lcho51(fUR%ArJijs8c-p6p+Q zGT6-Lv>#d(L;IDcEmyeuNx+5^>_e=hdRn}EH!Z8$c+mBAdy{Kcm13!_` z@!x+RDKatx&w49TyW0EsiVeW}C-7}<{mEMgHhbc`?1y`K-z0xyHE?Nh1pA@Ie~UME zc?S3{0QkHA!ev~)+KbCWYl?r$HwkCk^7-!vV@L5i!B{We!9l#9KX8cEm$A;iS|@)w z)2Fwx`(+%zFK6c1bo3Hr=;b`5~1yI&kWy>{jJ| zlz=PM%Q$M@vkL#gER|#S;Q*HhG?S8XgaUk$LAG)AJc}`vJ&wlM?k+0adx$4*j0$vsIwP4hRJo)SoP_t65c__aRxi!2 zK<31(5;IRXYusoQV^&A*`6Yny9GOj7_-)|Gnc2B|AX-%SV*l+DlbY5inDR$e2?FHX z*0b9nkOX7e1hwpO+pHGP!>Gf;`vHCj7k3C&*Ht2ExN)mAUB;Nz^q$YzVWL2Ou_ztM z!wKp%OzPMQ#Fk?CD0P}@xKzs|mS7Zx=*6}pM)DDNih-O4!|FCJIO|0uwou>Hg-Y8C~9f2h0pB~`S{zd z?GLjzm6%pksW?e@B(#OQuP6lDgkf>ew1`>YGt?Z{#9l9_T~uXA_)a4H(4UYhNB z4B{&(EvB;4M_J7IjPs@MBj!DJrKcX20uy?%2vG?dpA$fWM9_NuA|si2zuXpP>4Dqn zDq`=>I+u+jkKLf*6Ek8`C-X;WwZXCh+sNIWYafxTyJ&+&X#e8RB=$|MtO?~y`q(`b zRMaD!sz-KF2z-`u8eN?Fy6#NBm_U%wN+lfC?l?v2rkv#gz186IL(|-ghASVent8J- z(0!pAxQ}?&!))%A$p?g*+@v_~N|`GX&2$O8)5!SP=j1^s+I{4{EvuW9f+r*19rO>}jQzgPXT1Ba~O-x_x&I!PS=&o_>= zRfQIw(5Pvc2bqs6?A45{9frs-SuZ7}3MtUr%O>HP+J&N?bW)JkRSz0Ag8&0rN4LUYEB={dyoH2vfOQ*jMNpOf~#6j z8jnl4a_s}h85&!MX*Ph-!Z9IatXVDTLg-H*@rwyXnAHeMvI)VNR7#BC zENl+bR}!@gN&R|Rs*l6+rH{b(YmlDMmL@RE!b<6Uq<&pz6s`lXA#78Ge(vzYeYWQg zO{4QEqr;lnS&t!2O4ZgqDRRnK^I%KRU>hq95xf^3Ba=^>8+m^5@e8ZpG0W z{`EmJ;G?Ra*jrr~FTUB}T#i$R*K53H`4+L&0>Y}wt*dF80q{n<3e+c$ymi>3WH;Ek zXne`)>bOd7oF_aG8hJ?+NelBI-my7VI3myFUaGq);HC=?65ZKxvdA{e4$`vD*B=Qx zW6B_sQz`zYhMEU{`WOSj&Skl0sHc4dI5a(Tq@yaqMS_%{(v!vAmn`d3OPEleZ8?9A zbf+nm8_@D_45xfL=?}U&731SALZwgx?4~Tr10vIl4r0ZH)OEVIebjO7?2AfMH7GTR zA&u0BzlY>JNPdix6rAM`!Y%Dg;(z3+3sm=zb5O5ok)1(?nuLEZ6^(&RPlFj^y6%oR zv~e!^(VOKVNjKx>NW7TO0Fg}={$$vm)vb1E;0ygxg&4rk1p#yGGXodcu2)dL^fYh>3b zc^=p~LpavvUIWcaPIZr_p;WQtjP+xzEpOYHkUy#m__PhCF?(NL3i75x@u;3Ip)(gg zv_cXNQATUFxU2V1MQ#`Hf9B5>vnsrw^xZc@e|v4_;u*nG4YlVP!^CW8G=a0*0le;E zJ27gGBh&V7JD+A5(f;P>#Yskeb29iR#236kZ;zEEgHb9S-0Avky3(mNJ$3egyli;j zsRko#VVGuUkR!+G@$LnPI%;@s%URnRP8}_e<}Izd zk~`6I-D)l^Dy@>0rm*vE1V~1%dVT+3LrhM_wsrp0)$1GJYL7``gr z0CRK|s=x>2tTz=!Ee$b+G*~BX~8KK!mJ~U zsdNqi4lOQecV#s{B+UH?>ki4Q4_rCDK{+v+;;j>e0e5}arJ&{Z3BQ;l>rNgHfjzd?|pdM>i?6;S%yBK(19u2CP zH3`Xr-tOz5*$MbV&8r~-r#NE5-4OZYRY$s=Y8j1BJ994Q3c+0(!D2t9Z1SThimf*U zuKXxo)OWzfyA*`m4!M-TLrl@zX)RAn>Zxg;%><@uZumNBI`H zDkk05(i`YrXN#GytIG+QR(IMTk_1>IgaD;cb}Re+(qF*JQ&q`o&vd&~P`-7+cJs6s zj;PJ};Id&WrE@VY-eD@KNikCKPT*a}OxD7_y0`L3 zAyOF7CS|_e1m_N=TINXXM@!r+9FXW&)`2vEIaUD!F?MeS!7Rx^W4*Cm*hnJ+H+kEzQ%hB!7bP2#YCX=u+WoBEsU_&4>j0Y2R-7>1HCt@qy+wB0+h7#d! z9GDeDnBJ45sRHd3a?sM;A_4dXq^t15;N?%d?RI1xNRre2OnL8sB&UcS4=*bmsQp5h zfLHkl_c);9hxx#i)mINqx+S9xiGo#nGJRGvwN@_x+CtXRcv zT%VjM@F=oLyF&4)bDW*ivCpVe42u-HN1?RGb4#>8qWbfF}UMjfNY$>501j9w%YY9^1}e|O+Ib=T^MSxjgK7f z4t(t*sF@TIhT_bRMuu~&$E!)}R#jymfi!mUh&W)Z`%~c8N4XMN3=(o;w&EeGcLDe0^gbC_We6 zOAL(7u#Y}#RdYQ?$MU$ZR(7oe>0V+nPCeoOvwLFG@l-Cc1*r(J3 z*Gf!@5Tn%u$geKKE>7yz5Z<^rmB|c7oWY+Q@Ro(ZR%9Ez`l27#mYC z|K^%yu%?!-+aXQsHOxWcyV~WXnjkiH zWKR$_hRv%jhtK5bBr?JqboY8X&Bh5FOgS3Egv%=;qg%*xG@-Pfv`V zN7X<#2btx09Wfz#+xG-D+lzlTtRnH8dZD?m+^ju*^)D{#I(tWU=F_C@JgO+hY3Qt! zB{ErmHq{NBl2FZK7ecqAGj%$3@Rs`nUD)-)(C8(t+x~q1{{EUUbnJWpWXu>!BT!-CTx)2GGx{6-MI zY=;~lChA&L`Yw~|74<4MnA1WeENe&)LAgeG&jh+{Phqe#iBX;$DyBc7)B}gwdi{=S z{9>>a)_zodx~7ofl1y~lM-87PXZYN-vQgPJ|9B9?7n`!CoOqNdITyAJh1dhmXcSb~ zI?OBvWDZF?^9&B)>Lpytbi(gpN8v~&9n8`jMXEraMDoEtyMBB~BD-n9w6_AexSKX3 zu!fD=RS-F|n5!G6?e@fXJLC`4kq}!XQwF^-At93>y_`ui)nfh~LCZ-6tD~E5RabNt z-VYSx3=pje9a-BFrSWzm%XSk>ouc?{MPqQbmb>aH%`I~_k_ zrO~Mv_l=6o33QCE$eNb9m{hPMSwjQtiID_{;>%!102&~5cAIaoX}A6D362gM75 zh>{%b673^R1@*th%3^_Oc(YJu&k`HYEaXyFZi*75lJ;DLqyp(PHrmh;PKF?ECpiD6 zY7$;IDqCwV@?kU@Tm0F)6woXqq)Y}VR^@1EjV9ObyosmL>l9v}XMNEo0_TyGA%na@ z)oeW|7ZE(mEQm4y6PE?DZ!>actwqGod9E*&otoftlGiWtbyg8K3$1`cY$Rv}7u@A- zZVH`deFI51vW~K2eQHSmxaBhodV48*7T-2Z4@^=EtnDy!&ibQ~^lRUKc56^vUtk zC+-|vhoeD-5osDDSEF3^lRf6~WTzk1OEcU|HYJI~ug8~}`kwBtnU?gly4!M4LfWJ3 zJgktFvk7WFte2?{0FLb zLxgzZ;Ct}a4vnnqj%dF$=qG;W#b=wVkP{WqYJ*3? z3uDd)v24#I&wL$n2%LNFX9pzoD6i1a6B1<9igURtC+lANB4r_rsQ6jgJpYBTdk(H8 z>J~+x?AW%G9b?6|ZQHhO+qP}nc6Mx=JI2n-IbWSu_tty2?)szG=!?~L^c7#9H&j*02m3EuT07}6X}JusoN(52lSnAiXM$Y=&KDA$x)cwQf_39 zykYSV2(EF1R5W9Xd6x6vwnN!k#axBnO68qr>{+$)loFdEg$AtR*p^QJn4v_(xfZuT zDdG&z_}Ujx$HVz!HyVhHzdP4?MyC>E^p2Exz$iZi?h(GA_k=sFNg6w0M(cyCMVCH0 zG+tn)MfQA!@Ua3lt7^LNQtU#WW*D-P4mG$6E6InOnan?CdMu4~I=f!pbWQ!nvFIJ| zv#D3wjqPDy*B{AhM4GQ?ZBimmvEV5k5r$6K=?3-jjjQ~c4`PdtRQ`2M7F)H}q0V9n z(`BGsB&Kx95Ax{sh{h8*%wTGg(i37yQQ4~+H{(tZp?#4pJ8vz@sN`n_Qg1OmPYcJ; zpxJb|2>9fyT-^?na<~xb(K-$leBH13b>ARm_+|$?_Ep zvU1jmGYUvZldZg4<+$B*%(N@4DJ%(Pn|Mv1OczeR{sSR03|!NWbll$;#%Gtx^4*jK z+}l&k*V0s~$>icJ_Y7bYW|KFZ(pI5?y@(#u8j0HWWX^LVucK8i> zFj)kVpubE?A0M6iO$#L&$ZPkC;U6FlIlYduG9!TXr$^4u&7hUi;H=1zN_ho!!jKYo z5~XLib6@%^7&;5FrvmKq!wj=o{ppt*HguMxWQYDrzVTSAz|%gaX8UKzP?|Z^gFzH3 z3I+j{6&q*gGros&g~$Wl$mg_E^x2JLEDltJFge@SVW6h3+B>CzxPgZKU%iiXOYrt8nJMJY(wTrv&aYeY>a@>$_yZ zapD|u`b(F{6BkHC1qiD-x)U- z!@>{b-Cldv1gsHXi4nld9GIoh%>ka68`EF0&H-W}4J(7r=0z19A3MJWJbnFPD~G%i zJkl+K-n)4;xLzayDODq4e_xn9i{}SwF==;}@OQz=Y6zzzUzIB1n-iAbVi|mRM~h~C z{!peJHjX%0@D`Ognoc{H+^EQp`!NMWAWkd ziVq;KFFzXshYP38dK<0@3RjIP;l5$f^h;^G*a(^DWq`+MOYZP%!7fG2tY1ZJi~TM> zg=K%!1$TO&OWPYKvR$U%E-_Ij9HUoRC`;4hZ0LjX%EYvcw)0dm+*C1_hc}{;4xp_)mN1GwAlE59GVZ3wo1F6dVItzQ}X-$1e=9mKO^$^?^lt*n4Y9cXg*~d z$0ql^jaCaI$14G8&^=PzCgP)UC^6&7@34s4GIcTzo2I!Mb^G+VLY2DP6x3wQ$3Vd| zns`8k9?JC;5jv5K3zH>&5*uJqvJCn}!a@SoO=PmDAbPjBX~xVIQ)oxIl7K~kc z*387OatRnd72M}agM_NjgmeS8alqz`m$cYyyadBe%RYfDdeEX{hE739Z_i>c_xGlx z$f@*OwXN)Ekb{84-bYVFUw9UVPwUP!Cm1?I%7~b%{4s7CMbN7wwTk3oVC51SlMGh! zx=QP|{7-g-^gNGsw&jaY7#umjMv_?cj;C%(PQICE=)lavszfy9FJI#4IrU7{#{DKRq^Tihsv0ps{m&q}D|wIutnp z2~A5m6HJ?)W^GOMut$2*8}n+?Yyu36Acif)vuC#~jHItaJ~p@zkw7^Uq%;mOMWg2$ zCATph5q~9)q~MiP%ul5b-@BtrX0o2B|BdE@+bSD^lx~IMx{L*wVecu_FcH}^k~MEP z(EHLl@ToBm77eb)lOB;3%te$E>l}2-AJYV)oaDv6PxFYCruRG8_pd0sjC`vmuSK~v zodoU$Jynp8sv1vvzJ9349lZd?M)Ke%$TdynW;ezi$yvS zWt0rZZ3*T_H-xng>Zrv>8YLUMh6%pt^lHT!TpPVWSzzY;O*se@0#d6Uk7<#jd^iel z@4SkuO?L?0(O@0gXZECV;+GHv@p5D(FMocBjO*5vt`m~;Mg(nPH<6eDcfxwY66o(a& zV?)Rt!VGPWACdVx;kv!*-zIBAZX>Hp;ea3@;z6(o{|l6@SxDd3k6n(DcQ)$zdA;iL z0(*Kgt2gkOfjww|sCHZBchn(IQTXrtxV;&n0iK+I7H{_!3Rtc2e)`qauN&2}P~0!? zq_fzu$-={Cq*ivM=Fb)eCnId79g6vjdyd&Y2lKFE!FK%f?Kt$7v=A5?PVZdQQG(qC zWKXcK)9yGF|DzWL3F|5eXPH~a_3Z{q@_J#sICri^Ts&)^7!*G6BYJ*?1IxN8 zZ#T^aqy-KA_OSuo*XF12sye9j2r=1`KxLH5c=O7+0RhS+vSzn63@@bwb?I=+&+F4H zv&edzK!o%CWa3EZn~)v#EfOp}soa>?mQX4$*_TmV7f*{$>o8pCm0$&6s`rV)dz(*# zyYi^upa&XeyIr6Xx(FRJSd4g);ywk=`!jT#jke|v--taQ`TttFC$sea1oMexg(lPCfqbqOD z4rM3IdIxY1tt{}9CO%P!-|e45K)0x_G8$safyd>TdpnwuS_6fr!APc@ zy8~lD!5a&WB$VcVCw&cuY7#c#J}c2-d+i*==RyrMqj z-GMl`mA6`ybO=Gh^zWkiE@!A{CQ7+PRs_MaE<2_)ljh+DB)Hbt)_wN(^=6==G$%ub z{^feinHs!7YAaMv2p>iS<2pBK)J6+!F?;Ix_7(<7IA=M#cP?n<);;}l^`buH3z+-% zQ1bb2Hf2i9X}7R_2PgddywnU2#t+$+iMNo98%YuUG-}C8Z{`-;Pqzp8rRNz4mn(?L zyVw(H>OMhtPq0HM8{McZJ;DVQLnAuvk3F=+9JpLK&MBJ z!*e?8_P$@z)jVu{$?>*wSI4RHyhY`A>3%DjWg1{#-+f9G-3?eB^Rj z5-eg*dJ)?~vh+Luetn(sq~hLp_qlt~Yd=5m%X&gY7Jj1Erp5)tcD)L9 zMu{XMe>wVzD5b8lfBaZyia0S~mU1e&5r>A_Okc5LNzh)XKgnp!6t+QtWL69b@m-cq zkuzLL|8i6MS7I8?YX|YsVJ|vrsv@gbf1HLdW!h;JZsp=8@1Naaw^CL$0z^J8I7Ed=5*3B_xck2|)9MP@-8viXk44Gm> zKiNR>s!m_(bDulyH+qwGM$L7r``L5xB^grWtPr(2aOjVt0}}=~7{u=lHIQoKX>X-mw1-4HwvpiO-%z4L19;OR17xzOM%+%1fXyKS z8+6;To}kYjg^c8uG3K!ulp zM2qjv%`RaSLEG4 z?fdEWUmYpdTW~aTAbSv}6u+D&7@go#=yG{CcAnzqwoa8~9QHH&lR&Y&Mg?aQWv66L zG8|0eU;x<8nz&eSTIJ%ICl|eu3eJfnl5FL{_?62$^QRz~dxBvwM|ZiY^yQJvS3Z6x z-?Ogr5;M<4re5d@>QsYd#*MZRs+b|jeomteLib)%V&^;o4Lh$)#L4c_a(qXOy!sU0 zvSDa zy=J6c7hFa>aRMDYTUR$mS0pUY=hpIw3IzKZX#hzQ$(=MvFX^rt*3D>ar4g zcDU|8bHSB>T`bao{W6p{ql4>-g~xZvgF+mXHD#ZQ_UCt0f$A%nkm)coXYmvSE#CV^ zAL(Uo6AH>h^lC9x_Iyws6g z8-%ZZtOOQDCsMB=1ZF)tdM-SRJJppwg~S$-y^tzh%D7?&&xlxFmGXVu)qr8U_;B`S zb5i9Eqv0B#v3_bf+JY)&EsXC<5P@?c+SU*9(YV`0c~q+RL6_eYBMqW1gl&B7>12cP zw+B9VkS)x!Li_^e6#@~#=qnP$J#nvOin^o$>CQaO1?dZED7fcg4<1hyozvmBUi)z~ z>apl+qB_CtFTCT(8f)1aPm|R zYFd||H63}=ud;=Xj?4e8VMUwOZm840PK_CNBrwbX+r~T9q_<5-yZW~hZfcSyDdOv! z{2QxO?fB<%Ysr+t;WarW96$loifjKg&diu-n$iI-C43?P#A4LPc>4ZzjQqEsG4}0} zH@VaMD&4wz>aF0nw;W-kUbO0hwVahRGTmb)&Lcm37Rx?Y_IWF^4~(i6I_Xeahg()LcG7iFF z;@`7s7VmtRs13jDPTPsPkDa%H9?6JYsR|y2kwRWTaJ0~jT^QIl3gh3t`0@So`E)A3 z3Tz=SUm>kU!>D_t0CPAsUd#r4Rna-I}@WZ!I9l84>PhUtNQ6%k~cg5wJSwYa*=ps-|xvAjcD z$2Ud?gHK??mmF6su4|L992Y-P*w_A9D9g0o_pBlL6Lhoj!OUU}wm?)%+ef{IjMS%y zhEmi;ja`q^1W&kE)8Qgg8as;5PRN@R*A6abtb4X3>{SWY0MyiJJ}X=6vwsPa)VdF@ z+0DiS5d?DwReMziZUH?_Es$C{kamrqSM&s|0fXAa=?QtxIZT0|KQMZ<_%Z+-x6KD1d-s~lBY=SLp!}hufP{ZF< zpi1NO&#o@))oqDYZ&>HLWkGMMM=cbPE94?!x<31Zo2i%#u)CF?eKMm&mkl&{Af@NpP zGV_YSyw+m7#;^`S^d%HCS|0kyTuj0C&6M5o*4v>1>7YAVJi*y8JC~c_BtX+-ccvI|Ij7&X7EvOEdvq`I|Ma4-N*iVsOE)CrAo)4F*W>@m1_ad7i%wJBJI7pIDD z6r2nsm2FssTP;L6hI17N#tY)ByU&;klRaik!^C}(n%)IS-d<<<=>X@h(MSikP6DOj z)7X0wW#O$ylWs1HZ5eOThSY2raLu5_Ux(c+w_?U~#ZGPDS$#Bg_@=A@%p9KFGu4xu zJMRGk9LyA!nPq}wFrPh?;75$Bh?;3|pXu8fExN3Rn=`&Hc_T{q^s{Zh4GA{7rBO<* zLUp&fcLx!}%w3*O1>c?>kWrmLeXQRD1w1G+N;>o0&Ir7XE(Qy0VQuPIgH8x51*okf zD<$uZY@U=y#gSVyH5QLbJ6`V=%Hb(0f`NF{q0^)0rFgDj12vt-dcHhH8&IZ;|-cht4?z5Z#?{ zJeUsE2mD68&_5hr9CZ>fB8x`{M^mPggjbBmk@Mq;OIcrKLL!@B=W@_0&l#92AAfla zqy^og3=V`jrUpF#T1@GAPN3Oy{~)Nw?-SzAUdILUSUtJ9=^&+!7E^KGs)HJvri?)p zp#Qe^zz~P-9TYcigXuEr3jPdeNCVkLn1tA1q;!1tY^Mx6#ck`FEU1+a8GlFvRueMcW}Pr z$BHBX=v7#qLZk9-dxUSX(lsZL7@8AXT3CuAF?3c%P&9Kr z7wOnbQEb_R1UL5lTTLkD0m+a`qx#{p1d1*AK_YAHnDmon{Zu>OFc1C6*pYvh)q23n zzQBJ`)x-*0U2@E*ZLq>!oJ=F2j#l{(v_u*BO4h9F`D|=UnG{3_uEw;&NcFN}XVo_M zpZ)6WuYc(mOu-(|+58+Cw*=yryKw-H1(qVFWQLF0QGjh5Ur$>Y9jBFr6uKi%EN1*i z@*5KCzcLqd?o#OL=&u!bVX3D#Qz@B^kskZ5L~Y!>jPsfkpZfA@kTgFHlQl3YW#Y#sJXKsjuFB0TPsJO`ezUM+6<*u9I<2tv~Z~JEG-1ymcG~D$ZNP zuqG?vicBTjU?YP|g>BO)Dj`3z;`#=(k8fi*wDN*>QWwdy+{O?aiTW-~SrIX>xCNOp z`{1kZ7@|X`_n@oQGlS`(8aox$Elr*<>rEig1rZZtB&>_DtORbHZ1o-f30=FGtbILO zr_wZImqR?9X1v$XO9nk^6!`DKo@DraHMOmCH^4xn(5AofN^H;yW{BzG&~}cMHWx(i z*gDrL_}v{#v1T&)WizYJuraEF1{Jw2bo;U$%ODcpJ4_u^12t)Z;rV>Z0D$Z=giYrc2pkwGc?2>|CWKekL9$|)R zSN2bnXF>#wqC!MiAgGGhO@_?#=98$4Kq@bn!#5&Yc7qv63%RIu)2HskbJayNa< zkAwHqeP-p`BIkjXr10!jCuz=r0-}^$bWkq6$U8B@r;#99gQZPlRyB(9{nTGa@qO7# zVOr9Y*I}}ft!ZA*z!x7t8F7l?cE3e!f__kE`9^lc=?g|xwN$tRO;M11w|vxb@vHC+ zZP*5<&nclG7vA`gzmc>tm<##k7ax-2rV;f;)UDLM?0Lp@>xF<|HG5x&E&+nmf&L(b zc8fK3+z}|M(<%LTm^syT-8`S13zQk=iz-ZPCDqev^ZZm)o-l~5(~Yjln@FSj5&Jp4 zsxj@KR)0b4!PY+=4Vy{uZE9{T6L)q2!kY1n4o9^e!t!&~LZbo+p zVkD)VgofU% z!;<}$z$~t(7mZ0qdCR70$hFSwa_dw4h%$JcdXVjpM!mx7B((qyBs=skGFW#}pwjZH# z`+H9KHCTNgL`NHd<9k3=37ScNXLMvA32|u{(2*Y8?k$bIrJRkdwpf9S`5U%GbH`POm)T5aN`9Pib0N`z9M)~5Jzw!`?F6=r5!uD(AbbM$G#y7HXBulQ+w^wmi5IZ@~qG=(Y!PuS0kIIvSH$SSZpwJ5V%+318rDqBwdZq!) zLi62s#Cdgrnc6tqSs9>w<}2$Zj{Av1ujFhKZPt`0-=d%AU#gt!-eYFOxiY3sFA#EN&iYQtA!q_^o}u%Z^aQ`Ez@5 zHlqo$XdbA4*l6l7%JrFM#&rVrV#QiYM6U3f|D8#YPR`wQth+ko4yd`H*XIjGo)xxI zo|XaP?u=V4tjaD*XH>&NUHg~_SQ!>lt`Xp($~)IP$2-FM9rnW99cP&DQ^X%*jp@o= zOS?Z)P#0}jL=jm9qnMBpxME+~moRA0iqJ)zKyZ70{yfDcsY%B8ThVEqIsIOLRu-*s zfX7z>IZliAW?UyTGF|h_GdbTuy?OuO?!OYCt|x9?BxB6sB#0|OcgiVhr|SWRlJfHDcupG(p!o?LEFBaGmPu8y6bpI__~kRZ82 zWvfyv8QCJuz1vb^vd9X;&8^Y$FWL9O>W0kV!2j$s>>PN>p@}c5JAkDVOiHMpk}4cX zQ(-H$(DB(M2MN_=XDdM z5%S3+N$q+nbzf7SeOxIV1x}gcLv1ky90hi=E=d#r0by56gYO|-^|1By_x)ogS{dkscAm>LvIBQP}T3hA%Xd{iXWur`tgD3;XAv&FE*|g7b%4 z{v|`!d}ssjs}b9)j@oIA#IDzL^R~;G?z95X&|oF(0}WzZdW|SBYpP&dKXQ-3{I4xJ zDm)ydCcZ6s$hYLaxy)mRpqPRjQ|S!Sk;JhBr9x1iFtFHZ4Jlc?y1_Fz5w*#gFru+8 zVA{6KJ0}=1HQLlcxGsuMf(6%m>(%y2kUR1*=Drh(DC;A)4q_mGZ>h4cI{l6MrkXhm zo~x;3{?&hRa@3A+PQF+S#MQFKbw{K~ld`7OU>0V+DKmC|IeStwfnONaf z&F<2L5R9hJ)hwH#+xt>%tz!4aF6&563|D_w%IpXb=!I`R%(T*g@r%Z&tY=u8HO zXw_J~1`>+r^rwsKCcI2bjRc<@rXU$=n7uplt^?{SuV>h_)e3VJxMs(cR7G;mWqrsn zg?j%0$>QkhhS%U?}mwi1TD^|lv1Mal6MpSd4L(#NRMNRbik^j zvbC6t8I*iSro`Bje5v7~x?q;IQG5khRIqje)AK0n>2;C}<~)j$P~nrtm^%9zlrA;O z`A*z0%XDRzF-v|?%?wDDcUm&uHy(?yQ(iPmftq;X<@qQ=)qd?s@yqV(6gYp&IE%tv zmfB6EMi`!a7>_qR)oixIBkgW>OlNwdAHNSDJ^8p~oD-xC&&_mfeeVc?iUQ{ua0>?f zZ#`zdD+1?Z79g4opWLpk4{qLJC`z)X!Ca!|@DQ&^vx*N2oYSl@p;1l!FE~qQ-&LRKJ>5yEmB2YE-uzn^;Bi1vtoR=- z&z1$Bj-DgdBbZi}e#W-5jIAEF6Z-!e(`Qdal1s<8NQ`rj@mepFr$@5{+4uSjW5Q1! z7lwDj{KE`Mq}bS-8zn`fq2k>e3CC=-?=r+Lu%bR&yzK4Qf@UC+B`BZM4yP8Q;eD&B zk#!uTpwLLcr-|13(PXyR)HXb8Z#*TKt5h;9rwWPn?wOMqmncm}q>b4Z2cHFTBIz4j zMxQs_%y((yAMcs(JQAyqF0E&vcs%U@IdkBHW>M^mwjvm;N=D(0-bx`}X^_0!R6ffc#BRw$*ud z>gGP*@kzk%0qQ%Oddd1ciQy_vJ*7>n%M~yzw@NW};#&cbryOH=`960be!J_>J}hZ; zty-7a)VMY$}M#^b!93%em&l#=>#jQ~CKbMP0{v zq&y!PD#3avosRVlKO)ZwJrN>nKh6rsryH}$X;OrVf8wN%`#d=p)(^3UxFW2QBV)MM zTOy8!z&*njnX1L+fZfA259thC*B5E&dX#S`FU!Y)WS8M%^MXfWgPwxraBC{`%!lJ4 z`gvkY+?cscG5Gq%gKYRW`#s$md?E}@iPIOws4JYXHa=oQ8$5Dul%fP>WP0LA(P)Q4 zGmkB1T2?>Qg}B+*$s=^-v@wl5?QKMdEIwq-(9PLi_)ERdAl?f z*YNYpsq+uAjyICoU};^3O)j@D@H^tJLn)>@&xt3tGrspf{Wa|r1g;}=edz!$Sc%{9 zJsQysGa20UdMP9E)-cE_u`0GRTGJ3%<~Wf9@ZF4 zH4-0X_{6Op2a{?^#jjZd_6j-jSnj*tP+;8OZJnP_Jv&b1@nM9fpYd!kdnJ|eepht8 zaKcn2Jul^aS&6WE&l|wS@AN|Fk8b-D)=E=4sXXT0*(0j9d@0=_GSpC*q1oT5uOPl9 zM)$D)ebz%aJoH|I$-Vsq2*xh9I~{tOU@Qh=rvm$sPYZSngx5#_i#v@EbrqbkJMg-N zzHg?~mmP($dJEA2)rlIQCGCsV%i1uE2lS4Q`gi7kHK^5M;f#tdT*XE024a3(Mg5bs<>0{^+{FVN%fq~y%L7uI4IESug)BXB zHZg@qEIF>z>^9y$QSjsp(l(4Ygsk1F5 zTgmc)D1zB3S7Tb-mv=g#$0>Q%(+OP7qWkwM4*#v7@xcekkrqer0KE;p^Pb2(m| zjPT*je&kJ2wi@J|E5Nq#SAwt3Gh_r&{O&(laq zP=X@*8xuT=OBr@~FoQ=`;>)V|tbe~#g<<=46K2z!uIWC{wH=CV+(zG%i) z3bHif(Qb$h35jlSd7^zHhI%tRmedqcrBwHfcE&7;usKsw$oBUrnUF8=x@XHQ3+D}AC$UE} zP3P#&iqVI^OeHp|0Iw>P80bM+PJ^i`P>&?T4L$`=;u37WNnM3NgKD4+jPsZByj^{? zC+)$Dv+Yd?e3(E{2EGgw?`O`tPO46mFK#<#zzrG@%moM0X^C>Hbt20v#zYK_-CNQo zy;2M1uR2hp+RRcbs-WDr_dLCPqG$dB*lZ|+DWkTXchMz@hN#XtPnkz?B2xxo zVWsHKg>eXvNZ=%qD@G=oMid(;Ep=x+wnO)+bMXephEKk<_+VO{t(VIGMaV4ONwYb3 z$I{4&}tgs&V(rk%0O)_Mz{W_5`B2t_f==Aft$GK3rKxz-hH136=n9nyv zb>Q?JDow1mHF)$P6MA|MCm?)|w>JeWgfx+FHDA_>Otss^4_l%%@j@d}P^wk;0vjP0 zLR8ZO3M9x3Nc#pY{xWp{DfdDlIXFDr7skQdxR`hhkFJd|R2V)yX^=uf6n`o(+3)7_ zvay8YK|mS5ha$6T)#;tZd0!mwpyJKLCJ;Ct)GPY)GCA8ji=kuqpKF1j?|pc_bW{BC zs&g^;-`~;Fru6YU)gfw$N%ZuJYUV=EkS=)z>JkP)Jqe(dcu1ALAMHMsd%nRUOe69$P+E_Wl8+i|); zEJPVAjNHBpZ>`DAo$SoGwJ;K=$irEOR1vf~@iaU%l_>NfiQwLoWd>=^sqg$>j5@3h z-3WjdB)&&Iu)~g6ppB>Hm#Zt?U*21+E>?W%n7thY^Q;u+fmYmv98g0~|B+OzS2Nps z!(F?RKub^bVG=L2x{f2bjME@qv?)87ECuYS;;#;iFGo;uS#e37^Ca_Ra}M z$DT^}-r=nv|G1>=Xd7;f;=OwiBJ!A9Wuo-3F}vLeMm!Fy71QjTO9feyC)U9Fr%-PVYb_eb&xPDht4Bb5EPN~|N$a>?FbM}~* zvvDO;6S#*<%~vArv$ctw?I;(o&Q8F^iRKpN^I+7RtIKF`RKb%#fys5HrO4&f9WwdW zS*EKu7s75D|7B59DA)erS(v#A`bMq&Cq@x`aPizeG8AmS5a$G<@ZvgdFS|dM(RaQL zqJ)2g+Mc15nsy#Wn$>ag%`|<1$i18-FKQf=bVZE5N-^iSSG!FSYPLK=>B$ajx_3cI zJh3XWmqeXGL-zjB@j7n!x;SH(JXj?&w9G{@kk&Tf3n;QUHrG{9!IH z2FmF0B|$HNylHo6_`l=HZ8jN%MrtbdufK7iP04tf{~CzsQGtV1QS?Dpv*Yo*$r8?H zjLT)X$xkfmjoOf3fqOs1MS7Z>E=hdbwe%4@_HD({^=k_mFk9n7C!k*8WNZD8JbX+B zg=bUtfxx5&Sb^~n&3GVU(kbWHoD-S>DU%xaggXI5afvHk?6S&uW!SZs4Vrc}EB`Fg z^MH0LIP}yxzik!SY^cFs4DiBGm#a@UJ+fl6B%I*ga~eePUkTS&Y5(RnLe)Ewot4~- z<8vl>5%8<^X(+&6ZhlMW_L*DurYNj5!`QyBoHLV&2caJgjVPC)xVZv>rX|MT?e_`9YY_6FXZW;T24<7L@Nw%=m$?=Tlo7`&Gxo)iDsZ}o&gBJYUJ}A59&UML>Zl;Ar?!0h&sZ8Ra78=<6L>D zq7<{-gWl|3z6E zIv?G*o0XrM@Kk1yo)JZ#K)!)h8D3>yEqT4bb~Nko@qcOdZ7a}$z99eJK zH)S@ZX%&`rFejcQZki*%TE!TDp@eU4@lq*kK|z+s`(@6pw?ki}Jw5sP!gMG|xb?QS zctrchu~9XL{(#{HrNmsRbYvJ#WQokc5WN{)Zu0cuNncoqn6QV|EEB}H6-clNw1+Bt zvP^}cnwe8_QUKT)q@{ZdbNw;;hsfx8OUmuDt=1E;04s?ZShTF zaV5=*|HkIxzZAP<8cDL`?LmR@IhGR@^Rkxqs8|#z-7uMpZjujI?^}xq_g<|WYl%D8 zhFdb3fAV26-dbZ}Kn36Y!I`MOE*y-w|7_fvDddn#>?h*WXlESpb;!7d4P%$iwq=eo z43sR%E--4&uw(b(3PtYB%XE`iS7xnVY^Co&UFstD`e`Z%jLnS78nVl|Cb|VE{eyug zlo(BF;*CBk@1-d?eLUSG;Z8qEAYpbyAE|S94J`#&A}+?>JsxLGeF+6JLv!3MsK4gE zB$Ea6e)<0YS&D4`iyZiWw-hBMrG@{?QdIswS&Ga*lp+%oAqx{5Au9)~4m3c($;iak znUIx%0U97=U@va+U%26aW`#}uvyPULkr5go;cQ@SVI*K{W^F=94-HUqHnCCt*~kCU zQ4|0O0fYe}08xM#KpY?ekOW8pqyaJjS%5r15ugN62B-j30U7`UfPsy@iKCN&tuesB z$;iUO*}~e`wR3RRKP=$q+rrKmU~lc>1aSEABTbx~Eq?m*-;kuSq4j@)|K9k2vn8DXP9`=M z|LOaGj{QfQGj<9{L>2~J4X|ME8xEgN`R+{quu}RQ2v)X`M*1q?ElNz z^gj+I0}BK5|G<-sgp5qAKWD=Km!V{0Vqhiw@6Z38p^Q<6Vo&zMAYV7r;%Ge~$Ha7+y~}a>{gLBRJU=1C`QKxJe`z_0yO5C2%(1gS=C4LV=nP=?_@Ape z?a~33>p%p&9NgN{zW<7 z6K13qiZku+5j_q-hclG7kYX;^CUa#2fj$mwnbq81|0aY?f7Nj{D5K{dZYfzWkRs?P^Lmsw{ZC(WBdP*gno-biSD4XGFBfWhErUO#iqhSOY0=!3#cIw zHmM)kqr$HP0&D3IBgB{`!QQ5-;Pe?_(}RkEAiF61!JFizNS0SY>WfKN8$-sXUN^;`c8Kn|HQB(l`o z;S9dT@OrZV7T^^Z;JNmv9CZ*-JFuNjMP|Ei1}8vt9>yj^DO0<}s!xW&apg5PU}P)F zaeIWiKRGNYasrURwv9_Q}|A?ND>A`dqvo)JD##6*Fz}hYiK~13Ope4{ER{6Kjtz?Pzlz?_bZ4bG5do zqw6nCf7XmFyWx@iul1MgL>T8I3)`d=JLvXUNe71N$~HA{Yy5w{5%b^X zW6fDp<-XaX{%(_mrrS)3Zx;tvJ~VIi1;ma zQVOdj-IAx+u|DNy`33k6-=aLfaK{wIP~*O&Pt08N#yu@k;L$!(yjWy$851Xr@0vgD z=@nJ}dAy1ZD&W$P#4f}0C>`^bL6*{H-Mg)B@EGg*TIBv}{<~6HafUhusxnwqVT}TRnH<-Y@+lv45v$2=ui$^G}sdiP5k&ZS;Ia`jidGC znLGy6*8I+c68Ny*?X)z;!VsIcMDm|$*>dQptP4%6EkK3Lwq=Y9$`M*aDeS;J!=bq1_Z&l&=rXglGCYxF^zwKo@=d*R%%x+~)>anV0)IEu+vR?)6 z%uFDQtsM0Op#<9eeATWjQ-Pu#Kjpho7BpTV`h!a$7S-lh7^n0%p121$;(D3`? z*J0U_QkGRy-IB6bw0P%R+GW_ziaK-(xHhetkc6fb^OM-r+j>_dxr5tgHZR$c>usA1 z?^xC`{b_7@t`B}W505>WI2SeRP-h!}k(J$I{QoKKTcD&WuC<@9LiG`dxS347*NM?N{yk_O3do@7lJsdCK8+PhbD} ztk=)k|9h8oKk_G2>K0u2&u?zKX7%Wi)4%=T`yZX!ymM%{zUHaSTRnCx|9I0cdhhkh zzg<-SuVE8sO%1-e;ZNK8ywHCcZis)d>W96C9=mYUiLXyBoVa=65u-nPWn9BAe)PbE zEw68Ent0<^-@d*0!YNapJO;bq(k-L@JbF^Mf#!r+@tqPaXDPX6(+#FL>{& z`@i+Q2iAW6A2&B#aquIr?7Z@dE$0n8?9M+e+5Fa~jc0yq>l?3b`PETh?X&&*8^3t# zKW}Kf__I^rxqjKc3s!C4HQ=naArH-5KCCc*o%Y7e@pY+VIb*F9Lxc`4$c)*}v9dpF#$89?3l7+ke-e>8k{-b}o z=acmhK0mmr$Gt zXT03}=|@|qv^@UXhFxDdNh7J_>>T{;a{7(D05mV)9?HzZ+h>ReP7@8 z*`j~E@~gl8viG|iy7j;5cZVGIjeq>VhhIGX^ry#9IcGw{8TX8Nd+`;=&;RbGNt2em zc+bAaJb2lg>xJ0SG@Y|J4Y?}-sDT0YWrO@XWc=s*7SJbg=b#qyS-`QpM!gcE*rk%xowjd zocPh$*GI27W9gWuFFE{%#UITbefir@?(zO@eeT)2_S&z!uxr~L({>!%f6VVcKk$I_ zjy-OlgLo;Laq(rFe|Fv8_nrOCy??yl^5JLRckaM9f3SGj zz5@^a-H;C!fB%VB2j2bl!otF$-)>+0-ujgrciiyOCwG1RcJ`wQ4;9X9T=U#zlY1O; z{+vZ`O#RdJ`U&%oni|)wpL@sMzq|0Bw{F<$tVNfO`fz6Bn$0VA-E`-&o2RU8JNQ2z zUvT`6cmMR#z&m$s8TaxvJAbo!+4CQqaKo$J4j9q<{++j%rtLg)j}Pb64IQy~(6-aB z`S^~X+wye<`*yj%f+Ym{M(%CC$_8}ea0Cd z-m+=`WgCtqZAZzjpTfzv!4ft$)v_<`j;e_|obt-q_sZrR`InzxLhV&;3!)*@u69 z!k>HZcW~c>4!Lpv(b=ZG7X9q}Lzb+aFm2tTg%Q11y|ekUD<-^q<9pj*dv)yvbLI{_ zAsBe}>PZ_uyL#Roi`KpSz>dLFFaGbNYqqUj)?>xPD@Ko>cHu3L%$jg+<45n^zr1DP zki`dfOn-Rg@8%6TVCy>%Exq`v?zb+w_pH0t_P*z+<-fV}sVOT~u6^)3UpwK*8THGz zEIs1M$%}6M{m@$*ZH$CP%zvvTExykr=|N8Lt zwL`9X@QANG)_BJ!pZy}}UUSex*WEhcgqt5dyx+d_M!xyomEAL?UyeCq`I)zMpSQu3HX79_U zUicr+1nZAKZ{}maetAjuJ1-x8?@Rj(oP75BC)O>xZ~X}TyvxcDo?Uv~r}y_+x8?g= zdn`I|_ui8qz2XdC=3cULt*$cn5ktq18eeZRcjVgmzW?O*46?GJtt}mc2DM(4Ij3)q zGWRHx$8R9SrTqVY=AN&ZxsT+ZJ!nZ&*N)m*lwrE5B_)z}YMCqMyyBuzFl%DRoS99T zTG9bh%Rvq8O(a&Pwtn#7Q-+Ly(1XTtxdKEgIkYv;>}YMvesLpZr_@jv5m5Ja$v5^j(OJ7PKjLa%V}rW(38%p9|m^DjQ3fKM|Akf zInIoKr0f)opLMc>UjX^i?8u*05x!jdGQKQ-&Lqbx^UJB{q?6s!q~u3Aa~Rs@3Shjl zeq>oIEPi?KkpWloqr5qC+$TTHNadu4*a{5yzv&Tr$#U(yvF=5&Dh-%T16sAqj9 z%(0;}VQ3}^Q6px0Y$gwjtQ33F2tUmu7m70}+}bZ`lr<7Y$s|#1CW}lY$2P}I*pnGu zxo+o7MsXm~BU^w(GNKti>)p}xhBbOt$MohFvJ=PnOtJw{)X3z5#6^t>i58L=)waPHStr5UncuFr_SKG8_wnay=MHd{Yj0YSTqvlX-D=9%ft& z7nuE$hf6|1*-lC1G~DHqe;I|O%yJ+t&y{#}-@w*MKtjt|O(fx2(^nNaApx>O>5eh-fs#oH-iGIbLiOj%qiL2!-c_{nEkBaLk!I9LXkl zHIB%bR;%p zf}gFCNMkOCCQg!DGJc0|B?@vzVl0g|W{~-@ZRjFx!(iEj4D9r@q4im&kfO8#MjC-alW&O`~R8$^~mxR*OyRJK?G+wl8q#1X~TnT zI)RPEHK}q)`3lu|KuuV-qJ%W|NGa}ODHOW#fSXQi6QtuLAS3-JF_@qL6Vnv89`u5` zO9BW2*Iucb&F*QtLBe{cB|Rv{;9LdWOL~_hi;$?PQyIjTJ4|_-l}hbTqVe)MRpI^UCy^ z-j2Ki_dZ%C_v@Pjy~KhFdbTDLL>wVS19}7|1c`g0 zj=~x@F|zfOisgt9(fB?Y@@Po1MR$sr8rTm7s|9Lcrx6WBG?>j)G?dU_(qdaU$)7uY zNk~ZcmWH!OAk7+7>rNh!kxHyt(LhEju^Wj78p^;>(EuZbCT$T7&~9jwib?`vOh>*T z67t!>!Dqn$h6)3p957U9!lsx4h6+u<7Y#5}7`W`IsZgMmc@*~vg@(Li=G_**oPa*dNz5|H?F1S!<9ZNUC=ZPkFMGFN)?#yT;us3JCVx!E&yEIbx)mfO%LdAA8t^ zb_0WG+!-(<9dS|7(V3a{0s}i;I&B4(`OMW!Y_a_yUCt!#m82uyXb!uNvkN*X$6A4% z9WX**%D3)FS(-jDc-w7Z#sZVFxGe$qF_^_|2~7*59@#=19ltzJ1kQj3I^D%;Ar4H2TS-vn(vdU* z->yX~;2LWllE+$jRtw2va$G47Idk0UwBQ`HCM~KYtl?8gE3mCo1o7;wm$&>fv1~OphSFfyr>`NJ_mNFXjQN#HE1uywKE>T;6#12rZCQ<}FWaFErIC zw-4_tVW6XW5Su=o33z$5n0EKjl*}p_mAP~zrCzS2R5+<7Der8d1@6im6qq+tZ*t|~ z&>x!WsB9q}M4b@1JQ~NcFw*;RP~v$^1-Fu<%%vkK^>QWc0xuc7=7}+cyZ{)r4Gh5Y z#FvnE`oPM}QYk}PiGe2=gdBcDgFPz<$qd>uawk{DE|3!Sph)V0e$+&f)Pwz~iOgnI zj>-a|iTu#YhU_MaNFHEF15!w;iVPE8rNAO4@p7u-zcdO3B@Z~HCW=ZPbciPQQ;qb{ zLh^c20kn{~R$b511W9X>gi6LWd`5R(-Wo%z{8#1xE#zPZmsOS(Y&xQHH`kTB08GRK`Kt%#Q4^WZ1N6{DEmkUSaZZLc zg=xtg88*3WBiJUxngh;C!WuqRH&@s$P!rfD!xnUOL<z%g?BJeUB{Vy$L8vZoX8-hH%Fygy9!!ZAas&^= zLJK*9w+d0#Aam*1lzO?6RwyHt$0$&|h&+G|9Kfw2tB!5;frcXw!U}oMjXXFiqQF5hAj72&y_jDYavVsFo7gKHU^*{urvG@qe z9Scj4T6hPqBq#G|^A=Gr$D+ym}&Y1mJSOt0(f{#Rx43m{D?d&tU*f#J4%) zRO7*YBXbZdo2bQ{5mXS?Fe>H}aEXVmVpK3rM)d$)w2)CfKo>3K*w!&c>ey%@$M!&A zv>?Dm=0sLXiU1c?g}~?yE`_8;Vb(4{6UIQejLcEDI~IFs zM@?mS$g>NXY@m`88%Bk=qQK-_gYYfcJbR=`E?nE@*(0s9D2qArNKc&@0+B~rXTDY+ z@*xjwjCk{k4D7BfDwOL;O1)gWc7c~L4?B>Cv=MKTkq4)vh58tn?#^$v8xM4jxEL0B z3ae-#bDLx4N|G{{j-=Gfm9z`66qyargXGXc@_3LOT8KA;mWMyHC{V`r#g~1JER8@=FJZ2!F|+1;mT8Fq$Ubi z-V@VKW}sI`PVVJO+67XgiO6mq=toUtIO{;QJTsaoT6th0^`dBHownM&XeaVOM(RZi z-(bcHhD~^t5{qgupM6!?Txk@FB%V4SH6fJbJ-87~q$W=dnOb1Qya!TJ6Reo`U`lGj zfO%84t0FL16#}E5V`AP2s|y^!j(HD$B`#pcyr&RIO|WC$Q?#Kb*fH-Z+fWninD-QJ zs0qU4s}_doA??)Y=Sti~xrs(0J9=ciXkC7=IOqEn$@^211+rrDGMQ{5E1H|1ig8lAxlmDA zVB%E{DJAX#T9H^}Mo(TtO=Lz7&Zj0aqX+0y6PeLd_eT?^iabZt)Ixf%dL%$2qrVUs z{alys3S?m_vZE&rATDS%dh!5jB0G8#0cs*UdNKiOB0G9ALuw+uS1lpaL*P|PEN(aP z#MPZTCOdkH$TR`j(UTfd6WP&|8lnl~MV@;E)IxUjB#qQWdiP%CvQ`qYDg;J9$Hc78 z>H-(Yj-G=L;)3kxIryL^vZLqV15MCUWNt@D?x3V7c{kMIn@dOess|!8B^XuRTxq*F z&&y*X(z&MsPEDk9PvS&Pq$5w}geGe7oUfpTl;_D2(L%a2Ibx-NWf&FGiXDlaw3==C z=sR!SY%co_pH=5Qw|u}H`M-7P+3G{?Z{0$*TFCo72O^x^2i3s_GieK|l6zipRpdkm z7?r*cnO?z5Ipcgf@ZbzSKMp)7BPQDf9*hywwi4?x+x}BvY z=qxSAq$Fr9mnOO?4T{U9;irAp#FUJ%kA}o896C7zAAs7-r`^CuFY&bFy~dr*4P zX^qT#LoO}+I1OMbmsVA*1`eFL^uoH+K-Nh!ai@WX(x*|@Bg~#HpgKxra8X4-4%@kO zYp{mqu$@bDL~5`tXk0BRi0ej3lm;W+2&ru6b%%w^7-k$#?Rb(bSPa~WlcHgqR0!k5abr{avzf5o@uQu({BECo$%O%9>Tv0-#!=$rT34LJ zD13jL)f*>;x7bwK>{*?e5Z!E$kfSB#N^I}5$=u0`i<8<}oD|C9q$(CC3orJ*eU?JO zoN+sFlTvVvQBH1ep2_6Nn>lfEdL1W=B2J2HadOZb8;~gkx2D2+vL&ZmIwBiqWG&R5 ztg<)(q;Y~jmDrCniq{GI0Wa z;$#bqlWIqtlr~~h$EY+p>UXZuDTfs<$2p~#J=s{}WwP^&M5g2%HcnFDI7xWpBrk}QWHvU?+@4>=%5))X*Y(7!1b43V3pDu^!|cC=^WCme!iuvGi@1UL$9BWM;KD zwPj{BwBRQcYUl%xQ{iE~YHA15uP31U$cC{^<1(|GJEmmtGYU;@ZB3IhGw}lrkfx^g zw6@m9S?4#k^_tl@36J4zy$A=&*_zrBO><_qwl%i*8a=pS#`HcJOw=bcxV04nG;}my z*p#8)KWJ!dCt_RcEWA$N)Q*o*@}$Uc>hQx2nO=3r z^wQNMW7`^L&TMMLrw|*aw>LqZV~33EH+0tY=@T1TS|D++u~VAcGx$HldY{ah^h*$} zEg1kL+!!kbaVkw;;4nN6EsP}2@t$C*wytSnb3;o_X4=dKe6zBtA#-8UJKrzcFI!`M zVc{YutXnn{7jxaR<^M7WQ`j#iWy&<##_7LIOG3lPzv$G~rUltzky3S=Mt@Tfk~B(c z9U4AjMmv>F!*~T+mNpH4vtLOX`MN{P#YNg@Z5qalDW|Y$_?rtylBRgh6|>~|_H!67 zPs`V);ctFDM$#x~IyBsNAn<3?XgpeMHVuFC3&@g2;mM%|IH*F_Ytt|uzdCKx@Hd~h zNg4%LhZe*!;TW5S@j}8hHVuC>s**J68(F;XM7zKJ9LD2UYHb?+E)aTwvtBMx=Q-SPrj5_0VZ0*U2eD}wFGop+q!9vhX!yjWIA#ED?;~Vcb4ZJX#mNd2A zqC!c=FpS5aY7u=4l$S`Fio1Ed^e_AhS%V~EKXAh%GqR}-ihlZ6Ub&v5lYjmE= zVqT#ajK?K<=Q+T387DEGXDtMLo7U-@#TN}E&w%@KkHUC-{aW;erwZ8+*(ot{o{I~Z z#ie09ex1#EE{l%=2)jXEIEUL8s^?EF*?ln{e=@IL&p+P~eRWhaAQ!pMMposB` zavfm~013sP!X+3ltJWp@de%ot?%m*zzinglf-miqBt`-+B^f6Hkr3Vme+7&vd=ldo zm7k(7U8=O_WymG^0ygm-JNG$U&5(YO#lEll;_jBFg;YUt$HScnDF*@vrTpT#qQcLl zD;X1EUyXfGE|Ru{-^;ZR7{(PQDL03hp;o7t;;I7P90nNB* z72APMRm=v>BZrO$NYB+A_>h!b3xJL#z4nXzJt9XAq#r6z!57a|ya!F?bbyme2S9|H zKa@tK-3Ycz-@qFnDkg$PMPk7-pPWdVj4uRPRoq2=!!usV!?VT=_~`* zGsQD5f5~_SPg8p>XjEwxbD$WcXeE_@APrEp5qv32Vr4*JRIB88fc%QT7{*l3>6`># zyi$7rXnM_Hi&y%K`OOGd-k9&u30kaTETFtzAIQs;{;-A0dGR$Bm22PwoGNz?kcTQ= z!R?i?Aku4$k|m8XEFd=ekkp%X%9JkS*0K$S+V1$+%h$pIQ2U5N4c zr#2)_?OXU#j@q~I$s{_x6@5{jRx}jT6s;(8CQ297J_wqu9YV6K+Rs5#_#Ro5uFd68 z1dzO-1fXn$pXX4rVGB^Q<@l{xR|oj%WVw!D4Yl{+W|#6I&{XWi?xFn|phnA4RJjl; z&1%iy3r1?qfF|)SaytIG6<4-=QRPfwRMa~4#CFtywZ9-7D4jxmO13ZRye(?x!>(0LB8ma9Dv-&WOYrpO1lZeM)GTIvAbCQy41Xv)6$8mrphQ1exF zAADv&$qSl_VfajdIyV4K)iUtW02Ooaxd0V&K$F-zi|Uo~Nzhcj0FBCZguX@P_n>+7 zQleWJuAXVL&@_eD@Er%0AAzRuA3o}!@C!bItMChG3O8YyYhB^Cgyxywe{aNP)a06TU0nQiHISxEXVN9^BWFs+@9QfG0rWMp0#H)@9d*j4a#U{Mm zsIWI^%0|$io}-9Ly3`A3jPkRJYq&tF z{Q$?ml4o2nRciqyZWXUUQ+XcHkm4DaNfjmpP2p@@HdQzqG_@A!I7Rvus^|)5gQjpc zF0Lx92b#iq$YvDQ!@X4Hf1oMcx*`)W<2^s4<7hiJmbQGqY0x&^Kj zYMv3oG|#vZBK23$_mNPQS9XJz6}|_$SN6a;m|D{XTm+DQ3Yv=d1-d{a_@g6rxd(uz za0Ei9T9=?Hyo<83!n=Su3d4b>@GexP@GfX-uPxvXhLQtmw~_($x^ zO~pStVpjUYdAHIZiez#fVY^iEkG4=PhpwC9C_%+P&{X^@01C)>fJ{hX6+mU}_Xzlk z7X(>7p5CJhxCfwo4Y*0^3U|zvu8@)_UEyA~jCF{xs;*o>?xJjt+(p?OWlSwcQN_su ze!N}Dfm)=Jg940<8?;z8O~(T`k&>4TqWbDOAx@`Njt!cs>lJV}O390qPQ?hQO3SP6 z9nv*7Rgbo=8 z@#tL>XWs`+o%urrst$)^d$n(Yrm!Ahr;Z1>53F^i&)Nzlebxq=s>u{ep1roD?%m*; zCI1+dD=$h$QhzX;vIl5NFQ`PSJpea4RK2~3)KvOCjso>~`1xza3+iUlMkV|wd=d#x zC~XNeuJUBi_}7MP9pv!kR=K}{#^3F6p2L+Gi8l~n)tMn~p{qI}XzCsc0x^Pw>wln? zq(1`ys~S9LYR?18F3Q-6-8YhTQM%P9aSowz-4`%I=otn5lB^k_8sRxVM|n-GK{~0F zSQ)gUjKw$-MksRi0-CxX3!1vK4H_=5s=g(;E|F>A8l-##kUcuZ5w6lH>i5bDkF z2pgPOt3ao?j3fC&I;iG=i!1#V3o=&&2vhZE(D-W+u02ZpWk5kwIUV|zB-X=q0c|53 z5y(6b&*4Q8Asa1psRJwqnOD%QT)BVH>4L;6ps72bpkZ^A^MV;^OWbEr`a^0UaSk3s z=BUOiDf=R_OUyvmTI8MrnmX424OJsK2fj?N=B1Yl)N^Xzr|O250|z;BO(UI=`v>~! z^@gJui6`+KzjEpL5Hc$jC!td9LwKu8*#qB}v}EgOYiOR{)Yh$k|4i+e=DAJ$B2{gD zYikGIzk_}8{#)(vmPxIkLv#GEy39HKht>@)1w&9hDVB!NWz)ff^1z<_S;^z*O$4i{?R*a5p8ee{sgL%aPC?#4JD literal 0 HcmV?d00001 diff --git a/thirdparty/lwt-2.3.2/manual/manual.tex b/thirdparty/lwt-2.3.2/manual/manual.tex new file mode 100644 index 0000000..bfe4576 --- /dev/null +++ b/thirdparty/lwt-2.3.2/manual/manual.tex @@ -0,0 +1,52 @@ +\documentclass{article} +\usepackage{fullpage} +\usepackage[utf8]{inputenc} +\usepackage{url} +\usepackage{hyperref} +\usepackage{listings} +\usepackage{xcolor} + +\hypersetup{% + a4paper=true, + pdfstartview=FitH, + colorlinks=false, + pdfborder=0 0 0, + pdftitle = {Lwt user manual}, + pdfauthor = {Jérémie Dimino}, + pdfkeywords = {OCaml, Lwt, Cooperative threads, Coroutines} +} + +\lstset{ + language=[Objective]Caml, + extendedchars, + showspaces=false, + showstringspaces=false, + showtabs=false, + basicstyle=\ttfamily, + frame=l, + framerule=1.5mm, + xleftmargin=6mm, + framesep=4mm, + rulecolor=\color{lightgray}, + emph={lwt,for\_lwt,try\_lwt,raise\_lwt}, + emphstyle=\color[rgb]{0.627451, 0.125490, 0.941176}, + moredelim=*[s][\itshape]{(*}{*)}, + moredelim=[is][\textcolor{darkgray}]{§}{§}, + escapechar=°, + keywordstyle=\color[rgb]{0.627451, 0.125490, 0.941176}, + stringstyle=\color[rgb]{0.545098, 0.278431, 0.364706}, + commentstyle=\color[rgb]{0.698039, 0.133333, 0.133333}, + numberstyle=\color[rgb]{0.372549, 0.619608, 0.627451} +} + +\title{Lwt user manual} +\author{Jérémie Dimino} + +\begin{document} + +\maketitle +\tableofcontents + +\include{manual-wiki} + +\end{document} diff --git a/thirdparty/lwt-2.3.2/manual/manual.wiki b/thirdparty/lwt-2.3.2/manual/manual.wiki new file mode 100644 index 0000000..818af70 --- /dev/null +++ b/thirdparty/lwt-2.3.2/manual/manual.wiki @@ -0,0 +1,1028 @@ +<>.>> + +== Introduction == + + When writing a program, a common developer's task is to handle IO + operations. Indeed most software interact with several different + resources, such as: + + * the kernel, by doing system calls + * the user, by reading the keyboard, the mouse, or any input device + * a graphical server, to build graphical user interface + * other computers, by using the network + * ... + + When this list contains only one item, it is pretty easy to + handle. However as this list grows it becomes harder and harder to + make everything works together. Several choices have been proposed + to solve this problem: + + * using a main loop, and integrate all components we are + interacting with into this main loop. + * using preemptive system threads + + Both solution have their advantages and their drawbacks. For the + first one, it may works, but it becomes very complicated to write + some piece of asynchronous sequential code. The typical example being with + graphical user interfaces freezing and not redrawing themselves + because they are waiting for some blocking part of the code to + complete. + + If you already wrote code using preemptive threads, you shall know + that doing it right with threads is a hard job. Moreover system + threads consume non negligible resources, and so you can only launch + a limited number of threads at the same time. Thus this is not a + real solution. + + {{{Lwt}}} offers a new alternative. It provides very light-weight + cooperative threads; ``launching'' a thread is a very quick + operation, it does not require a new stack, a new process, or + anything else. Moreover context switches are very fast. In fact, it + is so easy that we will launch a thread for every system call. And + composing cooperative threads will allow us to write highly + asynchronous programs. + + In a first part, we will explain the concepts of {{{Lwt}}}, then we will + describe the many sub-libraries of {{{Lwt}}}. + +== The Lwt core library == + + In this section we describe the basics of {{{Lwt}}}. It is advised to + start an ocaml toplevel and try the given code examples. To start, + launch {{{ocaml}}} in a terminal or in emacs with the tuareg + mode, and type: + +{{{ +# #use "topfind";; +# #require "lwt";; +}}} + + {{{Lwt}}} is also shipped with an improved toplevel, which supports line + edition and completion. If it has been correctly installed, you + should be able to start it with the following command: + +{{{ +$ lwt-toplevel +}}} + +=== Lwt concepts === + + Let's take a classical function of the {{{Pervasives}}} module: + +< char = +>> + + This function will wait for a character to come on the given input + channel, then return it. The problem with this function is that it is + blocking: while it is being executed, the whole program will be + blocked, and other events will not be handled until it returns. + + Now let's look at the lwt equivalent: + +< char Lwt.t = +>> + + As you can see, it does not returns a character but something of + type {{{char Lwt.t}}}. The type {{{'a Lwt.t}}} is the type + of threads returning a value of type {{{'a}}}. Actually the + {{{Lwt_io.read_char}}} will try to read a character from the + given input channel and //immediatly// returns a light-weight + thread. + + Now, let's see what we can do with a {{{Lwt}}} thread. The following + code create a pipe, and launch a thread reading on the input side: + +< +val oc : Lwt_io.output_channel = +# let t = Lwt_io.read_char ic;; +val t : char Lwt.t = +>> + + We can now look at the state of our newly created thread: + +<> + + A thread may be in one of the following states: + + * {{{Return x}}}, which means that the thread has terminated + successfully and returned the value {{{x}}} + * {{{Fail exn}}}, which means that the thread has terminated, + but instead of returning a value, it failed with the exception + {{{exn}}} + * {{{Sleep}}}, which means that the thread is currently + sleeping and have not yet returned a value or an exception + + The thread {{{t}}} is sleeping because there is currently nothing + to read on the pipe. Let's write something: + +< +# Lwt.state t;; +- : char Lwt.state = Return 'a' +>> + + So, after we write something, the reading thread has been wakeup and + has returned the value {{{'a'}}}. + +=== Primitives for thread creation === + + There are several primitives for creating {{{Lwt}}} threads. These + functions are located in the module {{{Lwt}}}. + + Here are the main primitives: + + * {{{Lwt.return : 'a -> 'a Lwt.t}}} + \\ + creates a thread which has already terminated and returned a value + * {{{Lwt.fail : exn -> 'a Lwt.t}}} + \\ + creates a thread which has already terminated and failed with an + exception + * {{{Lwt.wait : unit -> 'a Lwt.t * 'a Lwt.u}}} + \\ + creates a sleeping thread and returns this thread plus a wakener (of + type {{{'a Lwt.u}}}) which must be used to wakeup the sleeping + thread. + + To wake up a sleeping thread, you must use one of the following + functions: + + * {{{Lwt.wakeup : 'a Lwt.u -> 'a -> unit}}} + \\ + wakes up the thread with a value. + * {{{Lwt.wakeup_exn : 'a Lwt.u -> exn -> unit}}} + \\ + wakes up the thread with an exception. + + Note that this is an error to wakeup two times the same threads. {{{Lwt}}} + will raise {{{Invalid_argument}}} if you try to do so. + + With these informations, try to guess the result of each of the + following expression: + +<> + +==== Primitives for thread composition ==== + + The most important operation you need to know is {{{bind}}}: + +< ('a -> 'b Lwt.t) -> 'b Lwt.t +>> + + {{{bind t f}}} creates a thread which waits for {{{t}}} to + terminates, then pass the result to {{{f}}}. If {{{t}}} is a + sleeping thread, then {{{bind t f}}} will be a sleeping thread too, + until {{{t}}} terminates. If {{{t}}} fails, then the resulting + thread will fail with the same exception. For example, consider the + following expression: + +< Lwt_io.printlf "You typed %S" str) +>> + + This code will first wait for the user to enter a line of text, then + print a message on the standard output. + + Similarly to {{{bind}}}, there is a function to handle the case + when {{{t}}} fails: + +< 'a Lwt.t) -> (exn -> 'a Lwt.t) -> 'a Lwt.t +>> + + {{{catch f g}}} will call {{{f ()}}}, then waits for its + termination, and if it fails with an exception {{{exn}}}, calls + {{{g exn}}} to handle it. Note that both exceptions raised with + {{{Pervasives.raise}}} and {{{Lwt.fail}}} are caught by + {{{catch}}}. + +==== Cancelable threads ==== + + In some case, we may want to cancel a thread. For example, because it + has not terminated after a timeout. This can be done with cancelable + threads. To create a cancelable thread, you must use the + {{{Lwt.task}}} function: + +< 'a Lwt.t * 'a Lwt.u +>> + + It has the same semantic as {{{Lwt.wait}}} except that the + sleeping thread can be canceled with {{{Lwt.cancel}}}: + +< unit +>> + + The thread will then fails with the exception + {{{Lwt.Canceled}}}. To execute a function when the thread is + canceled, you must use {{{Lwt.on_cancel}}}: + +< (unit -> unit) -> unit +>> + + Note that it is also possible to cancel a thread which has not been + created with {{{Lwt.task}}}. In this case, the deepest cancelable + thread connected with the given thread will be cancelled. + + For example, consider the following code: + +< +val wakener : '_a Lwt.u = +# let t = bind waiter (fun x -> return (x + 1));; +val t : int Lwt.t = +>> + + Here, cancelling {{{t}}} will in fact cancel {{{waiter}}}. + {{{t}}} will then fails with the exception {{{Lwt.Canceled}}}: + +<> + + By the way, it is possible to prevent a thread from being canceled + by using the function {{{Lwt.protected}}}: + +< 'a Lwt.t +>> + + Canceling {{{(proctected t)}}} will have no effect on {{{t}}}. + +==== Primitives for multi-thread composition ==== + + We now show how to compose several threads at the same time. The + main functions for this are in the {{{Lwt}}} module: {{{join}}}, + {{{choose}}} and {{{pick}}}. + + The first one, {{{join}}} takes a list of threads and wait for all + of them to terminate: + +< unit Lwt.t +>> + + Moreover, if at least one thread fails, {{{join l}}} will fails with + the same exception as the first to fail, after all threads threads terminated. + + On the contrary {{{choose}}} waits for at least one thread to + terminate, then returns the same value or exception: + +< 'a Lwt.t +>> + + For example: + +< +val wakener1 : '_a Lwt.u = +# let waiter2, wakener2 = Lwt.wait ();; +val waiter2 : '_a Lwt.t = +val wakener : '_a Lwt.u = +# let t = Lwt.choose [waiter1; waiter2];; +val t : '_a Lwt.t = +# Lwt.state t;; +- : '_a Lwt.state = Sleep +# Lwt.wakeup wakener2 42;; +- : unit = () +# Lwt.state t;; +- : int Lwt.state = Return 42 +>> + + Thel last one, {{{pick}}}, is the same as {{{join}}} except that it cancels + all other threads when one terminates. + +==== Threads local storage ==== + + Lwt can stores variables with different values on different + threads. This is called threads local storage. For example, this can + be used to store contexts or thread identifiers. The contents of a + variable can be read with: + +< 'a option +>> + + which takes a key to identify the variable we want to read and + returns either {{{None}}} if the variable is not set, or + {{{Some x}}} if it is. The value returned is the value of the + variable in the current thread. + + New keys can be created with: + +< 'a Lwt.key +>> + + To set a variable, you must use: + +< 'a option -> (unit -> 'b) -> 'b +>> + + {{{with_value key value f}}} will executes {{{f}}} with + the binding {{{key -> value}}}. The old value associated to + {{{key}}} is restored after {{{f}}} terminates. + + For example, you can use local storage to store thread identifiers + and use them in logs: + +< id + | None -> "main" + in + Lwt_io.printlf "%s: %s" thread_id msg + +lwt () = + Lwt.join [ + Lwt.with_value id_key (Some "thread 1") (fun () -> log "foo"); + Lwt.with_value id_key (Some "thread 2") (fun () -> log "bar"); + ] +>> + +==== Rules ==== + + {{{Lwt}}} will always try to execute the more it can before yielding and + switching to another cooperative thread. In order to make it works well, + you must follow the following rules: + + * do not write function that may takes time to complete without + using {{{Lwt}}}, + * do not do IOs that may block, otherwise the whole program will + hang. You must instead use asynchronous IOs operations. + +=== The syntax extension === + + {{{Lwt}}} offers a syntax extension which increases code readability and + makes coding using {{{Lwt}}} easier. To use it add the ``lwt.syntax'' package when + compiling: + +<> + + Or in the toplevel (after loading topfind): + +<> + + The following construction are added to the language: + + * {{{lwt}}} //pattern,,1,,// {{{=}}} //expr,,1,,// [ {{{and}}} + //pattern,,2,,// {{{=}}} //expr,,2,,// ... ] {{{in}}} //expr// + \\ + which is a parallel let-binding construction. For example in the + following code: + +<> + + the thread {{{f ()}}} and {{{g ()}}} are launched in parallel + and their result are then bound to {{{x}}} and {{{y}}} in the + expression //expr//. + + Of course you can also launch the two threads sequentially by + writing your code like that: + +<> + + * {{{try_lwt}}} //expr// [ {{{with}}} //pattern,,1,,// + {{{->}}} //expr,,1,,// ... ] [ {{{finally}}} //expr'// ] + \\ + which is the equivalent of the standard {{{try-with}}} + construction but for {{{Lwt}}}. Both exception raised by + {{{Pervasives.raise}}} and {{{Lwt.fail}}} are caught."; + + * {{{for_lwt}}} //ident// {{{=}}} //expr,,init,,// ( {{{to}}} {{{|}}} + {{{downto}}} ) //expr,,final,,// {{{do}}} //expr// + {{{done}}} + \\ + which is the equivalent of the standard {{{for}}} construction + but for {{{Lwt}}}. + + * {{{raise_lwt}}} //exn// + \\ + which is the same as {{{Lwt.fail}}} //exn// but with backtrace support. + +==== Correspondence table ==== + + You can keep in mind the following table to write code using lwt: + + |= without {{{Lwt}}} |= with {{{Lwt}}} | + | | | + | {{{let}}} //pattern,,1,,// {{{=}}} //expr,,1,,// | {{{lwt}}} //pattern,,1,,// {{{=}}} //expr,,1,,// | + | {{{and}}} //pattern,,2,,// {{{=}}} //expr,,2,,// | {{{and}}} //pattern,,2,,// {{{=}}} //expr,,2,,// | + | ... | ... | + | {{{and}}} //pattern,,n,,// {{{=}}} //expr,,n,,// {{{in}}} | {{{and}}} //pattern,,n,,// {{{=}}} //expr,,n,,// {{{in}}} | + | //expr// | //expr// | + | | | + | {{{try}}} | {{{try_lwt}}} | + | // expr// | // expr// | + | {{{with}}} | {{{with}}} | + | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | + | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | + | // // ... | // // ... | + | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | + | | | + | {{{for}}} //ident// {{{=}}} //expr,,init,,// {{{to}}} //expr,,final,,// {{{do}}} | {{{for_lwt}}} //ident// {{{=}}} //expr,,init,,// {{{to}}} //expr,,final,,// {{{do}}} | + | // expr// | // expr// | + | {{{done}}} | {{{done}}} | + | | | + | {{{raise}}} //exn// | {{{raise_lwt}}} //exn// | + | | | + | {{{assert}}} //expr// | {{{assert_lwt}}} //expr// | + | | | + | {{{match}}} //expr// {{{with}}} | {{{match_lwt}}} //expr// {{{with}}} | + | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | + | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | + | // // ... | // // ... | + | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | + | | | + | {{{while}}} //expr// {{{do}}} | {{{while_lwt}}} //expr// {{{do}}} | + | // expr// | // expr// | + | {{{done}}} | {{{done}}} | + +=== Backtrace support === + + When using {{{Lwt}}}, exceptions are not recorded by the ocaml runtime, and so you can not + get backtraces. However it is possible to get them when using the syntax extension. All you + have to do is to pass the {{{-lwt-debug}}} switch to {{{camlp4}}}: + +{{{ +$ ocamlfind ocamlc -syntax camlp4o -package lwt.syntax \ + -ppopt -lwt-debug -linkpkg -o foo foo.ml +}}} + +=== Other modules of the core library === + + The core library contains several modules that depend only on + {{{Lwt}}}. The following naming convention is used in {{{Lwt}}}: when a + function takes as argument a function returning a thread that is going + to be executed sequentially, it is suffixed with ``{{{_s}}}''. And + when it is going to be executed in parallel, it is suffixed with + ``{{{_p}}}''. For example, in the {{{Lwt_list}}} module we have: + +< 'b Lwt.t) -> 'a list -> 'b list Lwt.t +val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t +>> + +==== Mutexes ==== + + {{{Lwt_mutex}}} provides mutexes for {{{Lwt}}}. Its use is almost the + same as the {{{Mutex}}} module of the thread library shipped with + OCaml. In general, programs using {{{Lwt}}} do not need a lot of + mutexes. They are only usefull for serialising operations. + +==== Lists ==== + + The {{{Lwt_list}}} module defines iteration and scanning functions + over lists, similar to the ones of the {{{List}}} module, but using + functions that return a thread. For example: + +< unit Lwt.t) -> 'a list -> unit Lwt.t +val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t +>> + + In {{{iter_s f l}}}, {{{iter_s}}} will call f on each elements + of {{{l}}}, waiting for completion between each elements. On the + contrary, in {{{iter_p f l}}}, {{{iter_p}}} will call f on all + elements of {{{l}}}, then wait for all the threads to terminate. + +==== Data streams ==== + + {{{Lwt}}} streams are used in a lot of places in {{{Lwt}}} and its sub + libraries. They offer a high-level interface to manipulate data flows. + + A stream is an object which returns elements sequentially and + lazily. Lazily means that the source of the stream is guessed for new + elements only when needed. This module contains a lot of stream + transformation, iteration, and scanning functions. + + The common way of creating a stream is by using + {{{Lwt_stream.from}}} or by using {{{Lwt_stream.create}}}: + +< 'a option Lwt.t) -> 'a Lwt_stream.t +val create : unit -> 'a Lwt_stream.t * ('a option -> unit) +>> + + As for streams of the standard library, {{{from}}} takes as + argument a function which is used to create new elements. + + {{{create}}} returns a function used to push new elements + into the stream and the stream which will receive them. + + For example: + +< +val push : '_a option -> unit = +# push (Some 1);; +- : unit = () +# push (Some 2);; +- : unit = () +# push (Some 3);; +- : unit = () +# Lwt.state (Lwt_stream.next stream);; +- : int Lwt.state = Return 1 +# Lwt.state (Lwt_stream.next stream);; +- : int Lwt.state = Return 2 +# Lwt.state (Lwt_stream.next stream);; +- : int Lwt.state = Return 3 +# Lwt.state (Lwt_stream.next stream);; +- : int Lwt.state = Sleep +>> + + Note that streams are consumable. Once you take an element from a + stream, it is removed from it. So, if you want to iterates two times + over a stream, you may consider ``clonning'' it, with + {{{Lwt_stream.clone}}}. Cloned stream will returns the same + elements in the same order. Consuming one will not consume the other. + For example: + +< +# let s' = Lwt_stream.clone s;; +val s' : int Lwt_stream.t = +# Lwt.state (Lwt_stream.next s);; +- : int Lwt.state = Return 1 +# Lwt.state (Lwt_stream.next s);; +- : int Lwt.state = Return 2 +# Lwt.state (Lwt_stream.next s');; +- : int Lwt.state = Return 1 +# Lwt.state (Lwt_stream.next s');; +- : int Lwt.state = Return 2 +>> + +==== Mailbox variables ==== + + The {{{Lwt_mvar}}} module provides mailbox variables. A mailbox + variable, also called a ``mvar'', is a cell which may contains 0 or 1 + element. If it contains no elements, we say that the mvar is empty, + if it contains one, we say that it is full. Adding an element to a + full mvar will block until one is taken. Taking an element from an + empty mvar will block until one is added. + + Mailbox variables are commonly used to pass messages between threads. + + Note that a mailbox variable can be seen as a pushable stream with a + limited memory. + +== Running a Lwt program == + + Threads you create with {{{Lwt}}} always have the type + {{{Lwt.t}}}. If you want to write a program and run it this is not + enough. Indeed you don't know when a {{{Lwt}}} thread is terminated. + + For example if your program is just: + +<> + + you have no guarantee that the thread writing {{{"Hello, world!"}}} + on the terminal will be terminated when the program exit. In order + to wait for a thread to terminate, you have to call the function + {{{Lwt_main.run}}}: + +< 'a +>> + + This functions wait for the given thread to terminate and returns + its result. In fact it does more than that; it also run the + scheduler which is responsible for making thread to progress when + events are received from the outside world. + + So basically, when you write a {{{Lwt}}} program you must call at + the toplevel the function {{{Lwt_main.run}}}. For instance: + +<> + + Note that you must call {{{Lwt_main.run}}} only once at a time. It + cannot be used anywhere to get the result of a thread. It must only + be used in the entry point of your program. + +== The {{{lwt.unix}}} library == + + The package {{{lwt.unix}}} contains all {{{unix}}} dependant + modules of {{{Lwt}}}. Among all its features, it implements cooperative + versions of functions of the standard library and the unix library. + +=== Unix primitives === + + The {{{Lwt_unix}}} provides cooperative system calls. For example, + the {{{Lwt}}} counterpart of {{{Unix.read}}} is: + +< string -> int -> int -> int Lwt.t +>> + + {{{Lwt_io}}} provides features similar to buffered channels of + the standard library (of type {{{in_channel}}} or + {{{out_channel}}}) but cooperatively. + + {{{Lwt_gc}}} allow you to register finaliser that return a + thread. At the end of the program, {{{Lwt}}} will wait for all the + finaliser to terminates. + +=== The Lwt scheduler === + + Threads doing IO may be put asleep until some events are received by + the process. For example when you read from a file descriptor, you + may have to wait for the file descriptor to become readable if no + data are immediatly available on it. + + {{{Lwt}}} contains a shceduler which is responsible for managing + multiple threads waiting for events, and restart them when needed. + This scheduler is implemented by the two modules {{{Lwt_engine}}} + and {{{Lwt_main}}}. {{{Lwt_engine}}} is a low-level module, it + provides signatures for IO multiplexers as well as several builtin + implementation. {{{Lwt}}} support by default multiplexing IO with + {{{libev}}} or {{{Unix.select}}}. The signature is given by the + class {{{Lwt_engine.t}}}. + + {{{libev}}} is used by default on Unix, because it supports any + number of file descriptors while Unix.select supports only 1024 at + most, and is also much more efficient. On Windows {{{Unix.select}}} + is used because {{{libev}}} does not works properly. The user may + change at any time the backend in use. + + The engine can also be used directly in order to integrate other + libraries with {{{Lwt}}}. For example {{{GTK}}} need to be notified + when some events are received. If you use {{{Lwt}}} with {{{GTK}}} + you need to use the {{{Lwt}}} scheduler to monitor {{{GTK}}} + sources. This is what is done by the {{{lwt.glib}}} package. + + The {{{Lwt_main}}} module contains the //main loop// of + {{{Lwt}}}. It is run by calling the function {{{Lwt_main.run}}}: + +< 'a +>> + + This function continously run the scheduler until the thread passed + as argument terminates. + +=== The logging facility === + + The package {{{lwt.unix}}} contains a module {{{Lwt_log}}} + providing loggers. It support logging to a file, a channel, or to the + syslog daemon. You can also defines your own logger by providing the + appropriate functions (function {{{Lwt_log.make}}}). + + Several loggers can be merged into one. Sending logs on the merged + logger will send these logs to all its components. + + For example to redirect all logs to {{{stderr}}} and to the syslog + daemon: + +<> + + {{{Lwt}}} also provides a syntax extension, in the package + {{{lwt.syntax.log}}}. It does not modify the language but + it replaces log statement of the form: + +<> + + by: + +<> + + The advantages of using the syntax extension are the following: + + * it check the log level before calling the logging function, so + arguments are not computed if not needed + * debugging logs can be removed at parsing time + + By default, the syntax extension remove all logs with the level + {{{debug}}}. To keep them pass the command line option + {{{-lwt-debug}}} to camlp4. + +== The Lwt.react library == + + The {{{Lwt_react}}} module provide helpers for using the {{{react}}} + library with {{{Lwt}}}. It extends the {{{React}}} module by adding + {{{Lwt}}} specific functions. It can be used as a replacement of + {{{React}}}. For example you can add at the beginning of you + program: + +<> + + instead of: + +<> + + or: + +<> + + Among the added functionnality we have {{{Lwt_react.E.next}}}, which + takes an event and returns a thread which will wait until the next + occurence of this event. For example: + +< +val push : '_a -> unit = +# let t = E.next event;; +val t : '_a Lwt.t = +# Lwt.state t;; +- : '_a Lwt.state = Sleep +# push 42;; +- : unit = () +# Lwt.state t;; +- : int Lwt.state = Return 42 +>> + + Another interesting feature is the ability to limit events + (resp. signals) to occurs (resp. to changes) too often. For example, + suppose you are doing a program which displays something on the screeen + each time a signal changes. If at some point the signal changes 1000 + times per second, you probably want not to render it 1000 times per + second. For that you use {{{Lwt_react.S.limit}}}: + +< unit Lwt.t) -> 'a React.signal -> 'a React.signal +>> + + {{{Lwt_react.S.limit f signal}}} returns a signal which varies as + {{{signal}}} except that two consecutive updates are separeted by a + call to {{{f}}}. For example if {{{f}}} returns a thread which sleep + for 0.1 seconds, then there will be no more than 10 changes per + second. For example: + +< Lwt_unix.sleep 0.1) signal in + + (* Redraw the screen each time the limited signal change: *) + S.notify_p draw signal' +>> + +== The lwt.text library == + + The {{{lwt.text}}} library provides functions to deal with text + mode (in a terminal). It is composed of the three following modules: + + * {{{Lwt_text}}}, which is the equivalent of {{{Lwt_io}}} + but for unicode text channels + * {{{Lwt_term}}}, providing various terminal utilities, such as + reading a key from the terminal + * {{{Lwt_read_line}}}, which provides functions to input text + from the user with line editing support + +=== Text channels === + + A text channel is basically a byte channel plus an encoding. Input + (resp. output) text channels decode (resp. encode) unicode characters + on the fly. By default, output text channels use transliteration, so + they will not fails because text you want to print cannot be encoded + in the system encoding. + + For example, with you locale sets to ``C'', and the variable + {{{name}}} set to ``Jérémie'', you got: + +<> + +=== Terminal utilities === + + The {{{Lwt_term}}} allow you to put the terminal in //raw mode//, + meanings that input is not buffered and character are + returned as the user type them. For example, you can read a key with: + +<> + + The second main feature of {{{Lwt_term}}} is the ability to prints + text with styles. For example, to print text in bold and blue: + +<> + + If the output is not a terminal, then {{{printlc}}} will drop + styles, and act as {{{Lwt_text.printl}}}. + +=== Read-line === + + {{{Lwt_read_line}}} provides a full featured and fully + customisable read-line implementation. You can either use the + high-level and easy to use {{{read_*}}} functions, or use the + advanced {{{Lwt_read_line.Control.read_*}}} functions. + + For example: + +< "] ();; +foo> Hello, world! +val l : Text.t = "Hello, world!" +>> + + The second class of functions is a bit more complicated to use, but + allow to control a running read-line instances. For example you can + temporary hide it to draw something, you can send it commands, fake + input, and the prompt is a signal so it can change dynamically. + +== Other libraries == + +=== Detaching computation to preemptive threads === + + It may happen that you want to run a function which will take time to + compute or that you want to use a blocking function that cannot be + used in a non-blocking way. For these situations, {{{Lwt}}} allow you to + //detach// the computation to a preemptive thread. + + This is done by the module {{{Lwt_preemptive}}} of the + {{{lwt.preemptive}}} package which maintains a spool of system + threads. The main function is: + +< 'b) -> 'a -> 'b Lwt.t +>> + + {{{detach f x}}} will execute {{{f x}}} in another thread and + asynchronously wait for the result. + + The {{{lwt.extra}}} package provides wrappers for a few blocking + functions of the standard C library like {{{gethostbyname}}} (in + the module {{{Lwt_lib}}}). + +=== SSL support === + + The package {{{lwt.ssl}}} provides the module {{{Lwt_ssl}}} + which allow to use SSL asynchronously + +=== Glib integration === + + The {{{lwt.glib}}} embed the {{{glib}}} main loop into the + {{{Lwt}}} one. This allow you to write GTK application using {{{Lwt}}}. The + one thing you have to do is to call {{{Lwt_glib.install}}} at + the beginning of you program. + +== Writing stubs using {{{Lwt}}} == + +=== Thread-safe notifications === + + If you want to notify the main thread from another thread, you can use the {{{Lwt}}} + thread safe notification system. First you need to create a notification identifier + (which is just an integer) from the OCaml side using the + {{{Lwt_unix.make_notification}}} function, then you can send it from either the + OCaml code with {{{Lwt_unix.send_notification}}} function, or from the C code using + the function {{{lwt_unix_send_notification}}} (defined in {{{lwt_unix_.h}}}). + + Notification are received and processed asynchronously by the main thread. + +=== Jobs === + + For operations that can not be executed asynchronously, {{{Lwt}}} uses a + system of jobs that can be executed in a different threads. A job is + composed of four functions: + + * A function to create the job, which creates a job structure info + and stores parameters in it. This function is executed in the + main thread. + * A function which execute the job. This one may be executed asynchronously + in another thread. + * A function which read the result of the job. This function is + executed in the main thread. + * And finally a function that free resources allocated for the + job, which is also executed in the main thread. + + We show as example the implementation of {{{Lwt_unix.mkdir}}}. On the C + side we have: + +<result = mkdir(job->name, job->perms); + + /* Save the contents of [errno]. */ + job->error_code = errno; +} + +/* The stub that create the job. */ +CAMLprim value lwt_unix_mkdir_job(value val_name, value val_perms) +{ + struct job_mkdir *job = lwt_unix_new(struct job_mkdir); + + /* Sets the worker for this job. */ + job->job.worker = (lwt_unix_job_worker)worker_mkdir; + + /* Copy the name of the directory into the C memory. */ + job->name = lwt_unix_strdup(String_val(val_name)); + + /* Copy the perms parameter. */ + job->perms = Int_val(val_perms); + + /* Put the job into an ocaml custom value and returns it. */ + return lwt_unix_alloc_job(&(job->job)); +} + +/* The stub that read the result of the job. */ +CAMLprim value lwt_unix_mkdir_result(value val_job) +{ + struct job_mkdir *job = Job_mkdir_val(val_job); + + /* If mkdir failed, raise the unix error now. */ + if (job->result < 0) unix_error(job->error_code, "mkdir", Nothing); + + return Val_unit; +} + +/* The stub that free resources. */ +CAMLprim value lwt_unix_mkdir_free(value val_job) +{ + struct job_mkdir *job = Job_mkdir_val(val_job); + + /* Free the name of the directory. */ + free(job->name); + + /* Free resources allocated by lwt_unix for this job. */ + lwt_unix_free_job(&job->job); + + return Val_unit; +} +>> + + and on the ocaml side: + +< int -> [ `unix_mkdir ] job = "lwt_unix_mkdir_job" + +(* The stub for reading the result of the job. *) +external mkdir_result : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_result" + +(* The stub reading the result of the job. *) +external mkdir_free : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_free" + +(* And finally the ocaml function. *) +let mkdir name perms = + Lwt_unix.execute_job (mkdir_job name perms) mkdir_result mkdir_free +>> diff --git a/thirdparty/lwt-2.3.2/manual/menu.wiki b/thirdparty/lwt-2.3.2/manual/menu.wiki new file mode 100644 index 0000000..37caab6 --- /dev/null +++ b/thirdparty/lwt-2.3.2/manual/menu.wiki @@ -0,0 +1,2 @@ += Lwt +==[[manual|Overview]] \ No newline at end of file diff --git a/thirdparty/lwt-2.3.2/myocamlbuild.ml b/thirdparty/lwt-2.3.2/myocamlbuild.ml new file mode 100644 index 0000000..73d08b1 --- /dev/null +++ b/thirdparty/lwt-2.3.2/myocamlbuild.ml @@ -0,0 +1,771 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Myocamlbuild + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* Keep that in sync with the list in discover.ml *) +let search_paths = [ + "/usr"; + "/usr/local"; + "/opt"; + "/opt/local"; + "/sw"; + "/mingw"; +] + +(* OASIS_START *) +(* DO NOT EDIT (digest: 4c177063a31680580ca13639e7a11972) *) +module OASISGettext = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISGettext.ml" + + let ns_ str = + str + + let s_ str = + str + + let f_ (str : ('a, 'b, 'c, 'd) format4) = + str + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + let init = + [] + +end + +module OASISExpr = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISExpr.ml" + + + + open OASISGettext + + type test = string + + type flag = string + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + type 'a choices = (t * 'a) list + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + +end + + +module BaseEnvLight = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseEnvLight.ml" + + module MapString = Map.Make(String) + + type t = string MapString.t + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + let var_get name env = + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + in + var_expand (MapString.find name env) + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +module MyOCamlbuildFindlib = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" + + (** OCamlbuild extension, copied from + * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild + * by N. Pouillard and others + * + * Updated on 2009/02/28 + * + * Modified by Sylvain Le Gall + *) + open Ocamlbuild_plugin + + (* these functions are not really officially exported *) + let run_and_read = + Ocamlbuild_pack.My_unix.run_and_read + + let blank_sep_strings = + Ocamlbuild_pack.Lexers.blank_sep_strings + + let split s ch = + let x = + ref [] + in + let rec go s = + let pos = + String.index s ch + in + x := (String.before s pos)::!x; + go (String.after s (pos + 1)) + in + try + go s + with Not_found -> !x + + let split_nl s = split s '\n' + + let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + + (* this lists all supported packages *) + let find_packages () = + List.map before_space (split_nl & run_and_read "ocamlfind list") + + (* this is supposed to list available syntaxes, but I don't know how to do it. *) + let find_syntaxes () = ["camlp4o"; "camlp4r"] + + (* ocamlfind command *) + let ocamlfind x = S[A"ocamlfind"; x] + + let dispatch = + function + | Before_options -> + (* by using Before_options one let command line options have an higher priority *) + (* on the contrary using After_options will guarantee to have the higher priority *) + (* override default commands by ocamlfind ones *) + Options.ocamlc := ocamlfind & A"ocamlc"; + Options.ocamlopt := ocamlfind & A"ocamlopt"; + Options.ocamldep := ocamlfind & A"ocamldep"; + Options.ocamldoc := ocamlfind & A"ocamldoc"; + Options.ocamlmktop := ocamlfind & A"ocamlmktop" + + | After_rules -> + + (* When one link an OCaml library/binary/package, one should use -linkpkg *) + flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; + end + (find_packages ()); + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> + flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) + + | _ -> + () + +end + +module MyOCamlbuildBase = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" + + (** Base functions for writing myocamlbuild.ml + @author Sylvain Le Gall + *) + + + + open Ocamlbuild_plugin + + type dir = string + type file = string + type name = string + type tag = string + +# 55 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" + + type t = + { + lib_ocaml: (name * dir list) list; + lib_c: (name * dir * file list) list; + flags: (tag list * (spec OASISExpr.choices)) list; + } + + let env_filename = + Pathname.basename + BaseEnvLight.default_filename + + let dispatch_combine lst = + fun e -> + List.iter + (fun dispatch -> dispatch e) + lst + + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename + ~allow_empty:true + () + in + match e with + | Before_options -> + let no_trailing_dot s = + if String.length s >= 1 && s.[0] = '.' then + String.sub s 1 ((String.length s) - 1) + else + s + in + List.iter + (fun (opt, var) -> + try + opt := no_trailing_dot (BaseEnvLight.var_get var env) + with Not_found -> + Printf.eprintf "W: Cannot get variable %s" var) + [ + Options.ext_obj, "ext_obj"; + Options.ext_lib, "ext_lib"; + Options.ext_dll, "ext_dll"; + ] + + | After_rules -> + (* Declare OCaml libraries *) + List.iter + (function + | lib, [] -> + ocaml_lib lib; + | lib, dir :: tl -> + ocaml_lib ~dir:dir lib; + List.iter + (fun dir -> + flag + ["ocaml"; "use_"^lib; "compile"] + (S[A"-I"; P dir])) + tl) + t.lib_ocaml; + + (* Declare C libraries *) + List.iter + (fun (lib, dir, headers) -> + (* Handle C part of library *) + flag ["link"; "library"; "ocaml"; "byte"; "use_lib"^lib] + (S[A"-dllib"; A("-l"^lib); A"-cclib"; A("-l"^lib)]); + + flag ["link"; "library"; "ocaml"; "native"; "use_lib"^lib] + (S[A"-cclib"; A("-l"^lib)]); + + flag ["link"; "program"; "ocaml"; "byte"; "use_lib"^lib] + (S[A"-dllib"; A("dll"^lib)]); + + (* When ocaml link something that use the C library, then one + need that file to be up to date. + *) + dep ["link"; "ocaml"; "use_lib"^lib] + [dir/"lib"^lib^"."^(!Options.ext_lib)]; + + (* TODO: be more specific about what depends on headers *) + (* Depends on .h files *) + dep ["compile"; "c"] + headers; + + (* Setup search path for lib *) + flag ["link"; "ocaml"; "use_"^lib] + (S[A"-I"; P(dir)]); + ) + t.lib_c; + + (* Add flags *) + List.iter + (fun (tags, cond_specs) -> + let spec = + BaseEnvLight.var_choose cond_specs env + in + flag tags & spec) + t.flags + | _ -> + () + + let dispatch_default t = + dispatch_combine + [ + dispatch t; + MyOCamlbuildFindlib.dispatch; + ] + +end + + +open Ocamlbuild_plugin;; +let package_default = + { + MyOCamlbuildBase.lib_ocaml = + [ + ("src/core/lwt", ["src/core"]); + ("src/unix/lwt-unix", ["src/unix"]); + ("src/react/lwt-react", ["src/react"]); + ("tests/test", ["tests"]); + ("src/text/lwt-text", ["src/text"]); + ("syntax/lwt-syntax", ["syntax"]); + ("src/top/lwt-top", ["src/top"]); + ("src/preemptive/lwt-preemptive", ["src/preemptive"]); + ("src/simple_top/lwt-simple-top", ["src/simple_top"]); + ("src/glib/lwt-glib", ["src/glib"]); + ("syntax/lwt-syntax-log", ["syntax"]); + ("src/extra/lwt-extra", ["src/extra"]); + ("syntax/optcomp", ["syntax"]); + ("syntax/lwt-syntax-options", ["syntax"]); + ("src/ssl/lwt-ssl", ["src/ssl"]) + ]; + lib_c = + [ + ("lwt-unix", + "src/unix", + ["src/unix/lwt_config.h"; "src/unix/lwt_unix.h"]); + ("lwt-text", "src/text", []); + ("lwt-glib", "src/glib", []) + ]; + flags = + [ + (["oasis_library_lwt_unix_cclib"; "link"], + [ + (OASISExpr.EBool true, S []); + (OASISExpr.EFlag "libev", S [A "-cclib"; A "-lev"]); + (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), + S [A "-cclib"; A "-lpthread"]); + (OASISExpr.EAnd + (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), + OASISExpr.EFlag "libev"), + S [A "-cclib"; A "-lpthread"; A "-cclib"; A "-lev"]); + (OASISExpr.ETest ("os_type", "Win32"), + S [A "-cclib"; A "ws2_32.lib"]); + (OASISExpr.EAnd + (OASISExpr.ETest ("os_type", "Win32"), + OASISExpr.EFlag "libev"), + S [A "-cclib"; A "ws2_32.lib"; A "-cclib"; A "-lev"]); + (OASISExpr.EAnd + (OASISExpr.ETest ("os_type", "Win32"), + OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))), + S [A "-cclib"; A "ws2_32.lib"; A "-cclib"; A "-lpthread"]); + (OASISExpr.EAnd + (OASISExpr.EAnd + (OASISExpr.ETest ("os_type", "Win32"), + OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))), + OASISExpr.EFlag "libev"), + S + [ + A "-cclib"; + A "ws2_32.lib"; + A "-cclib"; + A "-lpthread"; + A "-cclib"; + A "-lev" + ]) + ]); + (["oasis_library_lwt_unix_cclib"; "ocamlmklib"; "c"], + [ + (OASISExpr.EBool true, S []); + (OASISExpr.EFlag "libev", S [A "-lev"]); + (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), + S [A "-lpthread"]); + (OASISExpr.EAnd + (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), + OASISExpr.EFlag "libev"), + S [A "-lpthread"; A "-lev"]); + (OASISExpr.ETest ("os_type", "Win32"), S [A "ws2_32.lib"]); + (OASISExpr.EAnd + (OASISExpr.ETest ("os_type", "Win32"), + OASISExpr.EFlag "libev"), + S [A "ws2_32.lib"; A "-lev"]); + (OASISExpr.EAnd + (OASISExpr.ETest ("os_type", "Win32"), + OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))), + S [A "ws2_32.lib"; A "-lpthread"]); + (OASISExpr.EAnd + (OASISExpr.EAnd + (OASISExpr.ETest ("os_type", "Win32"), + OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))), + OASISExpr.EFlag "libev"), + S [A "ws2_32.lib"; A "-lpthread"; A "-lev"]) + ]) + ]; + } + ;; + +let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; + +(* OASIS_STOP *) + +open Ocamlbuild_plugin + +let pkg_config flags = + with_temp_file "lwt" "pkg-config" + (fun tmp -> + Command.execute ~quiet:true & Cmd(S[A "pkg-config"; S flags; Sh ">"; A tmp]); + List.map (fun arg -> A arg) (string_list_of_file tmp)) + +let define_c_library ?(msvc = false) ~name ~c_name () = + let tag = Printf.sprintf "use_C_%s" name in + + (* Get compile flags. *) + let opt = pkg_config [A "--cflags"; A c_name] in + + (* Get linking flags. *) + let lib = + if msvc then + (* With msvc we need to pass "glib-2.0.lib" instead of + "-lglib-2.0" otherwise executables will fail. *) + pkg_config [A "--libs-only-L"; A c_name] @ pkg_config [A "--libs-only-l"; A "--msvc-syntax"; A c_name] + else + pkg_config [A "--libs"; A c_name] + in + + (* Add flags for linking with the C library: *) + flag ["ocamlmklib"; "c"; tag] & S lib; + + (* C stubs using the C library must be compiled with the library + specifics flags: *) + flag ["c"; "compile"; tag] & S (List.map (fun arg -> S[A"-ccopt"; arg]) opt); + + (* OCaml libraries must depends on the C library: *) + flag ["link"; "ocaml"; tag] & S (List.map (fun arg -> S[A"-cclib"; arg]) lib) + +let () = + dispatch + (fun hook -> + dispatch_default hook; + match hook with + | Before_options -> + Options.make_links := false + + | After_rules -> + dep ["file:src/unix/lwt_unix_stubs.c"] ["src/unix/lwt_unix_unix.c"; "src/unix/lwt_unix_windows.c"]; + dep ["pa_optcomp"] ["src/unix/lwt_config.ml"]; + + (* Internal syntax extension *) + List.iter + (fun base -> + let tag = "pa_" ^ base and file = "syntax/pa_" ^ base ^ ".cmo" in + flag ["ocaml"; "compile"; tag] & S[A"-ppopt"; A file]; + flag ["ocaml"; "ocamldep"; tag] & S[A"-ppopt"; A file]; + flag ["ocaml"; "doc"; tag] & S[A"-ppopt"; A file]; + dep ["ocaml"; "ocamldep"; tag] [file]) + ["lwt_options"; "lwt"; "lwt_log"; "optcomp"]; + + (* Optcomp for .mli *) + flag ["ocaml"; "compile"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"]; + flag ["ocaml"; "ocamldep"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"]; + flag ["ocaml"; "doc"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"]; + dep ["ocaml"; "ocamldep"; "pa_optcomp_standalone"] ["syntax/optcomp.byte"]; + + (* Use an introduction page with categories *) + tag_file "lwt-api.docdir/index.html" ["apiref"]; + dep ["apiref"] ["apiref-intro"]; + flag ["apiref"] & S[A "-intro"; P "apiref-intro"; A"-colorize-code"]; + + (* Glib bindings: *) + let env = BaseEnvLight.load ~allow_empty:true ~filename:MyOCamlbuildBase.env_filename () in + let msvc = BaseEnvLight.var_get "ccomp_type" env = "msvc" in + if BaseEnvLight.var_get "glib" env = "true" || BaseEnvLight.var_get "all" env = "true" then + define_c_library ~msvc ~name:"glib" ~c_name:"glib-2.0" (); + + let opts = S[A "-ppopt"; A "-let"; A "-ppopt"; A ("windows=" ^ if BaseEnvLight.var_get "os_type" env <> "Unix" then "true" else "false")] in + flag ["ocaml"; "compile"; "pa_optcomp"] & opts; + flag ["ocaml"; "ocamldep"; "pa_optcomp"] & opts; + (*flag ["ocaml"; "doc"; "pa_optcomp"] & opts; Does not work... *) + + flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg"; + + let env = BaseEnvLight.load () in + let stdlib_path = BaseEnvLight.var_get "standard_library" env in + + (* Try to find the path where compiler libraries are: *) + let compiler_libs = + let stdlib = String.chomp stdlib_path in + try + let path = + List.find Pathname.exists [ + stdlib / "compiler-libs"; + stdlib / "compiler-lib"; + stdlib / ".." / "compiler-libs"; + stdlib / ".." / "compiler-lib"; + ] + in + path :: List.filter Pathname.exists [ path / "typing"; path / "utils"; path / "parsing" ] + with Not_found -> + [] + in + + (* Add directories for compiler-libraries: *) + let paths = List.map (fun path -> S[A"-I"; A path]) compiler_libs in + List.iter + (fun stage -> flag ["ocaml"; stage; "use_compiler_libs"] & S paths) + ["compile"; "ocamldep"; "doc"; "link"]; + + dep ["file:src/top/toplevel_temp.top"] ["src/core/lwt.cma"; + "src/react/lwt-react.cma"; + "src/unix/lwt-unix.cma"; + "src/text/lwt-text.cma"; + "src/top/lwt-top.cma"]; + + flag ["file:src/top/toplevel_temp.top"] & S[A"-I"; A"src/unix"; + A"-I"; A"src/text"; + A"src/core/lwt.cma"; + A"src/react/lwt-react.cma"; + A"src/unix/lwt-unix.cma"; + A"src/text/lwt-text.cma"; + A"src/top/lwt-top.cma"]; + + (* Expunge compiler modules *) + rule "toplevel expunge" + ~dep:"src/top/toplevel_temp.top" + ~prod:"src/top/lwt_toplevel.byte" + (fun _ _ -> + let directories = + stdlib_path + :: "src/core" + :: "src/react" + :: "src/unix" + :: "src/text" + :: "src/top" + :: (List.map + (fun lib -> + String.chomp + (run_and_read + ("ocamlfind query " ^ lib))) + ["findlib"; "react"; "unix"; "text"]) + in + let modules = + List.fold_left + (fun set directory -> + List.fold_left + (fun set fname -> + if Pathname.check_extension fname "cmi" then + StringSet.add (module_name_of_pathname fname) set + else + set) + set + (Array.to_list (Pathname.readdir directory))) + StringSet.empty directories + in + Cmd(S[A(stdlib_path / "expunge"); + A"src/top/toplevel_temp.top"; + A"src/top/lwt_toplevel.byte"; + A"outcometree"; A"topdirs"; A"toploop"; + S(List.map (fun x -> A x) (StringSet.elements modules))])); + + (* Search for a header file in standard directories. *) + let search_header header = + let rec loop = function + | [] -> + None + | dir :: dirs -> + if Sys.file_exists (dir ^ "/include/" ^ header) then + Some dir + else + loop dirs + in + loop search_paths + in + + (* Add directories for libev and pthreads *) + let flags dir = + flag ["ocamlmklib"; "c"; "use_stubs"] & A("-L" ^ dir ^ "/lib"); + flag ["c"; "compile"; "use_stubs"] & S[A"-ccopt"; A("-I" ^ dir ^ "/include")]; + flag ["link"; "ocaml"; "use_stubs"] & S[A"-cclib"; A("-L" ^ dir ^ "/lib")] + in + begin + match search_header "ev.h", search_header "pthread.h" with + | None, None -> () + | Some path, None | None, Some path -> flags path + | Some path1, Some path2 when path1 = path2 -> flags path1 + | Some path1, Some path2 -> flags path1; flags path2 + end + + | _ -> + ()) + diff --git a/thirdparty/lwt-2.3.2/setup.ml b/thirdparty/lwt-2.3.2/setup.ml new file mode 100644 index 0000000..f799762 --- /dev/null +++ b/thirdparty/lwt-2.3.2/setup.ml @@ -0,0 +1,6552 @@ +(* + * setup.ml + * -------- + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of lwt. + *) + +(* OASIS_START *) +(* DO NOT EDIT (digest: 91ec49eb394436f650011e25724ddc84) *) +(* + Regenerated by OASIS v0.2.0 + Visit http://oasis.forge.ocamlcore.org for more information and + documentation about functions used in this file. +*) +module OASISGettext = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISGettext.ml" + + let ns_ str = + str + + let s_ str = + str + + let f_ (str : ('a, 'b, 'c, 'd) format4) = + str + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + let init = + [] + +end + +module OASISContext = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISContext.ml" + + open OASISGettext + + type level = + [ `Debug + | `Info + | `Warning + | `Error] + + type t = + { + verbose: bool; + debug: bool; + ignore_plugins: bool; + printf: level -> string -> unit; + } + + let printf lvl str = + let beg = + match lvl with + | `Error -> s_ "E: " + | `Warning -> s_ "W: " + | `Info -> s_ "I: " + | `Debug -> s_ "D: " + in + match lvl with + | `Error -> + prerr_endline (beg^str) + | _ -> + print_endline (beg^str) + + let default = + ref + { + verbose = true; + debug = false; + ignore_plugins = false; + printf = printf; + } + + let quiet = + {!default with + verbose = false; + debug = false; + } + + + let args () = + ["-quiet", + Arg.Unit (fun () -> default := {!default with verbose = false}), + (s_ " Run quietly"); + + "-debug", + Arg.Unit (fun () -> default := {!default with debug = true}), + (s_ " Output debug message")] +end + +module OASISUtils = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISUtils.ml" + + module MapString = Map.Make(String) + + let map_string_of_assoc assoc = + List.fold_left + (fun acc (k, v) -> MapString.add k v acc) + MapString.empty + assoc + + module SetString = Set.Make(String) + + let set_string_add_list st lst = + List.fold_left + (fun acc e -> SetString.add e acc) + st + lst + + let set_string_of_list = + set_string_add_list + SetString.empty + + + let compare_csl s1 s2 = + String.compare (String.lowercase s1) (String.lowercase s2) + + module HashStringCsl = + Hashtbl.Make + (struct + type t = string + + let equal s1 s2 = + (String.lowercase s1) = (String.lowercase s2) + + let hash s = + Hashtbl.hash (String.lowercase s) + end) + + let split sep str = + let str_len = + String.length str + in + let rec split_aux acc pos = + if pos < str_len then + ( + let pos_sep = + try + String.index_from str pos sep + with Not_found -> + str_len + in + let part = + String.sub str pos (pos_sep - pos) + in + let acc = + part :: acc + in + if pos_sep >= str_len then + ( + (* Nothing more in the string *) + List.rev acc + ) + else if pos_sep = (str_len - 1) then + ( + (* String end with a separator *) + List.rev ("" :: acc) + ) + else + ( + split_aux acc (pos_sep + 1) + ) + ) + else + ( + List.rev acc + ) + in + split_aux [] 0 + + + let varname_of_string ?(hyphen='_') s = + if String.length s = 0 then + begin + invalid_arg "varname_of_string" + end + else + begin + let buff = + Buffer.create (String.length s) + in + (* Start with a _ if digit *) + if '0' <= s.[0] && s.[0] <= '9' then + Buffer.add_char buff hyphen; + + String.iter + (fun c -> + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || + ('0' <= c && c <= '9') then + Buffer.add_char buff c + else + Buffer.add_char buff hyphen) + s; + + String.lowercase (Buffer.contents buff) + end + + let varname_concat ?(hyphen='_') p s = + let p = + let p_len = + String.length p + in + if p_len > 0 && p.[p_len - 1] = hyphen then + String.sub p 0 (p_len - 1) + else + p + in + let s = + let s_len = + String.length s + in + if s_len > 0 && s.[0] = hyphen then + String.sub s 1 (s_len - 1) + else + s + in + Printf.sprintf "%s%c%s" p hyphen s + + + let is_varname str = + str = varname_of_string str + + let failwithf1 fmt a = + failwith (Printf.sprintf fmt a) + + let failwithf2 fmt a b = + failwith (Printf.sprintf fmt a b) + + let failwithf3 fmt a b c = + failwith (Printf.sprintf fmt a b c) + + let failwithf4 fmt a b c d = + failwith (Printf.sprintf fmt a b c d) + + let failwithf5 fmt a b c d e = + failwith (Printf.sprintf fmt a b c d e) + +end + +module PropList = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/PropList.ml" + + open OASISGettext + + type name = string + + exception Not_set of name * string option + exception No_printer of name + exception Unknown_field of name * name + + let string_of_exception = + function + | Not_set (nm, Some rsn) -> + Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn + | Not_set (nm, None) -> + Printf.sprintf (f_ "Field '%s' is not set") nm + | No_printer nm -> + Printf.sprintf (f_ "No default printer for value %s") nm + | Unknown_field (nm, schm) -> + Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm + | e -> + raise e + + module Data = + struct + + type t = + (name, unit -> unit) Hashtbl.t + + let create () = + Hashtbl.create 13 + + let clear t = + Hashtbl.clear t + +# 59 "/home/chambart/bordel/oasis/oasis/src/oasis/PropList.ml" + end + + module Schema = + struct + + type ('ctxt, 'extra) value = + { + get: Data.t -> string; + set: Data.t -> ?context:'ctxt -> string -> unit; + help: (unit -> string) option; + extra: 'extra; + } + + type ('ctxt, 'extra) t = + { + name: name; + fields: (name, ('ctxt, 'extra) value) Hashtbl.t; + order: name Queue.t; + name_norm: string -> string; + } + + let create ?(case_insensitive=false) nm = + { + name = nm; + fields = Hashtbl.create 13; + order = Queue.create (); + name_norm = + (if case_insensitive then + String.lowercase + else + fun s -> s); + } + + let add t nm set get extra help = + let key = + t.name_norm nm + in + + if Hashtbl.mem t.fields key then + failwith + (Printf.sprintf + (f_ "Field '%s' is already defined in schema '%s'") + nm t.name); + Hashtbl.add + t.fields + key + { + set = set; + get = get; + help = help; + extra = extra; + }; + Queue.add nm t.order + + let mem t nm = + Hashtbl.mem t.fields nm + + let find t nm = + try + Hashtbl.find t.fields (t.name_norm nm) + with Not_found -> + raise (Unknown_field (nm, t.name)) + + let get t data nm = + (find t nm).get data + + let set t data nm ?context x = + (find t nm).set + data + ?context + x + + let fold f acc t = + Queue.fold + (fun acc k -> + let v = + find t k + in + f acc k v.extra v.help) + acc + t.order + + let iter f t = + fold + (fun () -> f) + () + t + + let name t = + t.name + end + + module Field = + struct + + type ('ctxt, 'value, 'extra) t = + { + set: Data.t -> ?context:'ctxt -> 'value -> unit; + get: Data.t -> 'value; + sets: Data.t -> ?context:'ctxt -> string -> unit; + gets: Data.t -> string; + help: (unit -> string) option; + extra: 'extra; + } + + let new_id = + let last_id = + ref 0 + in + fun () -> incr last_id; !last_id + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + (* Default value container *) + let v = + ref None + in + + (* If name is not given, create unique one *) + let nm = + match name with + | Some s -> s + | None -> Printf.sprintf "_anon_%d" (new_id ()) + in + + (* Last chance to get a value: the default *) + let default () = + match default with + | Some d -> d + | None -> raise (Not_set (nm, Some (s_ "no default value"))) + in + + (* Get data *) + let get data = + (* Get value *) + try + (Hashtbl.find data nm) (); + match !v with + | Some x -> x + | None -> default () + with Not_found -> + default () + in + + (* Set data *) + let set data ?context x = + let x = + match update with + | Some f -> + begin + try + f ?context (get data) x + with Not_set _ -> + x + end + | None -> + x + in + Hashtbl.replace + data + nm + (fun () -> v := Some x) + in + + (* Parse string value, if possible *) + let parse = + match parse with + | Some f -> + f + | None -> + fun ?context s -> + failwith + (Printf.sprintf + (f_ "Cannot parse field '%s' when setting value %S") + nm + s) + in + + (* Set data, from string *) + let sets data ?context s = + set ?context data (parse ?context s) + in + + (* Output value as string, if possible *) + let print = + match print with + | Some f -> + f + | None -> + fun _ -> raise (No_printer nm) + in + + (* Get data, as a string *) + let gets data = + print (get data) + in + + begin + match schema with + | Some t -> + Schema.add t nm sets gets extra help + | None -> + () + end; + + { + set = set; + get = get; + sets = sets; + gets = gets; + help = help; + extra = extra; + } + + let fset data t ?context x = + t.set data ?context x + + let fget data t = + t.get data + + let fsets data t ?context s = + t.sets data ?context s + + let fgets data t = + t.gets data + + end + + module FieldRO = + struct + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + let fld = + Field.create ?schema ?name ?parse ?print ?default ?update ?help extra + in + fun data -> Field.fget data fld + + end +end + +module OASISMessage = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISMessage.ml" + + + open OASISGettext + open OASISContext + + let generic_message ~ctxt lvl fmt = + let cond = + match lvl with + | `Debug -> ctxt.debug + | _ -> ctxt.verbose + in + Printf.ksprintf + (fun str -> + if cond then + begin + ctxt.printf lvl str + end) + fmt + + let debug ~ctxt fmt = + generic_message ~ctxt `Debug fmt + + let info ~ctxt fmt = + generic_message ~ctxt `Info fmt + + let warning ~ctxt fmt = + generic_message ~ctxt `Warning fmt + + let error ~ctxt fmt = + generic_message ~ctxt `Error fmt + + + let string_of_exception e = + try + PropList.string_of_exception e + with + | Failure s -> + s + | e -> + Printexc.to_string e + + (* TODO + let register_exn_printer f = + *) + +end + +module OASISVersion = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISVersion.ml" + + open OASISGettext + + + + type s = string + + type t = string + + type comparator = + | VGreater of t + | VGreaterEqual of t + | VEqual of t + | VLesser of t + | VLesserEqual of t + | VOr of comparator * comparator + | VAnd of comparator * comparator + + + (* Range of allowed characters *) + let is_digit c = + '0' <= c && c <= '9' + + let is_alpha c = + ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') + + let is_special = + function + | '.' | '+' | '-' | '~' -> true + | _ -> false + + let rec version_compare v1 v2 = + if v1 <> "" || v2 <> "" then + begin + (* Compare ascii string, using special meaning for version + * related char + *) + let val_ascii c = + if c = '~' then -1 + else if is_digit c then 0 + else if c = '\000' then 0 + else if is_alpha c then Char.code c + else (Char.code c) + 256 + in + + let len1 = String.length v1 in + let len2 = String.length v2 in + + let p = ref 0 in + + (** Compare ascii part *) + let compare_vascii () = + let cmp = ref 0 in + while !cmp = 0 && + !p < len1 && !p < len2 && + not (is_digit v1.[!p] && is_digit v2.[!p]) do + cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); + incr p + done; + if !cmp = 0 && !p < len1 && !p = len2 then + val_ascii v1.[!p] + else if !cmp = 0 && !p = len1 && !p < len2 then + - (val_ascii v2.[!p]) + else + !cmp + in + + (** Compare digit part *) + let compare_digit () = + let extract_int v p = + let start_p = !p in + while !p < String.length v && is_digit v.[!p] do + incr p + done; + match String.sub v start_p (!p - start_p) with + | "" -> 0, + v + | s -> int_of_string s, + String.sub v !p ((String.length v) - !p) + in + let i1, tl1 = extract_int v1 (ref !p) in + let i2, tl2 = extract_int v2 (ref !p) in + i1 - i2, tl1, tl2 + in + + match compare_vascii () with + | 0 -> + begin + match compare_digit () with + | 0, tl1, tl2 -> + if tl1 <> "" && is_digit tl1.[0] then + 1 + else if tl2 <> "" && is_digit tl2.[0] then + -1 + else + version_compare tl1 tl2 + | n, _, _ -> + n + end + | n -> + n + end + else + begin + 0 + end + + + let version_of_string str = + String.iter + (fun c -> + if is_alpha c || is_digit c || is_special c then + () + else + failwith + (Printf.sprintf + (f_ "Char %C is not allowed in version '%s'") + c str)) + str; + str + + let string_of_version t = + t + + let chop t = + try + let pos = + String.rindex t '.' + in + String.sub t 0 pos + with Not_found -> + t + + let rec comparator_apply v op = + match op with + | VGreater cv -> + (version_compare v cv) > 0 + | VGreaterEqual cv -> + (version_compare v cv) >= 0 + | VLesser cv -> + (version_compare v cv) < 0 + | VLesserEqual cv -> + (version_compare v cv) <= 0 + | VEqual cv -> + (version_compare v cv) = 0 + | VOr (op1, op2) -> + (comparator_apply v op1) || (comparator_apply v op2) + | VAnd (op1, op2) -> + (comparator_apply v op1) && (comparator_apply v op2) + + let rec string_of_comparator = + function + | VGreater v -> "> "^(string_of_version v) + | VEqual v -> "= "^(string_of_version v) + | VLesser v -> "< "^(string_of_version v) + | VGreaterEqual v -> ">= "^(string_of_version v) + | VLesserEqual v -> "<= "^(string_of_version v) + | VOr (c1, c2) -> + (string_of_comparator c1)^" || "^(string_of_comparator c2) + | VAnd (c1, c2) -> + (string_of_comparator c1)^" && "^(string_of_comparator c2) + + let rec varname_of_comparator = + let concat p v = + OASISUtils.varname_concat + p + (OASISUtils.varname_of_string + (string_of_version v)) + in + function + | VGreater v -> concat "gt" v + | VLesser v -> concat "lt" v + | VEqual v -> concat "eq" v + | VGreaterEqual v -> concat "ge" v + | VLesserEqual v -> concat "le" v + | VOr (c1, c2) -> + (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) + | VAnd (c1, c2) -> + (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) + +end + +module OASISLicense = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISLicense.ml" + + (** License for _oasis fields + @author Sylvain Le Gall + *) + + + + type license = string + + type license_exception = string + + type license_version = + | Version of OASISVersion.t + | VersionOrLater of OASISVersion.t + | NoVersion + + + type license_dep_5 = + { + license: license; + exceptions: license_exception list; + version: license_version; + } + + type t = + | DEP5License of license_dep_5 + | OtherLicense of string (* URL *) + + +end + +module OASISExpr = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISExpr.ml" + + + + open OASISGettext + + type test = string + + type flag = string + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + type 'a choices = (t * 'a) list + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + +end + +module OASISTypes = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISTypes.ml" + + + + + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) + + type findlib_name = string + type findlib_full = string + + type compiled_object = + | Byte + | Native + | Best + + + type dependency = + | FindlibPackage of findlib_full * OASISVersion.comparator option + | InternalLibrary of name + + + type tool = + | ExternalTool of name + | InternalExecutable of name + + + type vcs = + | Darcs + | Git + | Svn + | Cvs + | Hg + | Bzr + | Arch + | Monotone + | OtherVCS of url + + + type plugin_kind = + [ `Configure + | `Build + | `Doc + | `Test + | `Install + | `Extra + ] + + type plugin_data_purpose = + [ `Configure + | `Build + | `Install + | `Clean + | `Distclean + | `Install + | `Uninstall + | `Test + | `Doc + | `Extra + | `Other of string + ] + + type 'a plugin = 'a * name * OASISVersion.t option + + type all_plugin = plugin_kind plugin + + type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list + +# 102 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISTypes.ml" + + type 'a conditional = 'a OASISExpr.choices + + type custom = + { + pre_command: (command_line option) conditional; + post_command: (command_line option) conditional; + } + + + type common_section = + { + cs_name: name; + cs_data: PropList.Data.t; + cs_plugin_data: plugin_data; + } + + + type build_section = + { + bs_build: bool conditional; + bs_install: bool conditional; + bs_path: unix_dirname; + bs_compiled_object: compiled_object; + bs_build_depends: dependency list; + bs_build_tools: tool list; + bs_c_sources: unix_filename list; + bs_data_files: (unix_filename * unix_filename option) list; + bs_ccopt: args conditional; + bs_cclib: args conditional; + bs_dlllib: args conditional; + bs_dllpath: args conditional; + bs_byteopt: args conditional; + bs_nativeopt: args conditional; + } + + + type library = + { + lib_modules: string list; + lib_internal_modules: string list; + lib_findlib_parent: findlib_name option; + lib_findlib_name: findlib_name option; + lib_findlib_containers: findlib_name list; + } + + type executable = + { + exec_custom: bool; + exec_main_is: unix_filename; + } + + type flag = + { + flag_description: string option; + flag_default: bool conditional; + } + + type source_repository = + { + src_repo_type: vcs; + src_repo_location: url; + src_repo_browser: url option; + src_repo_module: string option; + src_repo_branch: string option; + src_repo_tag: string option; + src_repo_subdir: unix_filename option; + } + + type test = + { + test_type: [`Test] plugin; + test_command: command_line conditional; + test_custom: custom; + test_working_directory: unix_filename option; + test_run: bool conditional; + test_tools: tool list; + } + + type doc_format = + | HTML of unix_filename + | DocText + | PDF + | PostScript + | Info of unix_filename + | DVI + | OtherDoc + + + type doc = + { + doc_type: [`Doc] plugin; + doc_custom: custom; + doc_build: bool conditional; + doc_install: bool conditional; + doc_install_dir: unix_filename; + doc_title: string; + doc_authors: string list; + doc_abstract: string option; + doc_format: doc_format; + doc_data_files: (unix_filename * unix_filename option) list; + doc_build_tools: tool list; + } + + type section = + | Library of common_section * build_section * library + | Executable of common_section * build_section * executable + | Flag of common_section * flag + | SrcRepo of common_section * source_repository + | Test of common_section * test + | Doc of common_section * doc + + + type package = + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: string option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } + +end + +module OASISUnixPath = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISUnixPath.ml" + + type unix_filename = string + type unix_dirname = string + + type host_filename = string + type host_dirname = string + + let current_dir_name = "." + + let parent_dir_name = ".." + + let concat f1 f2 = + if f1 = current_dir_name then + f2 + else if f2 = current_dir_name then + f1 + else + f1^"/"^f2 + + let make = + function + | hd :: tl -> + List.fold_left + (fun f p -> concat f p) + hd + tl + | [] -> + invalid_arg "OASISUnixPath.make" + + let dirname f = + try + String.sub f 0 (String.rindex f '/') + with Not_found -> + current_dir_name + + let basename f = + try + let pos_start = + (String.rindex f '/') + 1 + in + String.sub f pos_start ((String.length f) - pos_start) + with Not_found -> + f + + let chop_extension f = + try + let last_dot = + String.rindex f '.' + in + let sub = + String.sub f 0 last_dot + in + try + let last_slash = + String.rindex f '/' + in + if last_slash < last_dot then + sub + else + f + with Not_found -> + sub + + with Not_found -> + f + + let capitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.capitalize base) + + let uncapitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.uncapitalize base) +end + +module OASISSection = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISSection.ml" + + (** Manipulate section + @author Sylvain Le Gall + *) + + open OASISTypes + + type section_kind = + | KLibrary + | KExecutable + | KFlag + | KSrcRepo + | KTest + | KDoc + + (** Extract generic information + *) + let section_kind_common = + function + | Library (cs, _, _) -> + KLibrary, cs + | Executable (cs, _, _) -> + KExecutable, cs + | Flag (cs, _) -> + KFlag, cs + | SrcRepo (cs, _) -> + KSrcRepo, cs + | Test (cs, _) -> + KTest, cs + | Doc (cs, _) -> + KDoc, cs + + (** Common section of a section + *) + let section_common sct = + snd (section_kind_common sct) + + (** Key used to identify section + *) + let section_id sct = + let k, cs = + section_kind_common sct + in + k, cs.cs_name + + let string_of_section sct = + let k, nm = + section_id sct + in + (match k with + | KLibrary -> "library" + | KExecutable -> "executable" + | KFlag -> "flag" + | KSrcRepo -> "src repository" + | KTest -> "test" + | KDoc -> "doc") + ^" "^nm + +end + +module OASISBuildSection = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISBuildSection.ml" + +end + +module OASISExecutable = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISExecutable.ml" + + open OASISTypes + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = + OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.dirname exec.exec_main_is) + in + let is_native_exec = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native () + | Byte -> false + in + + OASISUnixPath.concat + dir + (cs.cs_name^(suffix_program ())), + + if not is_native_exec && + not exec.exec_custom && + bs.bs_c_sources <> [] then + Some (dir^"/dll"^cs.cs_name^(ext_dll ())) + else + None + +end + +module OASISLibrary = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISLibrary.ml" + + open OASISTypes + open OASISUtils + open OASISGettext + + type library_name = name + + let generated_unix_files ~ctxt (cs, bs, lib) + source_file_exists is_native ext_lib ext_dll = + (* The headers that should be compiled along *) + let headers = + List.fold_left + (fun hdrs modul -> + try + let base_fn = + List.find + (fun fn -> + source_file_exists (fn^".ml") || + source_file_exists (fn^".mli") || + source_file_exists (fn^".mll") || + source_file_exists (fn^".mly")) + (List.map + (OASISUnixPath.concat bs.bs_path) + [modul; + OASISUnixPath.uncapitalize_file modul; + OASISUnixPath.capitalize_file modul]) + in + [base_fn^".cmi"] :: hdrs + with Not_found -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + (List.map (OASISUnixPath.concat bs.bs_path) + [modul^".cmi"; + OASISUnixPath.uncapitalize_file modul ^ ".cmi"; + OASISUnixPath.capitalize_file modul ^ ".cmi"]) + :: hdrs) + [] + lib.lib_modules + in + + let acc_nopath = + [] + in + + (* Compute what libraries should be built *) + let acc_nopath = + let byte acc = + [cs.cs_name^".cma"] :: acc + in + let native acc = + [cs.cs_name^".cmxs"] :: [cs.cs_name^".cmxa"] :: [cs.cs_name^(ext_lib ())] :: acc + in + match bs.bs_compiled_object with + | Native -> + byte (native acc_nopath) + | Best when is_native () -> + byte (native acc_nopath) + | Byte | Best -> + byte acc_nopath + in + + (* Add C library to be built *) + let acc_nopath = + if bs.bs_c_sources <> [] then + begin + ["lib"^cs.cs_name^(ext_lib ())] + :: + ["dll"^cs.cs_name^(ext_dll ())] + :: + acc_nopath + end + else + acc_nopath + in + + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + headers + + + type group_t = + | Container of findlib_name * (group_t list) + | Package of (findlib_name * + common_section * + build_section * + library * + (group_t list)) + + let group_libs pkg = + (** Associate a name with its children *) + let children = + List.fold_left + (fun mp -> + function + | Library (cs, bs, lib) -> + begin + match lib.lib_findlib_parent with + | Some p_nm -> + begin + let children = + try + MapString.find p_nm mp + with Not_found -> + [] + in + MapString.add p_nm ((cs, bs, lib) :: children) mp + end + | None -> + mp + end + | _ -> + mp) + MapString.empty + pkg.sections + in + + (* Compute findlib name of a single node *) + let findlib_name (cs, _, lib) = + match lib.lib_findlib_name with + | Some nm -> nm + | None -> cs.cs_name + in + + (** Build a package tree *) + let rec tree_of_library containers ((cs, bs, lib) as acc) = + match containers with + | hd :: tl -> + Container (hd, [tree_of_library tl acc]) + | [] -> + Package + (findlib_name acc, cs, bs, lib, + (try + List.rev_map + (fun ((_, _, child_lib) as child_acc) -> + tree_of_library + child_lib.lib_findlib_containers + child_acc) + (MapString.find cs.cs_name children) + with Not_found -> + [])) + in + + (** Merge containers with the same name *) + let rec merge_containers groups = + (* Collect packages and create the map "container name -> merged children" *) + let packages, containers = + List.fold_left + (fun (packages, containers) group -> + match group with + | Container(name, children) -> + let children' = + try + MapString.find name containers + with Not_found -> + [] + in + (packages, + MapString.add name (children' @ children) containers) + | Package(name, cs, bs, lib, children) -> + (Package(name, cs, bs, lib, merge_containers children) :: packages, + containers)) + ([], MapString.empty) + groups + in + (* Recreate the list of groups *) + packages @ + (MapString.fold + (fun name children acc -> + Container(name, merge_containers children) :: acc) + containers []) + in + + (* TODO: check that libraries are unique *) + merge_containers + (List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when lib.lib_findlib_parent = None -> + (tree_of_library lib.lib_findlib_containers (cs, bs, lib)) :: acc + | _ -> + acc) + [] + pkg.sections) + + (** Compute internal to findlib library matchings, including subpackage + and return a map of it. + *) + let findlib_name_map pkg = + + (* Compute names in a tree *) + let rec findlib_names_aux path mp grp = + let fndlb_nm, children, mp = + match grp with + | Container (fndlb_nm, children) -> + fndlb_nm, children, mp + + | Package (fndlb_nm, {cs_name = nm}, _, _, children) -> + fndlb_nm, children, (MapString.add nm (path, fndlb_nm) mp) + in + let fndlb_nm_full = + (match path with + | Some pth -> pth^"." + | None -> "")^ + fndlb_nm + in + List.fold_left + (findlib_names_aux (Some fndlb_nm_full)) + mp + children + in + + List.fold_left + (findlib_names_aux None) + MapString.empty + (group_libs pkg) + + + let findlib_of_name ?(recurse=false) map nm = + try + let (path, fndlb_nm) = + MapString.find nm map + in + match path with + | Some pth when recurse -> pth^"."^fndlb_nm + | _ -> fndlb_nm + + with Not_found -> + failwithf1 + (f_ "Unable to translate internal library '%s' to findlib name") + nm + + let name_findlib_map pkg = + let mp = + findlib_name_map pkg + in + MapString.fold + (fun nm _ acc -> + let fndlb_nm_full = + findlib_of_name + ~recurse:true + mp + nm + in + MapString.add fndlb_nm_full nm acc) + mp + MapString.empty + + let findlib_of_group = + function + | Container (fndlb_nm, _) + | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + + let root_of_group grp = + let rec root_lib_aux = + function + | Container (_, children) -> + root_lib_lst children + | Package (_, cs, bs, lib, children) -> + if lib.lib_findlib_parent = None then + cs, bs, lib + else + root_lib_lst children + and root_lib_lst = + function + | [] -> + raise Not_found + | hd :: tl -> + try + root_lib_aux hd + with Not_found -> + root_lib_lst tl + in + try + root_lib_aux grp + with Not_found -> + failwithf1 + (f_ "Unable to determine root library of findlib library '%s'") + (findlib_of_group grp) + + +end + +module OASISFlag = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISFlag.ml" + +end + +module OASISPackage = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISPackage.ml" + +end + +module OASISSourceRepository = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISSourceRepository.ml" + +end + +module OASISTest = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISTest.ml" + +end + +module OASISDocument = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISDocument.ml" + +end + + +module BaseEnvLight = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseEnvLight.ml" + + module MapString = Map.Make(String) + + type t = string MapString.t + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + let var_get name env = + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + in + var_expand (MapString.find name env) + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +module BaseContext = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseContext.ml" + + open OASISContext + + let args = args + + let default = default + +end + +module BaseMessage = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseMessage.ml" + + (** Message to user, overrid for Base + @author Sylvain Le Gall + *) + open OASISMessage + open BaseContext + + let debug fmt = debug ~ctxt:!default fmt + + let info fmt = info ~ctxt:!default fmt + + let warning fmt = warning ~ctxt:!default fmt + + let error fmt = error ~ctxt:!default fmt + + let string_of_exception = string_of_exception + +end + +module BaseFilePath = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseFilePath.ml" + + + open Filename + + module Unix = OASISUnixPath + + let make = + function + | [] -> + invalid_arg "BaseFilename.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + let of_unix ufn = + if Sys.os_type = "Unix" then + ufn + else + make + (List.map + (fun p -> + if p = Unix.current_dir_name then + current_dir_name + else if p = Unix.parent_dir_name then + parent_dir_name + else + p) + (OASISUtils.split '/' ufn)) + +end + +module BaseEnv = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseEnv.ml" + + open OASISTypes + open OASISGettext + open OASISUtils + open PropList + + module MapString = BaseEnvLight.MapString + + type origin_t = + | ODefault + | OGetEnv + | OFileLoad + | OCommandLine + + type cli_handle_t = + | CLINone + | CLIAuto + | CLIWith + | CLIEnable + | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + + type definition_t = + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } + + let schema = + Schema.create "environment" + + (* Environment data *) + let env = + Data.create () + + (* Environment data from file *) + let env_from_file = + ref MapString.empty + + (* Lexer for var *) + let var_lxr = + Genlex.make_lexer [] + + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + (* TODO: this is a quick hack to allow calling Test.Command + * without defining executable name really. I.e. if there is + * an exec Executable toto, then $(toto) should be replace + * by its real name. It is however useful to have this function + * for other variable that depend on the host and should be + * written better than that. + *) + let st = + var_lxr (Stream.of_string var) + in + match Stream.npeek 3 st with + | [Genlex.Ident "utoh"; Genlex.Ident nm] -> + BaseFilePath.of_unix (var_get nm) + | [Genlex.Ident "utoh"; Genlex.String s] -> + BaseFilePath.of_unix s + | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> + String.escaped (var_get nm) + | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> + String.escaped s + | [Genlex.Ident nm] -> + var_get nm + | _ -> + failwithf2 + (f_ "Unknown expression '%s' in variable expansion of %s.") + var + str + with + | Unknown_field (_, _) -> + failwithf2 + (f_ "No variable %s defined when trying to expand %S.") + var + str + | Stream.Error e -> + failwithf3 + (f_ "Syntax error when parsing '%s' when trying to \ + expand %S: %s") + var + str + e) + str; + Buffer.contents buff + + and var_get name = + let vl = + try + Schema.get schema env name + with Unknown_field _ as e -> + begin + try + MapString.find name !env_from_file + with Not_found -> + raise e + end + in + var_expand vl + + let var_choose ?printer ?name lst = + OASISExpr.choose + ?printer + ?name + var_get + lst + + let var_protect vl = + let buff = + Buffer.create (String.length vl) + in + String.iter + (function + | '$' -> Buffer.add_string buff "\\$" + | c -> Buffer.add_char buff c) + vl; + Buffer.contents buff + + let var_define + ?(hide=false) + ?(dump=true) + ?short_desc + ?(cli=CLINone) + ?arg_help + ?group + name (* TODO: type constraint on the fact that name must be a valid OCaml + id *) + dflt = + + let default = + [ + OFileLoad, lazy (MapString.find name !env_from_file); + ODefault, dflt; + OGetEnv, lazy (Sys.getenv name); + ] + in + + let extra = + { + hide = hide; + dump = dump; + cli = cli; + arg_help = arg_help; + group = group; + } + in + + (* Try to find a value that can be defined + *) + let var_get_low lst = + let errors, res = + List.fold_left + (fun (errors, res) (_, v) -> + if res = None then + begin + try + errors, Some (Lazy.force v) + with + | Not_found -> + errors, res + | Failure rsn -> + (rsn :: errors), res + | e -> + (Printexc.to_string e) :: errors, res + end + else + errors, res) + ([], None) + (List.sort + (fun (o1, _) (o2, _) -> + if o1 < o2 then + 1 + else if o1 = o2 then + 0 + else + -1) + lst) + in + match res, errors with + | Some v, _ -> + v + | None, [] -> + raise (Not_set (name, None)) + | None, lst -> + raise (Not_set (name, Some (String.concat (s_ ", ") lst))) + in + + let help = + match short_desc with + | Some fs -> Some fs + | None -> None + in + + let var_get_lst = + FieldRO.create + ~schema + ~name + ~parse:(fun ?(context=ODefault) s -> [context, lazy s]) + ~print:var_get_low + ~default + ~update:(fun ?context x old_x -> x @ old_x) + ?help + extra + in + + fun () -> + var_expand (var_get_low (var_get_lst env)) + + let var_redefine + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt = + if Schema.mem schema name then + begin + Schema.set schema env ~context:ODefault name (Lazy.force dflt); + fun () -> var_get name + end + else + begin + var_define + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt + end + + let var_ignore (e : unit -> string) = + () + + let print_hidden = + var_define + ~hide:true + ~dump:false + ~cli:CLIAuto + ~arg_help:"Print even non-printable variable. (debug)" + "print_hidden" + (lazy "false") + + let var_all () = + List.rev + (Schema.fold + (fun acc nm def _ -> + if not def.hide || bool_of_string (print_hidden ()) then + nm :: acc + else + acc) + [] + schema) + + let default_filename = + BaseEnvLight.default_filename + + let load ?allow_empty ?filename () = + env_from_file := BaseEnvLight.load ?allow_empty ?filename () + + let unload () = + (* TODO: reset lazy values *) + env_from_file := MapString.empty; + Data.clear env + + let dump ?(filename=default_filename) () = + let chn = + open_out_bin filename + in + Schema.iter + (fun nm def _ -> + if def.dump then + begin + try + let value = + Schema.get + schema + env + nm + in + Printf.fprintf chn "%s = %S\n" nm value + with Not_set _ -> + () + end) + schema; + close_out chn + + let print () = + let printable_vars = + Schema.fold + (fun acc nm def short_descr_opt -> + if not def.hide || bool_of_string (print_hidden ()) then + begin + try + let value = + Schema.get + schema + env + nm + in + let txt = + match short_descr_opt with + | Some s -> s () + | None -> nm + in + (txt, value) :: acc + with Not_set _ -> + acc + end + else + acc) + [] + schema + in + let max_length = + List.fold_left max 0 + (List.rev_map String.length + (List.rev_map fst printable_vars)) + in + let dot_pad str = + String.make ((max_length - (String.length str)) + 3) '.' + in + + print_newline (); + print_endline "Configuration: "; + print_newline (); + List.iter + (fun (name,value) -> + Printf.printf "%s: %s %s\n" name (dot_pad name) value) + printable_vars; + Printf.printf "%!"; + print_newline () + + let args () = + let arg_concat = + OASISUtils.varname_concat ~hyphen:'-' + in + [ + "--override", + Arg.Tuple + ( + let rvr = ref "" + in + let rvl = ref "" + in + [ + Arg.Set_string rvr; + Arg.Set_string rvl; + Arg.Unit + (fun () -> + Schema.set + schema + env + ~context:OCommandLine + !rvr + !rvl) + ] + ), + "var+val Override any configuration variable."; + + ] + @ + List.flatten + (Schema.fold + (fun acc name def short_descr_opt -> + let var_set s = + Schema.set + schema + env + ~context:OCommandLine + name + s + in + + let arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in + + let hlp = + match short_descr_opt with + | Some txt -> txt () + | None -> "" + in + + let arg_hlp = + match def.arg_help with + | Some s -> s + | None -> "str" + in + + let default_value = + try + Printf.sprintf + (f_ " [%s]") + (Schema.get + schema + env + name) + with Not_set _ -> + "" + in + + let args = + match def.cli with + | CLINone -> + [] + | CLIAuto -> + [ + arg_concat "--" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIWith -> + [ + arg_concat "--with-" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIEnable -> + [ + arg_concat "--enable-" arg_name, + Arg.Unit (fun () -> var_set "true"), + Printf.sprintf (f_ " %s%s") hlp + (if default_value = " [true]" then + (s_ " [default]") + else + ""); + + arg_concat "--disable-" arg_name, + Arg.Unit (fun () -> var_set "false"), + Printf.sprintf (f_ " %s%s") hlp + (if default_value = " [false]" then + (s_ " [default]") + else + ""); + ] + | CLIUser lst -> + lst + in + args :: acc) + [] + schema) +end + +module BaseExec = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseExec.ml" + + open OASISGettext + open OASISUtils + open BaseMessage + + let run ?f_exit_code cmd args = + let cmdline = + String.concat " " (cmd :: args) + in + info (f_ "Running command '%s'") cmdline; + match f_exit_code, Sys.command cmdline with + | None, 0 -> () + | None, i -> + failwithf2 + (f_ "Command '%s' terminated with error code %d") + cmdline i + | Some f, i -> + f i + + let run_read_output cmd args = + let fn = + Filename.temp_file "oasis-" ".txt" + in + let () = + try + run cmd (args @ [">"; Filename.quote fn]) + with e -> + Sys.remove fn; + raise e + in + let chn = + open_in fn + in + let routput = + ref [] + in + ( + try + while true do + routput := (input_line chn) :: !routput + done + with End_of_file -> + () + ); + close_in chn; + Sys.remove fn; + List.rev !routput + + let run_read_one_line cmd args = + match run_read_output cmd args with + | [fst] -> + fst + | lst -> + failwithf1 + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) +end + +module BaseFileUtil = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseFileUtil.ml" + + open OASISGettext + + let find_file paths exts = + + (* Cardinal product of two list *) + let ( * ) lst1 lst2 = + List.flatten + (List.map + (fun a -> + List.map + (fun b -> a,b) + lst2) + lst1) + in + + let rec combined_paths lst = + match lst with + | p1 :: p2 :: tl -> + let acc = + (List.map + (fun (a,b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) + | [e] -> + e + | [] -> + [] + in + + let alternatives = + List.map + (fun (p,e) -> + if String.length e > 0 && e.[0] <> '.' then + p ^ "." ^ e + else + p ^ e) + ((combined_paths paths) * exts) + in + List.find + Sys.file_exists + alternatives + + let which prg = + let path_sep = + match Sys.os_type with + | "Win32" -> + ';' + | _ -> + ':' + in + let path_lst = + OASISUtils.split + path_sep + (Sys.getenv "PATH") + in + let exec_ext = + match Sys.os_type with + | "Win32" -> + "" + :: + (OASISUtils.split + path_sep + (Sys.getenv "PATHEXT")) + | _ -> + [""] + in + find_file [path_lst; [prg]] exec_ext + + (**/**) + let rec fix_dir dn = + (* Windows hack because Sys.file_exists "src\\" = false when + * Sys.file_exists "src" = true + *) + let ln = + String.length dn + in + if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then + fix_dir (String.sub dn 0 (ln - 1)) + else + dn + + let q = Filename.quote + (**/**) + + let cp src tgt = + BaseExec.run + (match Sys.os_type with + | "Win32" -> "copy" + | _ -> "cp") + [q src; q tgt] + + let mkdir tgt = + BaseExec.run + (match Sys.os_type with + | "Win32" -> "md" + | _ -> "mkdir") + [q tgt] + + let rec mkdir_parent f tgt = + let tgt = + fix_dir tgt + in + if Sys.file_exists tgt then + begin + if not (Sys.is_directory tgt) then + OASISUtils.failwithf1 + (f_ "Cannot create directory '%s', a file of the same name already \ + exists") + tgt + end + else + begin + mkdir_parent f (Filename.dirname tgt); + if not (Sys.file_exists tgt) then + begin + f tgt; + mkdir tgt + end + end + + let rmdir tgt = + if Sys.readdir tgt = [||] then + begin + match Sys.os_type with + | "Win32" -> + BaseExec.run "rd" [q tgt] + | _ -> + BaseExec.run "rm" ["-r"; q tgt] + end + + let glob fn = + let basename = + Filename.basename fn + in + if String.length basename >= 2 && + basename.[0] = '*' && + basename.[1] = '.' then + begin + let ext_len = + (String.length basename) - 2 + in + let ext = + String.sub basename 2 ext_len + in + let dirname = + Filename.dirname fn + in + Array.fold_left + (fun acc fn -> + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) + ext_len + in + if fn_ext = ext then + (Filename.concat dirname fn) :: acc + else + acc + with Invalid_argument _ -> + acc) + [] + (Sys.readdir dirname) + end + else + begin + if Sys.file_exists fn then + [fn] + else + [] + end +end + +module BaseArgExt = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseArgExt.ml" + + open OASISUtils + open OASISGettext + + let parse argv args = + (* Simulate command line for Arg *) + let current = + ref 0 + in + + try + Arg.parse_argv + ~current:current + (Array.concat [[|"none"|]; argv]) + (Arg.align args) + (failwithf1 (f_ "Don't know what to do with arguments: '%s'")) + (s_ "configure options:") + with + | Arg.Help txt -> + print_endline txt; + exit 0 + | Arg.Bad txt -> + prerr_endline txt; + exit 1 +end + +module BaseCheck = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseCheck.ml" + + open BaseEnv + open BaseMessage + open OASISUtils + open OASISGettext + + let prog_best prg prg_lst = + var_redefine + prg + (lazy + (let alternate = + List.fold_left + (fun res e -> + match res with + | Some _ -> + res + | None -> + try + Some (BaseFileUtil.which e) + with Not_found -> + None) + None + prg_lst + in + match alternate with + | Some prg -> prg + | None -> raise Not_found)) + + let prog prg = + prog_best prg [prg] + + let prog_opt prg = + prog_best prg [prg^".opt"; prg] + + let ocamlfind = + prog "ocamlfind" + + let version + var_prefix + cmp + fversion + () = + (* Really compare version provided *) + let var = + var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) + in + var_redefine + ~hide:true + var + (lazy + (let version_str = + match fversion () with + | "[Distributed with OCaml]" -> + begin + try + (var_get "ocaml_version") + with Not_found -> + warning + (f_ "Variable ocaml_version not defined, fallback \ + to default"); + Sys.ocaml_version + end + | res -> + res + in + let version = + OASISVersion.version_of_string version_str + in + if OASISVersion.comparator_apply version cmp then + version_str + else + failwithf3 + (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") + var_prefix + (OASISVersion.string_of_comparator cmp) + version_str)) + () + + let package_version pkg = + BaseExec.run_read_one_line + (ocamlfind ()) + ["query"; "-format"; "%v"; pkg] + + let package ?version_comparator pkg () = + let var = + OASISUtils.varname_concat + "pkg_" + (OASISUtils.varname_of_string pkg) + in + let findlib_dir pkg = + let dir = + BaseExec.run_read_one_line + (ocamlfind ()) + ["query"; "-format"; "%d"; pkg] + in + if Sys.file_exists dir && Sys.is_directory dir then + dir + else + failwithf2 + (f_ "When looking for findlib package %s, \ + directory %s return doesn't exist") + pkg dir + in + let vl = + var_redefine + var + (lazy (findlib_dir pkg)) + () + in + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl +end + +module BaseOCamlcConfig = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseOCamlcConfig.ml" + + + open BaseEnv + open OASISUtils + open OASISGettext + + module SMap = Map.Make(String) + + let ocamlc = + BaseCheck.prog_opt "ocamlc" + + let ocamlc_config_map = + (* Map name to value for ocamlc -config output + (name ^": "^value) + *) + let rec split_field mp lst = + match lst with + | line :: tl -> + let mp = + try + let pos_semicolon = + String.index line ':' + in + if pos_semicolon > 1 then + ( + let name = + String.sub line 0 pos_semicolon + in + let linelen = + String.length line + in + let value = + if linelen > pos_semicolon + 2 then + String.sub + line + (pos_semicolon + 2) + (linelen - pos_semicolon - 2) + else + "" + in + SMap.add name value mp + ) + else + ( + mp + ) + with Not_found -> + ( + mp + ) + in + split_field mp tl + | [] -> + mp + in + + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (lazy + (var_protect + (Marshal.to_string + (split_field + SMap.empty + (BaseExec.run_read_output + (ocamlc ()) ["-config"])) + []))) + + let var_define nm = + (* Extract data from ocamlc -config *) + let avlbl_config_get () = + Marshal.from_string + (ocamlc_config_map ()) + 0 + in + let nm_config = + match nm with + | "ocaml_version" -> "version" + | _ -> nm + in + var_redefine + nm + (lazy + (try + let map = + avlbl_config_get () + in + let value = + SMap.find nm_config map + in + value + with Not_found -> + failwithf2 + (f_ "Cannot find field '%s' in '%s -config' output") + nm + (ocamlc ()))) + +end + +module BaseStandardVar = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseStandardVar.ml" + + + open OASISGettext + open OASISTypes + open OASISExpr + open BaseCheck + open BaseEnv + + let ocamlfind = BaseCheck.ocamlfind + let ocamlc = BaseOCamlcConfig.ocamlc + let ocamlopt = prog_opt "ocamlopt" + let ocamlbuild = prog "ocamlbuild" + + + (**/**) + let rpkg = + ref None + + let pkg_get () = + match !rpkg with + | Some pkg -> pkg + | None -> failwith (s_ "OASIS Package is not set") + (**/**) + + let pkg_name = + var_define + ~short_desc:(fun () -> s_ "Package name") + "pkg_name" + (lazy (pkg_get ()).name) + + let pkg_version = + var_define + ~short_desc:(fun () -> s_ "Package version") + "pkg_version" + (lazy + (OASISVersion.string_of_version (pkg_get ()).version)) + + let c = BaseOCamlcConfig.var_define + + let os_type = c "os_type" + let system = c "system" + let architecture = c "architecture" + let ccomp_type = c "ccomp_type" + let ocaml_version = c "ocaml_version" + + (* TODO: Check standard variable presence at runtime *) + + let standard_library_default = c "standard_library_default" + let standard_library = c "standard_library" + let standard_runtime = c "standard_runtime" + let bytecomp_c_compiler = c "bytecomp_c_compiler" + let native_c_compiler = c "native_c_compiler" + let model = c "model" + let ext_obj = c "ext_obj" + let ext_asm = c "ext_asm" + let ext_lib = c "ext_lib" + let ext_dll = c "ext_dll" + let default_executable_name = c "default_executable_name" + let systhread_supported = c "systhread_supported" + + + (**/**) + let p name hlp dflt = + var_define + ~short_desc:hlp + ~cli:CLIAuto + ~arg_help:"dir" + name + dflt + + let (/) a b = + if os_type () = Sys.os_type then + Filename.concat a b + else if os_type () = "Unix" then + BaseFilePath.Unix.concat a b + else + OASISUtils.failwithf1 + (f_ "Cannot handle os_type %s filename concat") + (os_type ()) + (**/**) + + let prefix = + p "prefix" + (fun () -> s_ "Install architecture-independent files dir") + (lazy + (match os_type () with + | "Win32" -> + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) + | _ -> + "/usr/local")) + + let exec_prefix = + p "exec_prefix" + (fun () -> s_ "Install architecture-dependent files in dir") + (lazy "$prefix") + + let bindir = + p "bindir" + (fun () -> s_ "User executables") + (lazy ("$exec_prefix"/"bin")) + + let sbindir = + p "sbindir" + (fun () -> s_ "System admin executables") + (lazy ("$exec_prefix"/"sbin")) + + let libexecdir = + p "libexecdir" + (fun () -> s_ "Program executables") + (lazy ("$exec_prefix"/"libexec")) + + let sysconfdir = + p "sysconfdir" + (fun () -> s_ "Read-only single-machine data") + (lazy ("$prefix"/"etc")) + + let sharedstatedir = + p "sharedstatedir" + (fun () -> s_ "Modifiable architecture-independent data") + (lazy ("$prefix"/"com")) + + let localstatedir = + p "localstatedir" + (fun () -> s_ "Modifiable single-machine data") + (lazy ("$prefix"/"var")) + + let libdir = + p "libdir" + (fun () -> s_ "Object code libraries") + (lazy ("$exec_prefix"/"lib")) + + let datarootdir = + p "datarootdir" + (fun () -> s_ "Read-only arch-independent data root") + (lazy ("$prefix"/"share")) + + let datadir = + p "datadir" + (fun () -> s_ "Read-only architecture-independent data") + (lazy ("$datarootdir")) + + let infodir = + p "infodir" + (fun () -> s_ "Info documentation") + (lazy ("$datarootdir"/"info")) + + let localedir = + p "localedir" + (fun () -> s_ "Locale-dependent data") + (lazy ("$datarootdir"/"locale")) + + let mandir = + p "mandir" + (fun () -> s_ "Man documentation") + (lazy ("$datarootdir"/"man")) + + let docdir = + p "docdir" + (fun () -> s_ "Documentation root") + (lazy ("$datarootdir"/"doc"/"$pkg_name")) + + let htmldir = + p "htmldir" + (fun () -> s_ "HTML documentation") + (lazy ("$docdir")) + + let dvidir = + p "dvidir" + (fun () -> s_ "DVI documentation") + (lazy ("$docdir")) + + let pdfdir = + p "pdfdir" + (fun () -> s_ "PDF documentation") + (lazy ("$docdir")) + + let psdir = + p "psdir" + (fun () -> s_ "PS documentation") + (lazy ("$docdir")) + + let destdir = + p "destdir" + (fun () -> s_ "Prepend a path when installing package") + (lazy + (raise + (PropList.Not_set + ("destdir", + Some (s_ "undefined by construct"))))) + + let findlib_version = + var_define + "findlib_version" + (lazy + (BaseCheck.package_version "findlib")) + + let is_native = + var_define + "is_native" + (lazy + (try + let _s : string = + ocamlopt () + in + "true" + with PropList.Not_set _ -> + let _s : string = + ocamlc () + in + "false")) + + let ext_program = + var_define + "suffix_program" + (lazy + (match os_type () with + | "Win32" -> ".exe" + | _ -> "" + )) + + let rm = + var_define + ~short_desc:(fun () -> s_ "Remove a file.") + "rm" + (lazy + (match os_type () with + | "Win32" -> "del" + | _ -> "rm -f")) + + let rmdir = + var_define + ~short_desc:(fun () -> s_ "Remove a directory.") + "rmdir" + (lazy + (match os_type () with + | "Win32" -> "rd" + | _ -> "rm -rf")) + + let debug = + var_define + ~short_desc:(fun () -> s_ "Compile with ocaml debug flag on.") + "debug" + (lazy "true") + + let profile = + var_define + ~short_desc:(fun () -> s_ "Compile with ocaml profile flag on.") + "profile" + (lazy "false") + + let init pkg = + rpkg := Some pkg + +end + +module BaseFileAB = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseFileAB.ml" + + open BaseEnv + open OASISGettext + open BaseMessage + + let to_filename fn = + let fn = + BaseFilePath.of_unix fn + in + if not (Filename.check_suffix fn ".ab") then + warning + (f_ "File '%s' doesn't have '.ab' extension") + fn; + Filename.chop_extension fn + + let replace fn_lst = + let buff = + Buffer.create 13 + in + List.iter + (fun fn -> + let fn = + BaseFilePath.of_unix fn + in + let chn_in = + open_in fn + in + let chn_out = + open_out (to_filename fn) + in + ( + try + while true do + Buffer.add_string buff (var_expand (input_line chn_in)); + Buffer.add_char buff '\n' + done + with End_of_file -> + () + ); + Buffer.output_buffer chn_out buff; + Buffer.clear buff; + close_in chn_in; + close_out chn_out) + fn_lst +end + +module BaseLog = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseLog.ml" + + open OASISUtils + + let default_filename = + Filename.concat + (Filename.dirname BaseEnv.default_filename) + "setup.log" + + module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + + let load () = + if Sys.file_exists default_filename then + begin + let chn = + open_in default_filename + in + let scbuf = + Scanf.Scanning.from_file default_filename + in + let rec read_aux (st, lst) = + if not (Scanf.Scanning.end_of_input scbuf) then + begin + let acc = + try + Scanf.bscanf scbuf "%S %S@\n" + (fun e d -> + let t = + e, d + in + if SetTupleString.mem t st then + st, lst + else + SetTupleString.add t st, + t :: lst) + with Scanf.Scan_failure _ -> + failwith + (Scanf.bscanf scbuf + "%l" + (fun line -> + Printf.sprintf + "Malformed log file '%s' at line %d" + default_filename + line)) + in + read_aux acc + end + else + begin + close_in chn; + List.rev lst + end + in + read_aux (SetTupleString.empty, []) + end + else + begin + [] + end + + let register event data = + let chn_out = + open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename + in + Printf.fprintf chn_out "%S %S\n" event data; + close_out chn_out + + let unregister event data = + if Sys.file_exists default_filename then + begin + let lst = + load () + in + let chn_out = + open_out default_filename + in + let write_something = + ref false + in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + begin + write_something := true; + Printf.fprintf chn_out "%S %S\n" e d + end) + lst; + close_out chn_out; + if not !write_something then + Sys.remove default_filename + end + + let filter events = + let st_events = + List.fold_left + (fun st e -> + SetString.add e st) + SetString.empty + events + in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ()) + + let exists event data = + List.exists + (fun v -> (event, data) = v) + (load ()) +end + +module BaseBuilt = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseBuilt.ml" + + open OASISTypes + open OASISGettext + open BaseStandardVar + open BaseMessage + + type t = + | BExec (* Executable *) + | BExecLib (* Library coming with executable *) + | BLib (* Library *) + | BDoc (* Document *) + + let to_log_event_file t nm = + "built_"^ + (match t with + | BExec -> "exec" + | BExecLib -> "exec_lib" + | BLib -> "lib" + | BDoc -> "doc")^ + "_"^nm + + let to_log_event_done t nm = + "is_"^(to_log_event_file t nm) + + let register t nm lst = + BaseLog.register + (to_log_event_done t nm) + "true"; + List.iter + (fun alt -> + let registered = + List.fold_left + (fun registered fn -> + if Sys.file_exists fn then + begin + BaseLog.register + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end + else + registered) + false + alt + in + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) + lst + + let unregister t nm = + List.iter + (fun (e, d) -> + BaseLog.unregister e d) + (BaseLog.filter + [to_log_event_file t nm; + to_log_event_done t nm]) + + let fold t nm f acc = + List.fold_left + (fun acc (_, fn) -> + if Sys.file_exists fn then + begin + f acc fn + end + else + begin + warning + (f_ "File '%s' has been marked as built \ + for %s but doesn't exist") + fn + (Printf.sprintf + (match t with + | BExec | BExecLib -> + (f_ "executable %s") + | BLib -> + (f_ "library %s") + | BDoc -> + (f_ "documentation %s")) + nm); + acc + end) + acc + (BaseLog.filter + [to_log_event_file t nm]) + + let is_built t nm = + List.fold_left + (fun is_built (_, d) -> + (try + bool_of_string d + with _ -> + false)) + false + (BaseLog.filter + [to_log_event_done t nm]) + + let of_executable ffn (cs, bs, exec) = + let unix_exec_is, unix_dll_opt = + OASISExecutable.unix_exec_is + (cs, bs, exec) + (fun () -> + bool_of_string + (is_native ())) + ext_dll + ext_program + in + let evs = + (BExec, cs.cs_name, [[ffn unix_exec_is]]) + :: + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) + in + evs, + unix_exec_is, + unix_dll_opt + + let of_library ffn (cs, bs, lib) = + let unix_lst = + OASISLibrary.generated_unix_files + ~ctxt:!BaseContext.default + (cs, bs, lib) + (fun fn -> + Sys.file_exists (BaseFilePath.of_unix fn)) + (fun () -> + bool_of_string (is_native ())) + ext_lib + ext_dll + in + let evs = + [BLib, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + +end + +module BaseCustom = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseCustom.ml" + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + let run cmd args extra_args = + BaseExec.run + (var_expand cmd) + (List.map + var_expand + (args @ (Array.to_list extra_args))) + + let hook ?(failsafe=false) cstm f e = + let optional_command lst = + let printer = + function + | Some (cmd, args) -> String.concat " " (cmd :: args) + | None -> s_ "No command" + in + match + var_choose + ~name:(s_ "Pre/Post Command") + ~printer + lst with + | Some (cmd, args) -> + begin + try + run cmd args [||] + with e when failsafe -> + warning + (f_ "Command '%s' fail with error: %s") + (String.concat " " (cmd :: args)) + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + end + | None -> + () + in + let res = + optional_command cstm.pre_command; + f e + in + optional_command cstm.post_command; + res +end + +module BaseDynVar = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseDynVar.ml" + + + open OASISTypes + open OASISGettext + open BaseEnv + open BaseBuilt + + let init pkg = + List.iter + (function + | Executable (cs, bs, exec) -> + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + cs.cs_name + (lazy + (let fn_opt = + fold + BExec cs.cs_name + (fun _ fn -> Some fn) + None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name)))))) + + | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) + pkg.sections +end + +module BaseTest = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseTest.ml" + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISExpr + open OASISGettext + + let test lst pkg extra_args = + + let one_test (failure, n) (test_plugin, cs, test) = + if var_choose + ~name:(Printf.sprintf + (f_ "test %s run") + cs.cs_name) + ~printer:string_of_bool + test.test_run then + begin + let () = + info (f_ "Running test '%s'") cs.cs_name + in + let back_cwd = + match test.test_working_directory with + | Some dir -> + let cwd = + Sys.getcwd () + in + let chdir d = + info (f_ "Changing directory to '%s'") d; + Sys.chdir d + in + chdir dir; + fun () -> chdir cwd + + | None -> + fun () -> () + in + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end + end + else + begin + info (f_ "Skipping test '%s'") cs.cs_name; + (failure, n) + end + in + let (failed, n) = + List.fold_left + one_test + (0.0, 0) + lst + in + let failure_percent = + if n = 0 then + 0.0 + else + failed /. (float_of_int n) + in + let msg = + Printf.sprintf + (f_ "Tests had a %.2f%% failure rate") + (100. *. failure_percent) + in + if failure_percent > 0.0 then + failwith msg + else + info "%s" msg +end + +module BaseDoc = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseDoc.ml" + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + let doc lst pkg extra_args = + + let one_doc (doc_plugin, cs, doc) = + if var_choose + ~name:(Printf.sprintf + (f_ "documentation %s build") + cs.cs_name) + ~printer:string_of_bool + doc.doc_build then + begin + info (f_ "Building documentation '%s'") cs.cs_name; + BaseCustom.hook + doc.doc_custom + (doc_plugin pkg (cs, doc)) + extra_args + end + in + List.iter + one_doc + lst +end + +module BaseSetup = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseSetup.ml" + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISSection + open OASISGettext + open OASISUtils + + type std_args_fun = + package -> string array -> unit + + type ('a, 'b) section_args_fun = + name * (package -> (common_section * 'a) -> string array -> 'b) + + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + version: string; + } + + (* Associate a plugin function with data from package *) + let join_plugin_sections filter_map lst = + List.rev + (List.fold_left + (fun acc sct -> + match filter_map sct with + | Some e -> + e :: acc + | None -> + acc) + [] + lst) + + (* Search for plugin data associated with a section name *) + let lookup_plugin_section plugin action nm lst = + try + List.assoc nm lst + with Not_found -> + failwithf3 + (f_ "Cannot find plugin %s matching section %s for %s action") + plugin + nm + action + + let configure t args = + (* Run configure *) + BaseCustom.hook + t.package.conf_custom + (t.configure t.package) + args; + + (* Reload environment *) + unload (); + load (); + + (* Replace data in file *) + BaseFileAB.replace t.package.files_ab + + let build t args = + BaseCustom.hook + t.package.build_custom + (t.build t.package) + args + + let doc t args = + BaseDoc.doc + (join_plugin_sections + (function + | Doc (cs, e) -> + Some + (lookup_plugin_section + "documentation" + (s_ "build") + cs.cs_name + t.doc, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + let test t args = + BaseTest.test + (join_plugin_sections + (function + | Test (cs, e) -> + Some + (lookup_plugin_section + "test" + (s_ "run") + cs.cs_name + t.test, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + let all t args = + let rno_doc = + ref false + in + let rno_test = + ref false + in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: + (Array.to_list args))) + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc target"; + + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; + ] + (failwithf1 (f_ "Don't know what to do with '%s'")) + ""; + + info "Running configure step"; + configure t [||]; + + info "Running build step"; + build t [||]; + + (* Load setup.log dynamic variables *) + BaseDynVar.init t.package; + + if not !rno_doc then + begin + info "Running doc step"; + doc t [||]; + end + else + begin + info "Skipping doc step" + end; + + if not !rno_test then + begin + info "Running test step"; + test t [||] + end + else + begin + info "Skipping test step" + end + + let install t args = + BaseCustom.hook + t.package.install_custom + (t.install t.package) + args + + let uninstall t args = + BaseCustom.hook + t.package.uninstall_custom + (t.uninstall t.package) + args + + let reinstall t args = + uninstall t args; + install t args + + let clean, distclean = + let failsafe f a = + try + f a + with e -> + warning + (f_ "Action fail with error: %s") + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + in + + let generic_clean t cstm mains docs tests args = + BaseCustom.hook + ~failsafe:true + cstm + (fun () -> + (* Clean section *) + List.iter + (function + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, test)) + args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, doc)) + args + | Library _ + | Executable _ + | Flag _ + | SrcRepo _ -> + ()) + t.package.sections; + (* Clean whole package *) + List.iter + (fun f -> + failsafe + (f t.package) + args) + mains) + () + in + + let clean t args = + generic_clean + t + t.package.clean_custom + t.clean + t.clean_doc + t.clean_test + args + in + + let distclean t args = + (* Call clean *) + clean t args; + + (* Remove generated file *) + List.iter + (fun fn -> + if Sys.file_exists fn then + begin + info (f_ "Remove '%s'") fn; + Sys.remove fn + end) + (BaseEnv.default_filename + :: + BaseLog.default_filename + :: + (List.rev_map BaseFileAB.to_filename t.package.files_ab)); + + (* Call distclean code *) + generic_clean + t + t.package.distclean_custom + t.distclean + t.distclean_doc + t.distclean_test + args + in + + clean, distclean + + let version t _ = + print_endline t.version + + let setup t = + let catch_exn = + ref true + in + try + let act_ref = + ref (fun _ -> + failwithf2 + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) + + in + let extra_args_ref = + ref [] + in + let allow_empty_env_ref = + ref false + in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + + Arg.parse + (Arg.align + [ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ (BaseContext.args ())) + (failwithf1 (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n"); + + (* Build initial environment *) + load ~allow_empty:!allow_empty_env_ref (); + + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (lazy (string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices)))) + in + match hlp with + | Some hlp -> + apply ~short_desc:(fun () -> hlp) () + | None -> + apply () + end + | _ -> + ()) + t.package.sections; + + BaseStandardVar.init t.package; + + BaseDynVar.init t.package; + + !act_ref t (Array.of_list (List.rev !extra_args_ref)) + + with e when !catch_exn -> + error "%s" (string_of_exception e); + exit 1 + +end + +module BaseDev = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseDev.ml" + + + + open OASISGettext + open BaseMessage + + type t = + { + oasis_cmd: string; + } + + let update_and_run t = + (* Command line to run setup-dev *) + let oasis_args = + "setup-dev" :: "-run" :: + Sys.executable_name :: + (Array.to_list Sys.argv) + in + + let exit_on_child_error = + function + | 0 -> () + | 2 -> + (* Bad CLI arguments *) + error + (f_ "The command '%s %s' exit with code 2. It often means that we \ + don't use the right command-line arguments, rerun \ + 'oasis setup-dev'.") + t.oasis_cmd + (String.concat " " oasis_args) + + | 127 -> + (* Cannot find OASIS *) + error + (f_ "Cannot find executable '%s', check where 'oasis' is located \ + and rerun 'oasis setup-dev'") + t.oasis_cmd + + | i -> + exit i + in + + let () = + (* Run OASIS to generate a temporary setup.ml + *) + BaseExec.run + ~f_exit_code:exit_on_child_error + t.oasis_cmd + oasis_args + in + + () + +end + + +module InternalConfigurePlugin = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/internal/InternalConfigurePlugin.ml" + + (** Configure using internal scheme + @author Sylvain Le Gall + *) + + open BaseEnv + open OASISTypes + open OASISUtils + open OASISGettext + open BaseMessage + + (** Configure build using provided series of check to be done + * and then output corresponding file. + *) + let configure pkg argv = + let var_ignore_eval var = + let _s : string = + var () + in + () + in + + let errors = + ref SetString.empty + in + + let buff = + Buffer.create 13 + in + + let add_errors fmt = + Printf.kbprintf + (fun b -> + errors := SetString.add (Buffer.contents b) !errors; + Buffer.clear b) + buff + fmt + in + + let warn_exception e = + warning "%s" (string_of_exception e) + in + + (* Check tools *) + let check_tools lst = + List.iter + (function + | ExternalTool tool -> + begin + try + var_ignore_eval (BaseCheck.prog tool) + with e -> + warn_exception e; + add_errors (f_ "Cannot find external tool '%s'") tool + end + | InternalExecutable nm1 -> + (* Check that matching tool is built *) + List.iter + (function + | Executable ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal executable \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + lst + in + + let build_checks sct bs = + if var_choose bs.bs_build then + begin + if bs.bs_compiled_object = Native then + begin + try + var_ignore_eval BaseStandardVar.ocamlopt + with e -> + warn_exception e; + add_errors + (f_ "Section %s requires native compilation") + (OASISSection.string_of_section sct) + end; + + (* Check tools *) + check_tools bs.bs_build_tools; + + (* Check depends *) + List.iter + (function + | FindlibPackage (findlib_pkg, version_comparator) -> + begin + try + var_ignore_eval + (BaseCheck.package ?version_comparator findlib_pkg) + with e -> + warn_exception e; + match version_comparator with + | None -> + add_errors + (f_ "Cannot find findlib package %s") + findlib_pkg + | Some ver_cmp -> + add_errors + (f_ "Cannot find findlib package %s (%s)") + findlib_pkg + (OASISVersion.string_of_comparator ver_cmp) + end + | InternalLibrary nm1 -> + (* Check that matching library is built *) + List.iter + (function + | Library ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal library \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + bs.bs_build_depends + end + in + + (* Parse command line *) + BaseArgExt.parse argv (BaseEnv.args ()); + + (* OCaml version *) + begin + match pkg.ocaml_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "ocaml" + ver_cmp + BaseStandardVar.ocaml_version) + with e -> + warn_exception e; + add_errors + (f_ "OCaml version %s doesn't match version constraint %s") + (BaseStandardVar.ocaml_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* Findlib version *) + begin + match pkg.findlib_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "findlib" + ver_cmp + BaseStandardVar.findlib_version) + with e -> + warn_exception e; + add_errors + (f_ "Findlib version %s doesn't match version constraint %s") + (BaseStandardVar.findlib_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* Check build depends *) + List.iter + (function + | Executable (_, bs, _) + | Library (_, bs, _) as sct -> + build_checks sct bs + | Doc (_, doc) -> + if var_choose doc.doc_build then + check_tools doc.doc_build_tools + | Test (_, test) -> + if var_choose test.test_run then + check_tools test.test_tools + | _ -> + ()) + pkg.sections; + + (* Save and print environment *) + if SetString.empty = !errors then + begin + dump (); + print () + end + else + begin + List.iter + (fun e -> error "%s" e) + (SetString.elements !errors); + failwithf1 + (fn_ + "%d configuration error" + "%d configuration errors" + (SetString.cardinal !errors)) + (SetString.cardinal !errors) + end + +end + +module InternalInstallPlugin = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/internal/InternalInstallPlugin.ml" + + (** Install using internal scheme + @author Sylvain Le Gall + *) + + open BaseEnv + open BaseStandardVar + open BaseMessage + open OASISTypes + open OASISLibrary + open OASISGettext + open OASISUtils + + let exec_hook = + ref (fun (cs, bs, exec) -> cs, bs, exec) + + let lib_hook = + ref (fun (cs, bs, lib) -> cs, bs, lib, []) + + let doc_hook = + ref (fun (cs, doc) -> cs, doc) + + let install_file_ev = + "install-file" + + let install_dir_ev = + "install-dir" + + let install_findlib_ev = + "install-findlib" + + let install pkg argv = + + let in_destdir = + try + let destdir = + destdir () + in + (* Practically speaking destdir is prepended + * at the beginning of the target filename + *) + fun fn -> destdir^fn + with PropList.Not_set _ -> + fun fn -> fn + in + + let install_file src_file envdir = + let tgt_dir = + in_destdir (envdir ()) + in + let tgt_file = + Filename.concat + tgt_dir + (Filename.basename src_file) + in + (* Create target directory if needed *) + BaseFileUtil.mkdir_parent + (fun dn -> + info (f_ "Creating directory '%s'") dn; + BaseLog.register install_dir_ev dn) + tgt_dir; + + (* Really install files *) + info (f_ "Copying file '%s' to '%s'") src_file tgt_file; + BaseFileUtil.cp src_file tgt_file; + BaseLog.register install_file_ev tgt_file + in + + (* Install data into defined directory *) + let install_data srcdir lst tgtdir = + let tgtdir = + BaseFilePath.of_unix (var_expand tgtdir) + in + List.iter + (fun (src, tgt_opt) -> + let real_srcs = + BaseFileUtil.glob + (Filename.concat srcdir src) + in + if real_srcs = [] then + failwithf1 + (f_ "Wildcard '%s' doesn't match any files") + src; + List.iter + (fun fn -> + install_file + fn + (fun () -> + match tgt_opt with + | Some s -> + BaseFilePath.of_unix (var_expand s) + | None -> + tgtdir)) + real_srcs) + lst + in + + (** Install all libraries *) + let install_libs pkg = + + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, lib_extra = + !lib_hook data_lib + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then + begin + let acc = + (* Start with acc + lib_extra *) + List.rev_append lib_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + BaseFilePath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + Sys.file_exists + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + OASISUnixPath.uncapitalize_file modul^".mli"; + OASISUnixPath.capitalize_file modul^".mli"; + OASISUnixPath.uncapitalize_file modul^".ml"; + OASISUnixPath.capitalize_file modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in library %s") + modul cs.cs_name; + acc + end) + acc + lib.lib_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the library *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + in + + (* Install one group of library *) + let install_group_lib grp = + (* Iterate through all group nodes *) + let rec install_group_lib_aux data_and_files grp = + let data_and_files, children = + match grp with + | Container (_, children) -> + data_and_files, children + | Package (_, cs, bs, lib, children) -> + files_of_library data_and_files (cs, bs, lib), children + in + List.fold_left + install_group_lib_aux + data_and_files + children + in + + (* Findlib name of the root library *) + let findlib_name = + findlib_of_group grp + in + + (* Determine root library *) + let root_lib = + root_of_group grp + in + + (* All files to install for this library *) + let f_data, files = + install_group_lib_aux (ignore, []) grp + in + + (* Really install, if there is something to install *) + if files = [] then + begin + warning + (f_ "Nothing to install for findlib library '%s'") + findlib_name + end + else + begin + let meta = + (* Search META file *) + let (_, bs, _) = + root_lib + in + let res = + Filename.concat bs.bs_path "META" + in + if not (Sys.file_exists res) then + failwithf2 + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + info + (f_ "Installing findlib library '%s'") + findlib_name; + BaseExec.run + (ocamlfind ()) + ("install" :: findlib_name :: meta :: files); + BaseLog.register install_findlib_ev findlib_name + end; + + (* Install data files *) + f_data (); + + in + + (* We install libraries in groups *) + List.iter + install_group_lib + (group_libs pkg) + in + + let install_execs pkg = + let install_exec data_exec = + let (cs, bs, exec) = + !exec_hook data_exec + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then + begin + let exec_libdir () = + Filename.concat + (libdir ()) + pkg.name + in + BaseBuilt.fold + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file + fn + bindir) + (); + BaseBuilt.fold + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> + install_file + fn + exec_libdir) + (); + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name) + end + in + List.iter + (function + | Executable (cs, bs, exec)-> + install_exec (cs, bs, exec) + | _ -> + ()) + pkg.sections + in + + let install_docs pkg = + let install_doc data = + let (cs, doc) = + !doc_hook data + in + if var_choose doc.doc_install && + BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then + begin + let tgt_dir = + BaseFilePath.of_unix (var_expand doc.doc_install_dir) + in + BaseBuilt.fold + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> + install_file + fn + (fun () -> tgt_dir)) + (); + install_data + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end + in + List.iter + (function + | Doc (cs, doc) -> + install_doc (cs, doc) + | _ -> + ()) + pkg.sections + in + + install_libs pkg; + install_execs pkg; + install_docs pkg + + (* Uninstall already installed data *) + let uninstall _ argv = + List.iter + (fun (ev, data) -> + if ev = install_file_ev then + begin + if Sys.file_exists data then + begin + info + (f_ "Removing file '%s'") + data; + Sys.remove data + end + else + begin + warning + (f_ "File '%s' doesn't exist anymore") + data + end + end + else if ev = install_dir_ev then + begin + if Sys.file_exists data && Sys.is_directory data then + begin + if Sys.readdir data = [||] then + begin + info + (f_ "Removing directory '%s'") + data; + BaseFileUtil.rmdir data + end + else + begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat + ", " + (Array.to_list + (Sys.readdir data))) + end + end + else + begin + warning + (f_ "Directory '%s' doesn't exist anymore") + data + end + end + else if ev = install_findlib_ev then + begin + info (f_ "Removing findlib library '%s'") data; + BaseExec.run (ocamlfind ()) ["remove"; data] + end + else + failwithf1 (f_ "Unknown log event '%s'") ev; + BaseLog.unregister ev data) + (* We process event in reverse order *) + (List.rev + (BaseLog.filter + [install_file_ev; + install_dir_ev; + install_findlib_ev;])) + +end + + +module OCamlbuildCommon = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/OCamlbuildCommon.ml" + + (** Functions common to OCamlbuild build and doc plugin + *) + + open OASISGettext + open BaseEnv + open BaseStandardVar + + let ocamlbuild_clean_ev = + "ocamlbuild-clean" + + let ocamlbuildflags = + var_define + ~short_desc:(fun () -> "OCamlbuild additional flags") + "ocamlbuildflags" + (lazy "") + + (** Fix special arguments depending on environment *) + let fix_args args extra_argv = + List.flatten + [ + if (os_type ()) = "Win32" then + [ + "-classic-display"; + "-no-log"; + "-no-links"; + "-install-lib-dir"; + (Filename.concat (standard_library ()) "ocamlbuild") + ] + else + []; + + if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then + [ + "-byte-plugin" + ] + else + []; + args; + + if bool_of_string (debug ()) then + ["-tag"; "debug"] + else + []; + + if bool_of_string (profile ()) then + ["-tag"; "profile"] + else + []; + + OASISUtils.split ' ' (ocamlbuildflags ()); + + Array.to_list extra_argv; + ] + + (** Run 'ocamlbuild -clean' if not already done *) + let run_clean extra_argv = + let extra_cli = + String.concat " " (Array.to_list extra_argv) + in + (* Run if never called with these args *) + if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then + begin + BaseExec.run (ocamlbuild ()) (fix_args ["-clean"] extra_argv); + BaseLog.register ocamlbuild_clean_ev extra_cli; + at_exit + (fun () -> + try + BaseLog.unregister ocamlbuild_clean_ev extra_cli + with _ -> + ()) + end + + (** Run ocamlbuild, unregister all clean events *) + let run_ocamlbuild args extra_argv = + (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html + *) + BaseExec.run (ocamlbuild ()) (fix_args args extra_argv); + (* Remove any clean event, we must run it again *) + List.iter + (fun (e, d) -> BaseLog.unregister e d) + (BaseLog.filter [ocamlbuild_clean_ev]) + + (** Determine real build directory *) + let build_dir extra_argv = + let rec search_args dir = + function + | "-build-dir" :: dir :: tl -> + search_args dir tl + | _ :: tl -> + search_args dir tl + | [] -> + dir + in + search_args "_build" (fix_args [] extra_argv) + +end + +module OCamlbuildPlugin = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" + + (** Build using ocamlbuild + @author Sylvain Le Gall + *) + + open OASISTypes + open OASISGettext + open OASISUtils + open BaseEnv + open OCamlbuildCommon + open BaseStandardVar + open BaseMessage + + type target = + | Std of string list + | StdRename of string * string + + let cond_targets_hook = + ref (fun lst -> lst) + + let build pkg argv = + + (* Return the filename in build directory *) + let in_build_dir fn = + Filename.concat + (build_dir argv) + fn + in + + (* Return the unix filename in host build directory *) + let in_build_dir_of_unix fn = + in_build_dir (BaseFilePath.of_unix fn) + in + + let cond_targets = + List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_library + in_build_dir_of_unix + (cs, bs, lib) + in + + let ends_with nd fn = + let nd_len = + String.length nd + in + (String.length fn >= nd_len) + && + (String.sub + fn + (String.length fn - nd_len) + nd_len) = nd + in + + let tgts = + List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ".cma" fn || + ends_with ".cmxa" fn || + ends_with ".cmxs" fn || + ends_with (ext_lib ()) fn || + ends_with (ext_dll ()) fn)) + unix_files) + in + + match tgts with + | hd :: tl -> + (evs, Std hd) + :: + (List.map (fun tgts -> [], Std tgts) tl) + @ + acc + | [] -> + failwithf2 + (f_ "No possible ocamlbuild targets \ + in generated files %s for library %s") + (String.concat (s_ ", " ) (List.map (String.concat (s_ ", ")) tgts)) + cs.cs_name + end + + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, unix_exec_is, unix_dll_opt = + BaseBuilt.of_executable + in_build_dir_of_unix + (cs, bs, exec) + in + + let host_exec_is = + in_build_dir_of_unix unix_exec_is + in + + let target ext = + let unix_tgt = + (BaseFilePath.Unix.concat + bs.bs_path + (BaseFilePath.Unix.chop_extension + exec.exec_main_is))^ext + in + + evs, + (if unix_tgt = unix_exec_is then + Std [unix_tgt] + else + StdRename (unix_tgt, host_exec_is)) + in + + (* Add executable *) + let acc = + match bs.bs_compiled_object with + | Native -> + (target ".native") :: acc + | Best when bool_of_string (is_native ()) -> + (target ".native") :: acc + | Byte + | Best -> + (target ".byte") :: acc + in + acc + end + + | Library _ | Executable _ | Test _ + | SrcRepo _ | Flag _ | Doc _ -> + acc) + [] + (* Keep the pkg.sections ordered *) + (List.rev pkg.sections); + in + + (* Check and register built files *) + let check_and_register (bt, bnm, lst) = + List.iter + (fun fns -> + if not (List.exists Sys.file_exists fns) then + failwithf1 + (f_ "No one of expected built files %s exists") + (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) + lst; + (BaseBuilt.register bt bnm lst) + in + + (* Run a list of target + post process *) + let run_ocamlbuild rtargets = + run_ocamlbuild + (List.rev_map snd rtargets) + argv; + List.iter + check_and_register + (List.flatten (List.rev_map fst rtargets)) + in + + (* Compare two files, return true if they differ *) + let diff fn1 fn2 = + if Sys.file_exists fn1 && Sys.file_exists fn2 then + begin + let chn1 = open_in fn1 in + let chn2 = open_in fn2 in + let res = + if in_channel_length chn1 = in_channel_length chn2 then + begin + let len = + 4096 + in + let str1 = + String.make len '\000' + in + let str2 = + String.copy str1 + in + try + while (String.compare str1 str2) = 0 do + really_input chn1 str1 0 len; + really_input chn2 str2 0 len + done; + true + with End_of_file -> + false + end + else + true + in + close_in chn1; close_in chn2; + res + end + else + true + in + + let last_rtargets = + List.fold_left + (fun acc (built, tgt) -> + match tgt with + | Std nms -> + (built, List.hd nms) :: acc + | StdRename (src, tgt) -> + begin + (* We run with a fake list for event registering *) + run_ocamlbuild (([], src) :: acc); + + (* And then copy and register *) + begin + let src_fn = + in_build_dir_of_unix src + in + if diff src_fn tgt then + BaseFileUtil.cp src_fn tgt + else + info + (f_ "No need to copy file '%s' to '%s', same content") + src_fn tgt + end; + List.iter check_and_register built; + [] + end) + [] + (!cond_targets_hook cond_targets) + in + if last_rtargets <> [] then + run_ocamlbuild last_rtargets + + let clean pkg extra_args = + run_clean extra_args; + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + +end + +module OCamlbuildDocPlugin = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" + + (* Create documentation using ocamlbuild .odocl files + @author Sylvain Le Gall + *) + + open OASISTypes + open OASISGettext + open OASISMessage + open OCamlbuildCommon + open BaseStandardVar + + + + let doc_build path pkg (cs, doc) argv = + let index_html = + BaseFilePath.Unix.make + [ + path; + cs.cs_name^".docdir"; + "index.html"; + ] + in + let tgt_dir = + BaseFilePath.make + [ + build_dir argv; + BaseFilePath.of_unix path; + cs.cs_name^".docdir"; + ] + in + run_ocamlbuild [index_html] argv; + List.iter + (fun glb -> + BaseBuilt.register + BaseBuilt.BDoc + cs.cs_name + [BaseFileUtil.glob + (Filename.concat tgt_dir glb)]) + ["*.html"; "*.css"] + + let doc_clean t pkg (cs, doc) argv = + run_clean argv; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + +end + + +module CustomPlugin = struct +# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/custom/CustomPlugin.ml" + + (** Generate custom configure/build/doc/test/install system + @author + *) + + open BaseEnv + open OASISGettext + open OASISTypes + + + + type t = + { + cmd_main: command_line conditional; + cmd_clean: (command_line option) conditional; + cmd_distclean: (command_line option) conditional; + } + + let run = BaseCustom.run + + let main t _ extra_args = + let cmd, args = + var_choose + ~name:(s_ "main command") + t.cmd_main + in + run cmd args extra_args + + let clean t pkg extra_args = + match var_choose t.cmd_clean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + let distclean t pkg extra_args = + match var_choose t.cmd_distclean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + module Build = + struct + let main t pkg extra_args = + main t pkg extra_args; + List.iter + (fun sct -> + let evs = + match sct with + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, _ = + BaseBuilt.of_library + BaseFilePath.of_unix + (cs, bs, lib) + in + evs + end + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, _, _ = + BaseBuilt.of_executable + BaseFilePath.of_unix + (cs, bs, exec) + in + evs + end + | _ -> + [] + in + List.iter + (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) + evs) + pkg.sections + + let clean t pkg extra_args = + clean t pkg extra_args; + (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild + * considering moving this to BaseSetup? + *) + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + let distclean t pkg extra_args = + distclean t pkg extra_args + end + + module Test = + struct + let main t pkg (cs, test) extra_args = + try + main t pkg extra_args; + 0.0 + with Failure s -> + BaseMessage.warning + (f_ "Test '%s' fails: %s") + cs.cs_name + s; + 1.0 + + let clean t pkg (cs, test) extra_args = + clean t pkg extra_args + + let distclean t pkg (cs, test) extra_args = + distclean t pkg extra_args + end + + module Doc = + struct + let main t pkg (cs, _) extra_args = + main t pkg extra_args; + BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] + + let clean t pkg (cs, _) extra_args = + clean t pkg extra_args; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + + let distclean t pkg (cs, _) extra_args = + distclean t pkg extra_args + end + +end + + +open OASISTypes;; + +let setup_t = + { + BaseSetup.configure = InternalConfigurePlugin.configure; + build = OCamlbuildPlugin.build; + test = + [ + ("unix", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test_unix", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("react", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test_react", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("core", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test_core", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + doc = + [ + ("lwt-api", OCamlbuildDocPlugin.doc_build "./"); + ("lwt-manual", + CustomPlugin.Doc.main + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("make", ["-C"; "manual"; "manual.pdf"])) + ]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + install = InternalInstallPlugin.install; + uninstall = InternalInstallPlugin.uninstall; + clean = [OCamlbuildPlugin.clean]; + clean_test = + [ + ("unix", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test_unix", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("react", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test_react", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("core", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test_core", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + clean_doc = + [ + ("lwt-api", OCamlbuildDocPlugin.doc_clean "./"); + ("lwt-manual", + CustomPlugin.Doc.clean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("make", ["-C"; "manual"; "manual.pdf"])) + ]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + distclean = []; + distclean_test = + [ + ("unix", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test_unix", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("react", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test_react", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("core", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$test_core", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + distclean_doc = + [ + ("lwt-manual", + CustomPlugin.Doc.distclean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("make", ["-C"; "manual"; "manual.pdf"])) + ]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + package = + { + oasis_version = "0.1"; + ocaml_version = Some (OASISVersion.VGreaterEqual "3.12"); + findlib_version = None; + name = "lwt"; + version = "2.3.2"; + license = + OASISLicense.DEP5License + { + OASISLicense.license = "LGPL"; + exceptions = ["OCaml linking"]; + version = OASISLicense.Version "2.1"; + }; + license_file = Some "COPYING"; + copyrights = []; + maintainers = []; + authors = + [ + "J\195\169r\195\180me Vouillon"; + "Vincent Balat"; + "Nataliya Guts"; + "Pierre Clairambault"; + "St\195\169phane Glondu"; + "J\195\169r\195\169mie Dimino"; + "Warren Harris"; + "Pierre Chambart"; + "Mauricio Fernandez" + ]; + homepage = Some "http://ocsigen.org/lwt/"; + synopsis = "Lightweight thread library for Objective Caml"; + description = + Some + "Lwt is a library of cooperative threads implemented in monadic\nstyle. With respect to preemptive threads, cooperative threads are\nnot using a scheduler to distribute processor time between\nthreads. Instead of this, each thread must tell the others that he\nwants to let them work."; + categories = []; + conf_type = (`Configure, "internal", Some "0.2"); + conf_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = + [ + (OASISExpr.EBool true, + Some + (("ocaml", + [ + "discover.ml"; + "-ocamlc"; + "$ocamlc"; + "-ext-obj"; + "$ext_obj"; + "-exec-name"; + "$default_executable_name"; + "-use-libev"; + "$libev"; + "-os-type"; + "$os_type" + ]))) + ]; + }; + build_type = (`Build, "ocamlbuild", Some "0.2"); + build_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + install_type = (`Install, "internal", Some "0.2"); + install_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + uninstall_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + clean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + distclean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = + [ + (OASISExpr.EBool true, + Some + (("$rm", + ["src/unix/lwt_config.h"; "src/unix/lwt_config.ml" + ]))) + ]; + }; + files_ab = []; + sections = + [ + Library + ({ + cs_name = "lwt"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src/core"; + bs_compiled_object = Best; + bs_build_depends = []; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + [ + "Lwt_condition"; + "Lwt_list"; + "Lwt"; + "Lwt_mutex"; + "Lwt_mvar"; + "Lwt_pool"; + "Lwt_sequence"; + "Lwt_stream"; + "Lwt_switch"; + "Lwt_util"; + "Lwt_pqueue" + ]; + lib_internal_modules = []; + lib_findlib_parent = None; + lib_findlib_name = None; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "lwt-unix"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), + true) + ]; + bs_path = "src/unix"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "lwt"; + FindlibPackage ("unix", None); + FindlibPackage ("bigarray", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = + [ + "lwt_config.h"; + "lwt_unix.h"; + "lwt_unix_stubs.c"; + "lwt_libev_stubs.c" + ]; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = + [ + (OASISExpr.EBool true, []); + (OASISExpr.EFlag "libev", ["-lev"]); + (OASISExpr.ENot + (OASISExpr.ETest ("os_type", "Win32")), + ["-lpthread"]); + (OASISExpr.EAnd + (OASISExpr.ENot + (OASISExpr.ETest ("os_type", "Win32")), + OASISExpr.EFlag "libev"), + ["-lpthread"; "-lev"]); + (OASISExpr.ETest ("os_type", "Win32"), + ["ws2_32.lib"]); + (OASISExpr.EAnd + (OASISExpr.ETest ("os_type", "Win32"), + OASISExpr.EFlag "libev"), + ["ws2_32.lib"; "-lev"]); + (OASISExpr.EAnd + (OASISExpr.ETest ("os_type", "Win32"), + OASISExpr.ENot + (OASISExpr.ETest ("os_type", "Win32"))), + ["ws2_32.lib"; "-lpthread"]); + (OASISExpr.EAnd + (OASISExpr.EAnd + (OASISExpr.ETest ("os_type", "Win32"), + OASISExpr.ENot + (OASISExpr.ETest ("os_type", "Win32"))), + OASISExpr.EFlag "libev"), + ["ws2_32.lib"; "-lpthread"; "-lev"]) + ]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + [ + "Lwt_chan"; + "Lwt_daemon"; + "Lwt_gc"; + "Lwt_io"; + "Lwt_log"; + "Lwt_main"; + "Lwt_process"; + "Lwt_throttle"; + "Lwt_timeout"; + "Lwt_unix"; + "Lwt_sys"; + "Lwt_engine"; + "Lwt_bytes" + ]; + lib_internal_modules = ["Lwt_log_rules"]; + lib_findlib_parent = Some "lwt"; + lib_findlib_name = Some "unix"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "lwt-react"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "react", + OASISExpr.EFlag "all"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "react", + OASISExpr.EFlag "all"), + true) + ]; + bs_path = "src/react"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "lwt"; + FindlibPackage ("react", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Lwt_event"; "Lwt_signal"; "Lwt_react"]; + lib_internal_modules = []; + lib_findlib_parent = Some "lwt"; + lib_findlib_name = Some "react"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "test"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), + true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests"; + bs_compiled_object = Best; + bs_build_depends = []; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Test"]; + lib_internal_modules = []; + lib_findlib_parent = None; + lib_findlib_name = None; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "lwt-text"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "text", OASISExpr.EFlag "all"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "text", OASISExpr.EFlag "all"), + true) + ]; + bs_path = "src/text"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "lwt"; + InternalLibrary "lwt-unix"; + InternalLibrary "lwt-react"; + FindlibPackage ("text", None); + FindlibPackage ("text.bigarray", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = ["lwt_text_stubs.c"]; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Lwt_text"; "Lwt_term"; "Lwt_read_line"]; + lib_internal_modules = []; + lib_findlib_parent = Some "lwt"; + lib_findlib_name = Some "text"; + lib_findlib_containers = []; + }); + Executable + ({ + cs_name = "test_unix"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), + true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests/unix"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "test"; + InternalLibrary "lwt"; + FindlibPackage ("unix", None); + InternalLibrary "lwt-unix" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "main.ml"; }); + Library + ({ + cs_name = "lwt-syntax"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "syntax"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("camlp4.lib", None); + FindlibPackage ("camlp4.quotations.o", None); + FindlibPackage ("camlp4.extend", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Pa_lwt"]; + lib_internal_modules = []; + lib_findlib_parent = Some "lwt"; + lib_findlib_name = Some "syntax"; + lib_findlib_containers = []; + }); + Executable + ({ + cs_name = "test_react"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EAnd + (OASISExpr.EFlag "unix", + OASISExpr.EFlag "react"), + OASISExpr.EFlag "all"), + true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests/react"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "test"; + InternalLibrary "lwt"; + FindlibPackage ("unix", None); + InternalLibrary "lwt-unix"; + FindlibPackage ("react", None); + InternalLibrary "lwt-react" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "main.ml"; }); + Executable + ({ + cs_name = "test_core"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), + true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests/core"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "test"; + InternalLibrary "lwt"; + FindlibPackage ("unix", None); + InternalLibrary "lwt-unix" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "main.ml"; }); + Library + ({ + cs_name = "lwt-top"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "text", OASISExpr.EFlag "all"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "text", OASISExpr.EFlag "all"), + true) + ]; + bs_path = "src/top"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "lwt"; + InternalLibrary "lwt-text"; + FindlibPackage ("findlib", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Lwt_top"]; + lib_internal_modules = ["Lwt_ocaml_completion"]; + lib_findlib_parent = Some "lwt"; + lib_findlib_name = Some "top"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "lwt-preemptive"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "preemptive", + OASISExpr.EFlag "all"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "preemptive", + OASISExpr.EFlag "all"), + true) + ]; + bs_path = "src/preemptive"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "lwt"; + InternalLibrary "lwt-unix"; + FindlibPackage ("threads", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Lwt_preemptive"]; + lib_internal_modules = []; + lib_findlib_parent = Some "lwt"; + lib_findlib_name = Some "preemptive"; + lib_findlib_containers = []; + }); + Flag + ({ + cs_name = "extra"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "Asynchronous unix functions"; + flag_default = [(OASISExpr.EBool true, true)]; + }); + SrcRepo + ({ + cs_name = "head"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + src_repo_type = Darcs; + src_repo_location = "http://ocsigen.org/darcs/lwt"; + src_repo_browser = + Some "http://ocsigen.org/darcsweb/?r=lwt;a=summary"; + src_repo_module = None; + src_repo_branch = None; + src_repo_tag = None; + src_repo_subdir = None; + }); + Flag + ({ + cs_name = "preemptive"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "Preemptive threads support"; + flag_default = [(OASISExpr.EBool true, true)]; + }); + Library + ({ + cs_name = "lwt-simple-top"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), + true) + ]; + bs_path = "src/simple_top"; + bs_compiled_object = Best; + bs_build_depends = + [InternalLibrary "lwt"; InternalLibrary "lwt-unix"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = []; + lib_internal_modules = ["Lwt_simple_top"]; + lib_findlib_parent = Some "lwt"; + lib_findlib_name = Some "simple-top"; + lib_findlib_containers = []; + }); + Flag + ({ + cs_name = "glib"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "Glib integration"; + flag_default = [(OASISExpr.EBool true, false)]; + }); + Test + ({ + cs_name = "unix"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + test_type = (`Test, "custom", Some "0.2"); + test_command = + [(OASISExpr.EBool true, ("$test_unix", []))]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + test_working_directory = None; + test_run = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), + true) + ]; + test_tools = + [ + ExternalTool "ocamlbuild"; + InternalExecutable "test_unix" + ]; + }); + Flag + ({ + cs_name = "unix"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "Unix support"; + flag_default = [(OASISExpr.EBool true, true)]; + }); + Flag + ({ + cs_name = "text"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "Text mode utilities"; + flag_default = [(OASISExpr.EBool true, false)]; + }); + Doc + ({ + cs_name = "lwt-api"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "ocamlbuild", Some "0.2"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = [(OASISExpr.EBool true, true)]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$htmldir/api"; + doc_title = "API reference for Lwt"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = [("utils/style.css", None)]; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; + }); + Library + ({ + cs_name = "lwt-glib"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "glib", OASISExpr.EFlag "all"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "glib", OASISExpr.EFlag "all"), + true) + ]; + bs_path = "src/glib"; + bs_compiled_object = Best; + bs_build_depends = + [InternalLibrary "lwt"; InternalLibrary "lwt-unix"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = ["lwt_glib_stubs.c"]; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Lwt_glib"]; + lib_internal_modules = []; + lib_findlib_parent = Some "lwt"; + lib_findlib_name = Some "glib"; + lib_findlib_containers = []; + }); + Flag + ({ + cs_name = "all"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "build and install everything"; + flag_default = [(OASISExpr.EBool true, false)]; + }); + Executable + ({ + cs_name = "relay"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "unix", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples/unix"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "lwt-unix"; + InternalLibrary "lwt-syntax" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "relay.ml"; }); + Executable + ({ + cs_name = "logging"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "unix", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples/unix"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "lwt-unix"; + InternalLibrary "lwt-syntax" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "logging.ml"; }); + Test + ({ + cs_name = "react"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + test_type = (`Test, "custom", Some "0.2"); + test_command = + [(OASISExpr.EBool true, ("$test_react", []))]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + test_working_directory = None; + test_run = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EAnd + (OASISExpr.EFlag "unix", + OASISExpr.EFlag "react"), + OASISExpr.EFlag "all"), + true) + ]; + test_tools = + [ + ExternalTool "ocamlbuild"; + InternalExecutable "test_react" + ]; + }); + Library + ({ + cs_name = "lwt-syntax-log"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "syntax"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("camlp4.lib", None); + FindlibPackage ("camlp4.quotations.o", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Pa_lwt_log"]; + lib_internal_modules = []; + lib_findlib_parent = Some "lwt-syntax"; + lib_findlib_name = Some "log"; + lib_findlib_containers = []; + }); + Flag + ({ + cs_name = "react"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "React helpers"; + flag_default = [(OASISExpr.EBool true, false)]; + }); + Flag + ({ + cs_name = "ssl"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "SSL support"; + flag_default = [(OASISExpr.EBool true, false)]; + }); + Test + ({ + cs_name = "core"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + test_type = (`Test, "custom", Some "0.2"); + test_command = + [(OASISExpr.EBool true, ("$test_core", []))]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + test_working_directory = None; + test_run = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), + true) + ]; + test_tools = + [ + ExternalTool "ocamlbuild"; + InternalExecutable "test_core" + ]; + }); + Executable + ({ + cs_name = "lwt-toplevel"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "toplevel", + OASISExpr.EFlag "all"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "toplevel", + OASISExpr.EFlag "all"), + true) + ]; + bs_path = "src/top"; + bs_compiled_object = Byte; + bs_build_depends = + [ + InternalLibrary "lwt"; + InternalLibrary "lwt-top"; + InternalLibrary "lwt-text"; + InternalLibrary "lwt-react"; + FindlibPackage ("text", None); + FindlibPackage ("findlib", None); + FindlibPackage ("unix", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "lwt_toplevel.ml"; }); + Flag + ({ + cs_name = "toplevel"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "Enhanced toplevel"; + flag_default = [(OASISExpr.EBool true, false)]; + }); + Executable + ({ + cs_name = "parallelize"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "unix", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples/unix"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "lwt-unix"; + InternalLibrary "lwt-syntax" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "parallelize.ml"; }); + Library + ({ + cs_name = "lwt-extra"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "extra", + OASISExpr.EFlag "all"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "extra", + OASISExpr.EFlag "all"), + true) + ]; + bs_path = "src/extra"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "lwt"; + InternalLibrary "lwt-preemptive" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Lwt_lib"]; + lib_internal_modules = []; + lib_findlib_parent = Some "lwt"; + lib_findlib_name = Some "extra"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "optcomp"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "syntax"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("camlp4.lib", None); + FindlibPackage ("camlp4.quotations.o", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Pa_optcomp"]; + lib_internal_modules = []; + lib_findlib_parent = None; + lib_findlib_name = None; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "lwt-syntax-options"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "syntax"; + bs_compiled_object = Best; + bs_build_depends = + [FindlibPackage ("camlp4.lib", None)]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = []; + lib_internal_modules = ["Pa_lwt_options"]; + lib_findlib_parent = Some "lwt-syntax"; + lib_findlib_name = Some "options"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "lwt-ssl"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "ssl", OASISExpr.EFlag "all"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EOr + (OASISExpr.EFlag "ssl", OASISExpr.EFlag "all"), + true) + ]; + bs_path = "src/ssl"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("ssl", None); + InternalLibrary "lwt-unix" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Lwt_ssl"]; + lib_internal_modules = []; + lib_findlib_parent = Some "lwt"; + lib_findlib_name = Some "ssl"; + lib_findlib_containers = []; + }); + Doc + ({ + cs_name = "lwt-manual"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "custom", Some "0.2"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = [(OASISExpr.EBool true, true)]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$pdfdir"; + doc_title = "Lwt user manual"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = [("manual/manual.pdf", None)]; + doc_build_tools = [ExternalTool "ocamlbuild"]; + }); + Flag + ({ + cs_name = "libev"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + flag_description = Some "Compile with libev support"; + flag_default = + [ + (OASISExpr.EBool true, false); + (OASISExpr.ENot + (OASISExpr.ETest ("os_type", "Win32")), + true) + ]; + }) + ]; + plugins = + [(`Extra, "DevFiles", Some "0.2"); (`Extra, "META", Some "0.2")]; + schema_data = PropList.Data.create (); + plugin_data = []; + }; + version = "0.2.0"; + };; + +let setup () = BaseSetup.setup setup_t;; + +(* OASIS_STOP *) + +let () = + InternalInstallPlugin.lib_hook := + fun (cs, bs, lib) -> + match lib.OASISTypes.lib_findlib_name with + | Some "unix" -> + (cs, bs, lib, ["src/unix/lwt_config.ml"; "src/unix/lwt_config.h"; "src/unix/lwt_unix.h"]) + | _ -> + (cs, bs, lib, []) +;; + +let () = setup ();; diff --git a/thirdparty/lwt-2.3.2/src/core/META b/thirdparty/lwt-2.3.2/src/core/META new file mode 100644 index 0000000..fa397b8 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/META @@ -0,0 +1,115 @@ +# OASIS_START +# DO NOT EDIT (digest: 92360f3460ecb78dca24ff748f6650bd) +version = "2.3.2" +description = "Lightweight thread library for OCaml (core library)" +archive(byte) = "lwt.cma" +archive(native) = "lwt.cmxa" +exists_if = "lwt.cma" +package "ssl" ( + version = "2.3.2" + description = "SSL support for Lwt" + requires = "ssl lwt.unix" + archive(byte) = "lwt-ssl.cma" + archive(native) = "lwt-ssl.cmxa" + exists_if = "lwt-ssl.cma" +) + +package "extra" ( + version = "2.3.2" + description = "Unix functions for Lwt using Lwt_preemptive" + requires = "lwt lwt.preemptive" + archive(byte) = "lwt-extra.cma" + archive(native) = "lwt-extra.cmxa" + exists_if = "lwt-extra.cma" +) + +package "glib" ( + version = "2.3.2" + description = "Glib integration" + requires = "lwt lwt.unix" + archive(byte) = "lwt-glib.cma" + archive(native) = "lwt-glib.cmxa" + exists_if = "lwt-glib.cma" +) + +package "simple-top" ( + version = "2.3.2" + description = "Unix support for lwt" + requires = "lwt lwt.unix" + archive(byte) = "lwt-simple-top.cma" + archive(native) = "lwt-simple-top.cmxa" + exists_if = "lwt-simple-top.cma" +) + +package "preemptive" ( + version = "2.3.2" + description = "Preemptive threads support for Lwt" + requires = "lwt lwt.unix threads" + archive(byte) = "lwt-preemptive.cma" + archive(native) = "lwt-preemptive.cmxa" + exists_if = "lwt-preemptive.cma" +) + +package "top" ( + version = "2.3.2" + description = "Line-editing in the toplevel" + requires = "lwt lwt.text findlib" + archive(byte) = "lwt-top.cma" + archive(native) = "lwt-top.cmxa" + exists_if = "lwt-top.cma" +) + +package "syntax" ( + version = "2.3.2" + description = "Syntactic sugars for Lwt" + requires = "camlp4 lwt.syntax.options" + archive(syntax,preprocessor) = "lwt-syntax.cma" + archive(syntax,toploop) = "lwt-syntax.cma" + exists_if = "lwt-syntax.cma" + package "options" ( + version = "2.3.2" + description = "Options for syntax extensions" + requires = "camlp4" + archive(syntax,preprocessor) = "lwt-syntax-options.cma" + archive(syntax,toploop) = "lwt-syntax-options.cma" + exists_if = "lwt-syntax-options.cma" + ) + + package "log" ( + version = "2.3.2" + description = "Syntactic sugars for logging" + requires = "camlp4 lwt.syntax.options" + archive(syntax,preprocessor) = "lwt-syntax-log.cma" + archive(syntax,toploop) = "lwt-syntax-log.cma" + exists_if = "lwt-syntax-log.cma" + ) +) + +package "text" ( + version = "2.3.2" + description = "Text mode utilities" + requires = "lwt lwt.unix lwt.react text text.bigarray" + archive(byte) = "lwt-text.cma" + archive(native) = "lwt-text.cmxa" + exists_if = "lwt-text.cma" +) + +package "react" ( + version = "2.3.2" + description = "Reactive programming helpers" + requires = "lwt react" + archive(byte) = "lwt-react.cma" + archive(native) = "lwt-react.cmxa" + exists_if = "lwt-react.cma" +) + +package "unix" ( + version = "2.3.2" + description = "Unix support for lwt" + requires = "lwt unix bigarray" + archive(byte) = "lwt-unix.cma" + archive(native) = "lwt-unix.cmxa" + exists_if = "lwt-unix.cma" +) +# OASIS_STOP + diff --git a/thirdparty/lwt-2.3.2/src/core/lwt.ml b/thirdparty/lwt-2.3.2/src/core/lwt.ml new file mode 100644 index 0000000..926d817 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt.ml @@ -0,0 +1,1060 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * 2009 Jrmie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +exception Canceled + +module Int_map = Map.Make(struct type t = int let compare = compare end) + +type data = (unit -> unit) Int_map.t + (* Type of data carried by threads *) + +type +'a t +type -'a u + +type 'a thread_state = + | Return of 'a + (* [Return v] a terminated thread which has successfully + terminated with the value [v] *) + | Fail of exn + (* [Fail exn] a terminated thread which has failed with the + exception [exn] *) + | Sleep of 'a sleeper + (* [Sleep sleeper] is a sleeping thread *) + | Repr of 'a thread_repr + (* [Repr t] a thread which behaves the same as [t] *) + +and 'a thread_repr = { + mutable state : 'a thread_state; + (* The state of the thread *) +} + +and 'a sleeper = { + cancel : cancel ref; + (* The canceler for this thread *) + mutable waiters : 'a waiter_set; + (* All thunk functions *) + mutable removed : int; + (* Number of waiter that have been disabled. When this number + reaches [max_removed], they are effectively removed from + [waiters]. *) +} + +(* Type of set of waiters: *) +and 'a waiter_set = + | Empty + | Removable of ('a thread_state -> unit) option ref + | Immutable of ('a thread_state -> unit) + | Append of 'a waiter_set * 'a waiter_set + +and cancel = + | Cancel_func of (unit -> unit) + (* A cancel function. *) + | Cancel_repr of cancel ref + (* Behave has this canceler. *) + +external thread_repr : 'a t -> 'a thread_repr = "%identity" +external thread : 'a thread_repr -> 'a t = "%identity" +external wakener : 'a thread_repr -> 'a u = "%identity" +external wakener_repr : 'a u -> 'a thread_repr = "%identity" + +(* Maximum number of disabled waiters a waiter set can contains before + being cleaned: *) +let max_removed = 42 + +(* +-----------------------------------------------------------------+ + | Local storage | + +-----------------------------------------------------------------+ *) + +type 'a key = { + id : int; + mutable store : 'a option; +} + +let next_key_id = ref 0 + +let new_key () = + let id = !next_key_id in + next_key_id := id + 1; + { id = id; store = None } + +let current_data = ref Int_map.empty + +let get key = + try + Int_map.find key.id !current_data (); + let value = key.store in + key.store <- None; + value + with Not_found -> + None + +(* +-----------------------------------------------------------------+ + | Restarting/connecting threads | + +-----------------------------------------------------------------+ *) + +(* Returns the representative of a thread, updating non-direct references: *) +let rec repr_rec t = + match t.state with + | Repr t' -> let t'' = repr_rec t' in if t'' != t' then t.state <- Repr t''; t'' + | _ -> t +let repr t = repr_rec (thread_repr t) + +let rec run_waiters_rec state ws rem = + match ws, rem with + | Empty, [] -> + () + | Empty, ws :: rem -> + run_waiters_rec state ws rem + | Immutable f, [] -> + f state + | Immutable f, ws :: rem -> + f state; + run_waiters_rec state ws rem + | Removable{ contents = None }, [] -> + () + | Removable{ contents = None }, ws :: rem -> + run_waiters_rec state ws rem + | Removable{ contents = Some f }, [] -> + f state + | Removable{ contents = Some f }, ws :: rem -> + f state; + run_waiters_rec state ws rem + | Append(ws1, ws2), _ -> + run_waiters_rec state ws1 (ws2 :: rem) + +(* Run all waiters waiting on [t]: *) +let run_waiters waiters state = + let save = !current_data in + run_waiters_rec state waiters []; + current_data := save + +let wakeup t v = + let t = repr_rec (wakener_repr t) in + match t.state with + | Sleep{ waiters = waiters } -> + let state = Return v in + t.state <- state; + run_waiters waiters state + | Fail Canceled -> + (* Do not fail if the thread has been canceled: *) + () + | _ -> + invalid_arg "Lwt.wakeup" + +let wakeup_exn t e = + let t = repr_rec (wakener_repr t) in + match t.state with + | Sleep{ waiters = waiters } -> + let state = Fail e in + t.state <- state; + run_waiters waiters state + | Fail Canceled -> + () + | _ -> + invalid_arg "Lwt.wakeup_exn" + +(* Same as [wakeup] but do not raise [Invalid_argument]. *) +let ignore_wakeup t v = + let t = repr_rec (wakener_repr t) in + match t.state with + | Sleep{ waiters = waiters } -> + let state = Return v in + t.state <- state; + run_waiters waiters state + | _ -> + () + +(* Same as [wakeup_exn] but do not raise [Invalid_argument]. *) +let ignore_wakeup_exn t e = + let t = repr_rec (wakener_repr t) in + match t.state with + | Sleep{ waiters = waiters } -> + let state = Fail e in + t.state <- state; + run_waiters waiters state + | _ -> + () + +let wakeuping = ref false +let to_wakeup = Queue.create () + +let wakeup_all () = + while not (Queue.is_empty to_wakeup) do + Queue.pop to_wakeup () + done; + wakeuping := false + +let wakeup_later t v = + if !wakeuping then + Queue.push (fun () -> ignore_wakeup t v) to_wakeup + else begin + wakeuping := true; + ignore_wakeup t v; + wakeup_all () + end + +let wakeup_later_exn t v = + if !wakeuping then + Queue.push (fun () -> ignore_wakeup_exn t v) to_wakeup + else begin + wakeuping := true; + ignore_wakeup_exn t v; + wakeup_all () + end + +let restart_cancel t = + let t = repr_rec (wakener_repr t) in + match t.state with + | Sleep{ waiters = waiters } -> + let state = Fail Canceled in + t.state <- state; + run_waiters waiters state + | _ -> + () + +let cancel_none = Cancel_func ignore + +let rec get_cancel = function + | Cancel_func f -> f + | Cancel_repr r -> let c = !r in r := cancel_none; get_cancel c + +let cancel t = + match (repr t).state with + | Sleep{ cancel = cancel } -> + let f = get_cancel !cancel in + cancel := cancel_none; + let save = !current_data in + f (); + current_data := save + | _ -> + () + +let append l1 l2 = + match l1, l2 with + | Empty, _ -> l2 + | _, Empty -> l1 + | _ -> Append(l1, l2) + +(* Remove all disbaled waiters of a waiter set: *) +let rec cleanup = function + | Removable{ contents = None } -> + Empty + | Append(l1, l2) -> + append (cleanup l1) (cleanup l2) + | ws -> + ws + +(* Connects the two processes [t1] and [t2] when [t2] finishes up, + where [t1] must be a sleeping thread. + + Connecting means running all the waiters for [t2] and assigning the + state of [t1] to [t2]. +*) +let connect t1 t2 = + let t1 = repr t1 and t2 = repr t2 in + match t1.state with + | Sleep sleeper1 -> + if t1 == t2 then + (* Do nothing if the two threads already have the same + representation *) + () + else begin + match t2.state with + | Sleep sleeper2 -> + (* If [t2] is sleeping, then makes it behave as [t1]: *) + t2.state <- Repr t1; + (* Note that the order is important: the user have no + access to [t2] but may keep a reference to [t1]. If + we inverse the order, i.e. we do: + + [t1.state <- Repr t2] + + then we have a possible leak. For example: + + {[ + let rec loop ()== + lwt () = Lwt_unix.yield () in + loop () + + lwt () = + let t = loop () in + ... + ]} + + Here, after [n] iterations, [t] will contains: + + [ref(Repr(ref(Repr(ref(Repr ... ref Sleep)))))] + \-------------[n]--------------/ + *) + + (* However, since [t1] is a temporary thread created + for a thread that is now terminated, its cancel + function is meaningless. Only the one of [t2] is + now important: *) + sleeper1.cancel := Cancel_repr sleeper2.cancel; + + (* Merge the two sets of waiters: *) + let waiters = append sleeper1.waiters sleeper2.waiters + and removed = sleeper1.removed + sleeper2.removed in + if removed > max_removed then begin + (* Remove disabled threads *) + sleeper1.removed <- 0; + sleeper1.waiters <- cleanup waiters + end else begin + sleeper1.removed <- removed; + sleeper1.waiters <- waiters + end + | state2 -> + (* [t2] is already terminated, assing its state to [t1]: *) + t1.state <- state2; + (* and run all the waiters of [t1]: *) + run_waiters sleeper1.waiters state2 + end + | _ -> + (* [t1] is not asleep: *) + invalid_arg "Lwt.connect" + +(* Same as [connect] except that we know that [t2] has terminated: *) +let fast_connect t state = + let t = repr t in + match t.state with + | Sleep{ waiters = waiters } -> + t.state <- state; + run_waiters waiters state + | _ -> + invalid_arg "Lwt.fast_connect" + +(* +-----------------------------------------------------------------+ + | Threads conctruction and combining | + +-----------------------------------------------------------------+ *) + +let return v = + thread { state = Return v } + +let fail e = + thread { state = Fail e } + +let temp r = + thread { + state = Sleep{ cancel = r; + waiters = Empty; + removed = 0 } + } + +let wait () = + let t = { + state = Sleep{ cancel = ref cancel_none; + waiters = Empty; + removed = 0 }; + } in + (thread t, wakener t) + +let task () = + let rec t = { + state = Sleep{ cancel = ref (Cancel_func(fun () -> restart_cancel (wakener t))); + waiters = Empty; + removed = 0 }; + } in + (thread t, wakener t) + +let waiter_of_wakener wakener = thread (wakener_repr wakener) + +(* apply function, reifying explicit exceptions into the thread type + apply: ('a -(exn)-> 'b t) -> ('a -(n)-> 'b t) + semantically a natural transformation TE -> T, where T is the thread + monad, which is layered over exception monad E. +*) +let apply f x = try f x with e -> fail e + +let wrap f = try return (f ()) with exn -> fail exn + +let wrap1 f x1 = try return (f x1) with exn -> fail exn +let wrap2 f x1 x2 = try return (f x1 x2) with exn -> fail exn +let wrap3 f x1 x2 x3 = try return (f x1 x2 x3) with exn -> fail exn +let wrap4 f x1 x2 x3 x4 = try return (f x1 x2 x3 x4) with exn -> fail exn +let wrap5 f x1 x2 x3 x4 x5 = try return (f x1 x2 x3 x4 x5) with exn -> fail exn +let wrap6 f x1 x2 x3 x4 x5 x6 = try return (f x1 x2 x3 x4 x5 x6) with exn -> fail exn +let wrap7 f x1 x2 x3 x4 x5 x6 x7 = try return (f x1 x2 x3 x4 x5 x6 x7) with exn -> fail exn + +let add_immutable_waiter sleeper waiter = + sleeper.waiters <- (match sleeper.waiters with + | Empty -> Immutable waiter + | _ -> Append(Immutable waiter, sleeper.waiters)) + +let add_removable_waiter sleeper waiter = + sleeper.waiters <- (match sleeper.waiters with + | Empty -> Removable waiter + | _ -> Append(Removable waiter, sleeper.waiters)) + +let on_cancel t f = + match (repr t).state with + | Sleep sleeper -> + let data = !current_data in + add_immutable_waiter sleeper + (function + | Fail Canceled -> current_data := data; (try f () with _ -> ()) + | _ -> ()) + | Fail Canceled -> + f () + | _ -> + () + +let bind t f = + match (repr t).state with + | Return v -> + f v + | Fail exn -> + fail exn + | Sleep sleeper -> + let res = temp sleeper.cancel in + let data = !current_data in + add_immutable_waiter sleeper + (function + | Return v -> current_data := data; connect res (try f v with exn -> fail exn) + | Fail exn -> fast_connect res (Fail exn) + | _ -> assert false); + res + | Repr _ -> + assert false + +let on_success t f = + match (repr t).state with + | Return v -> + f v + | Fail exn -> + raise exn + | Sleep sleeper -> + let data = !current_data in + add_immutable_waiter sleeper + (function + | Return v -> current_data := data; f v + | Fail exn -> raise exn + | _ -> assert false) + | Repr _ -> + assert false + +let (>>=) t f = bind t f +let (=<<) f t = bind t f + +let map f t = + match (repr t).state with + | Return v -> + return (f v) + | Fail e -> + thread { state = Fail e } + | Sleep sleeper -> + let res = temp sleeper.cancel in + let data = !current_data in + add_immutable_waiter sleeper + (function + | Return v -> current_data := data; fast_connect res (try Return(f v) with exn -> Fail exn) + | Fail exn -> fast_connect res (Fail exn) + | _ -> assert false); + res + | Repr _ -> + assert false + +let (>|=) t f = map f t +let (=|<) f t = map f t + +let catch x f = + let t = try x () with exn -> fail exn in + match (repr t).state with + | Return _ -> + t + | Fail exn -> + f exn + | Sleep sleeper -> + let res = temp sleeper.cancel in + let data = !current_data in + add_immutable_waiter sleeper + (function + | Return _ as state -> fast_connect res state + | Fail exn -> current_data := data; connect res (try f exn with exn -> fail exn) + | _ -> assert false); + res + | Repr _ -> + assert false + +let on_failure t f = + match (repr t).state with + | Return v -> + () + | Fail exn -> + f exn + | Sleep sleeper -> + let data = !current_data in + add_immutable_waiter sleeper + (function + | Return v -> () + | Fail exn -> current_data := data; f exn + | _ -> assert false) + | Repr _ -> + assert false + +let on_termination t f = + match (repr t).state with + | Return v -> + f () + | Fail exn -> + f () + | Sleep sleeper -> + let data = !current_data in + add_immutable_waiter sleeper + (function + | Return v -> current_data := data; f () + | Fail exn -> current_data := data; f () + | _ -> assert false) + | Repr _ -> + assert false + +let try_bind x f g = + let t = try x () with exn -> fail exn in + match (repr t).state with + | Return v -> + f v + | Fail exn -> + g exn + | Sleep sleeper -> + let res = temp sleeper.cancel in + let data = !current_data in + add_immutable_waiter sleeper + (function + | Return v -> current_data := data; connect res (try f v with exn -> fail exn) + | Fail exn -> current_data := data; connect res (try g exn with exn -> fail exn) + | _ -> assert false); + res + | Repr _ -> + assert false + +let poll t = + match (repr t).state with + | Fail e -> raise e + | Return v -> Some v + | Sleep _ -> None + | Repr _ -> assert false + +let rec ignore_result t = + match (repr t).state with + | Return _ -> + () + | Fail e -> + raise e + | Sleep sleeper -> + add_immutable_waiter sleeper + (function + | Return _ -> () + | Fail exn -> raise exn + | _ -> assert false) + | Repr _ -> + assert false + +let protected t = + match (repr t).state with + | Sleep sleeper -> + let waiter, wakener = task () in + add_immutable_waiter sleeper + (fun state -> + try + match state with + | Return v -> wakeup wakener v + | Fail exn -> wakeup_exn wakener exn + | _ -> assert false + with Invalid_argument _ -> + ()); + waiter + | Return _ | Fail _ -> + t + | Repr _ -> + assert false + +let rec nth_ready l n = + match l with + | [] -> + assert false + | t :: l -> + match (repr t).state with + | Sleep _ -> + nth_ready l n + | _ when n > 0 -> + nth_ready l (n - 1) + | state -> + state + +let ready_count l = + List.fold_left (fun acc x -> match (repr x).state with Sleep _ -> acc | _ -> acc + 1) 0 l + +let remove_waiters l = + List.iter + (fun t -> + match (repr t).state with + | Sleep sleeper -> + let removed = sleeper.removed + 1 in + if removed > max_removed then begin + sleeper.removed <- 0; + sleeper.waiters <- cleanup sleeper.waiters + end else + sleeper.removed <- removed + | _ -> + ()) + l + +(* The PRNG state is initialized with a constant to make non-IO-based + programs deterministic. *) +let random_state = Random.State.make [||] + +let choose l = + let ready = ready_count l in + if ready > 0 then + if ready = 1 then + (* Optimisation for the common case: *) + thread { state = nth_ready l 0 } + else + thread { state = nth_ready l (Random.State.int random_state ready) } + else begin + let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) in + let waiter = ref None in + let handle_result state = + (* Disable the waiter now: *) + waiter := None; + (* Removes all waiters so we do not leak memory: *) + remove_waiters l; + (* This will not fail because it is called at most one time, + since all other waiters have been removed: *) + fast_connect res state + in + waiter := (Some handle_result); + List.iter + (fun t -> + match (repr t).state with + | Sleep sleeper -> + (* The data passed here will never be used because + [handle_result] only calls [fast_connect] which + calls [run_waiters] which ignore the current data *) + add_removable_waiter sleeper waiter; + | _ -> + assert false) + l; + res + end + +let rec nchoose_terminate res acc = function + | [] -> + fast_connect res (Return(List.rev acc)) + | t :: l -> + match (repr t).state with + | Return x -> + nchoose_terminate res (x :: acc) l + | Fail e -> + fast_connect res (Fail e) + | _ -> + nchoose_terminate res acc l + +let nchoose_sleep l = + let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) in + let rec waiter = ref (Some handle_result) + and handle_result state = + waiter := None; + remove_waiters l; + nchoose_terminate res [] l + in + List.iter + (fun t -> + match (repr t).state with + | Sleep sleeper -> + add_removable_waiter sleeper waiter; + | _ -> + assert false) + l; + res + +let nchoose l = + let rec init = function + | [] -> + nchoose_sleep l + | t :: l -> + match (repr t).state with + | Return x -> + collect [x] l + | Fail exn -> + fail exn + | _ -> + init l + and collect acc = function + | [] -> + return (List.rev acc) + | t :: l -> + match (repr t).state with + | Return x -> + collect (x :: acc) l + | Fail exn -> + fail exn + | _ -> + collect acc l + in + init l + +let rec nchoose_split_terminate res acc_terminated acc_sleeping = function + | [] -> + fast_connect res (Return(List.rev acc_terminated, List.rev acc_sleeping)) + | t :: l -> + match (repr t).state with + | Return x -> + nchoose_split_terminate res (x :: acc_terminated) acc_sleeping l + | Fail e -> + fast_connect res (Fail e) + | _ -> + nchoose_split_terminate res acc_terminated (t :: acc_sleeping) l + +let nchoose_split_sleep l = + let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) in + let rec waiter = ref (Some handle_result) + and handle_result state = + waiter := None; + remove_waiters l; + nchoose_split_terminate res [] [] l + in + List.iter + (fun t -> + match (repr t).state with + | Sleep sleeper -> + add_removable_waiter sleeper waiter; + | _ -> + assert false) + l; + res + +let nchoose_split l = + let rec init acc_sleeping = function + | [] -> + nchoose_split_sleep l + | t :: l -> + match (repr t).state with + | Return x -> + collect [x] acc_sleeping l + | Fail exn -> + fail exn + | _ -> + init (t :: acc_sleeping) l + and collect acc_terminated acc_sleeping = function + | [] -> + return (List.rev acc_terminated, acc_sleeping) + | t :: l -> + match (repr t).state with + | Return x -> + collect (x :: acc_terminated) acc_sleeping l + | Fail exn -> + fail exn + | _ -> + collect acc_terminated (t :: acc_sleeping) l + in + init [] l + +(* Return the nth ready thread, and cancel all others *) +let rec cancel_and_nth_ready l n = + match l with + | [] -> + assert false + | t :: l -> + match (repr t).state with + | Sleep _ -> + cancel t; + cancel_and_nth_ready l n + | _ when n > 0 -> + cancel_and_nth_ready l (n - 1) + | state -> + List.iter cancel l; + state + +let pick l = + let ready = ready_count l in + if ready > 0 then + if ready = 1 then + (* Optimisation for the common case: *) + thread { state = cancel_and_nth_ready l 0 } + else + thread { state = cancel_and_nth_ready l (Random.State.int random_state ready) } + else begin + let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) in + let rec waiter = ref (Some handle_result) + and handle_result state = + waiter := None; + remove_waiters l; + (* Cancel all other threads: *) + List.iter cancel l; + fast_connect res state + in + List.iter + (fun t -> + match (repr t).state with + | Sleep sleeper -> + add_removable_waiter sleeper waiter; + | _ -> + assert false) + l; + res + end + +let npick_sleep l = + let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) in + let rec waiter = ref (Some handle_result) + and handle_result state = + waiter := None; + remove_waiters l; + List.iter cancel l; + nchoose_terminate res [] l + in + List.iter + (fun t -> + match (repr t).state with + | Sleep sleeper -> + add_removable_waiter sleeper waiter; + | _ -> + assert false) + l; + res + +let npick threads = + let rec init = function + | [] -> + npick_sleep threads + | t :: l -> + match (repr t).state with + | Return x -> + collect [x] l + | Fail exn -> + List.iter cancel threads; + fail exn + | _ -> + init l + and collect acc = function + | [] -> + List.iter cancel threads; + return (List.rev acc) + | t :: l -> + match (repr t).state with + | Return x -> + collect (x :: acc) l + | Fail exn -> + List.iter cancel threads; + fail exn + | _ -> + collect acc l + in + init threads + +let join l = + let res = temp (ref (Cancel_func(fun () -> List.iter cancel l))) + (* Number of threads still sleeping: *) + and sleeping = ref 0 + (* The state that must be returned: *) + and return_state = ref (Return ()) in + let rec waiter = ref (Some handle_result) + and handle_result state = + begin + match !return_state, state with + | Return _, Fail exn -> return_state := state + | _ -> () + end; + decr sleeping; + (* All threads are terminated, we can wakeup the result: *) + if !sleeping = 0 then begin + waiter := None; + fast_connect res !return_state + end + in + let rec init = function + | [] -> + if !sleeping = 0 then + (* No thread is sleeping, returns immediately: *) + thread { state = !return_state } + else + res + | t :: rest -> + match (repr t).state with + | Sleep sleeper -> + incr sleeping; + add_removable_waiter sleeper waiter; + init rest + | Fail _ as state -> begin + match !return_state with + | Return _ -> + return_state := state; + init rest + | _ -> + init rest + end + | _ -> + init rest + in + init l + +let ( ) t1 t2 = choose [t1; t2] +let ( <&> ) t1 t2 = join [t1; t2] + +let finalize f g = + try_bind f + (fun x -> g () >>= fun () -> return x) + (fun e -> g () >>= fun () -> fail e) + +let update_data key = function + | Some _ as value -> + current_data := Int_map.add key.id (fun () -> key.store <- value) !current_data + | None -> + current_data := Int_map.remove key.id !current_data + +let with_value key value f = + let save = !current_data in + let data = + match value with + | Some _ -> + Int_map.add key.id (fun () -> key.store <- value) save + | None -> + Int_map.remove key.id save + in + current_data := data; + try + let result = f () in + current_data := save; + result + with exn -> + current_data := save; + raise exn + +(* +-----------------------------------------------------------------+ + | Paused threads | + +-----------------------------------------------------------------+ *) + +let pause_hook = ref ignore + +let paused = Lwt_sequence.create () +let paused_count = ref 0 + +let pause () = + let waiter, wakener = task () in + let node = Lwt_sequence.add_r wakener paused in + on_cancel waiter (fun () -> Lwt_sequence.remove node); + incr paused_count; + !pause_hook !paused_count; + waiter + +let wakeup_paused () = + if not (Lwt_sequence.is_empty paused) then begin + let tmp = Lwt_sequence.create () in + Lwt_sequence.transfer_r paused tmp; + paused_count := 0; + Lwt_sequence.iter_l (fun wakener -> wakeup wakener ()) tmp + end + +let register_pause_notifier f = pause_hook := f + +let paused_count () = !paused_count + +(* +-----------------------------------------------------------------+ + | Bakctrace support | + +-----------------------------------------------------------------+ *) + +let backtrace_bind add_loc t f = + match (repr t).state with + | Return v -> + f v + | Fail exn -> + thread { state = Fail(add_loc exn) } + | Sleep sleeper -> + let res = temp sleeper.cancel in + let data = !current_data in + add_immutable_waiter sleeper + (function + | Return v -> current_data := data; connect res (try f v with exn -> fail (add_loc exn)) + | Fail exn -> fast_connect res (Fail(add_loc exn)) + | _ -> assert false); + res + | Repr _ -> + assert false + +let backtrace_catch add_loc x f = + let t = try x () with exn -> fail exn in + match (repr t).state with + | Return _ -> + t + | Fail exn -> + f (add_loc exn) + | Sleep sleeper -> + let res = temp sleeper.cancel in + let data = !current_data in + add_immutable_waiter sleeper + (function + | Return _ as state -> fast_connect res state + | Fail exn -> current_data := data; connect res (try f exn with exn -> fail (add_loc exn)) + | _ -> assert false); + res + | Repr _ -> + assert false + +let backtrace_try_bind add_loc x f g = + let t = try x () with exn -> fail exn in + match (repr t).state with + | Return v -> + f v + | Fail exn -> + g (add_loc exn) + | Sleep sleeper -> + let res = temp sleeper.cancel in + let data = !current_data in + add_immutable_waiter sleeper + (function + | Return v -> current_data := data; connect res (try f v with exn -> fail (add_loc exn)) + | Fail exn -> current_data := data; connect res (try g exn with exn -> fail (add_loc exn)) + | _ -> assert false); + res + | Repr _ -> + assert false + +let backtrace_finalize add_loc f g = + backtrace_try_bind add_loc f + (fun x -> g () >>= fun () -> return x) + (fun e -> g () >>= fun () -> fail (add_loc e)) + +(* +-----------------------------------------------------------------+ + | Threads state query | + +-----------------------------------------------------------------+ *) + +module State = struct + type 'a state = + | Return of 'a + | Fail of exn + | Sleep +end + +let state t = match (repr t).state with + | Return v -> State.Return v + | Fail exn -> State.Fail exn + | Sleep _ -> State.Sleep + | Repr _ -> assert false + +include State diff --git a/thirdparty/lwt-2.3.2/src/core/lwt.mli b/thirdparty/lwt-2.3.2/src/core/lwt.mli new file mode 100644 index 0000000..576684b --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt.mli @@ -0,0 +1,396 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Module [Lwt]: cooperative light-weight threads. *) + +(** This module defines {e cooperative light-weight threads} with + their primitives. A {e light-weight thread} represent a + computation that may be not terminated, for example because it is + waiting for some event to happen. + + Lwt threads are cooperative in the sense that switching to another + thread is awlays explicit (with {!wakeup} or {!wekup_exn}). When a + thread is running, it executes as much as possible, and then + returns (a value or an eror) or sleeps. + + Note that inside a Lwt thread, exceptions must be raised with + {!fail} instead of [raise]. Also the [try ... with ...] + construction will not catch Lwt errors. You must use {!catch} + instead. You can also use {!wrap} for functions that may raise + normal exception. + + Lwt also provides the syntax extension {!Pa_lwt} to make code + using Lwt more readable. +*) + +(** {6 Definitions and basics} *) + +type +'a t + (** The type of threads returning a result of type ['a]. *) + +val return : 'a -> 'a t + (** [return e] is a thread whose return value is the value of the + expression [e]. *) + +val fail : exn -> 'a t + (** [fail e] is a thread that fails with the exception [e]. *) + +val bind : 'a t -> ('a -> 'b t) -> 'b t + (** [bind t f] is a thread which first waits for the thread [t] to + terminate and then, if the thread succeeds, behaves as the + application of function [f] to the return value of [t]. If the + thread [t] fails, [bind t f] also fails, with the same + exception. + + The expression [bind t (fun x -> t')] can intuitively be read as + [let x = t in t'], and if you use the {e lwt.syntax} syntax + extension, you can write a bind operation like that: [lwt x = t in t']. + + Note that [bind] is also often used just for synchronization + purpose: [t'] will not execute before [t] is terminated. + + The result of a thread can be bound several time. *) + +val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + (** [t >>= f] is an alternative notation for [bind t f]. *) + +val (=<<) : ('a -> 'b t) -> 'a t -> 'b t + (** [f =<< t] is [t >>= f] *) + +val map : ('a -> 'b) -> 'a t -> 'b t + (** [map f m] map the result of a thread. This is the same as [bind + m (fun x -> return (f x))] *) + +val (>|=) : 'a t -> ('a -> 'b) -> 'b t + (** [m >|= f] is [map f m] *) + +val (=|<) : ('a -> 'b) -> 'a t -> 'b t + (** [f =|< m] is [map f m] *) + +(** {6 Thread storage} *) + +type 'a key + (** Type of a key. Keys are used to store local values into + threads *) + +val new_key : unit -> 'a key + (** [new_key ()] creates a new key. *) + +val get : 'a key -> 'a option + (** [get key] returns the value associated with [key] in the current + thread. *) + +val with_value : 'a key -> 'a option -> (unit -> 'b) -> 'b + (** [with_value key value f] executes [f] with [value] associated to + [key]. The previous value associated to [key] is restored after + [f] terminates. *) + +(** {6 Exceptions handling} *) + +val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t + (** [catch t f] is a thread that behaves as the thread [t ()] if + this thread succeeds. If the thread [t ()] fails with some + exception, [catch t f] behaves as the application of [f] to this + exception. *) + +val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t + (** [try_bind t f g] behaves as [bind (t ()) f] if [t] does not + fail. Otherwise, it behaves as the application of [g] to the + exception associated to [t ()]. *) + +val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t + (** [finalize f g] returns the same result as [f ()] whether it + fails or not. In both cases, [g ()] is executed after [f]. *) + +val wrap : (unit -> 'a) -> 'a t + (** [wrap f] calls [f] and transform the result into a monad. If [f] + raise an exception, it is catched by Lwt. + + This is actually the same as: + + {[ + try + return (f ()) + with exn -> + fail exn + ]} + *) + +val wrap1 : ('a -> 'b) -> 'a -> 'b t + (** [wrap1 f x] applies [f] on [x] and returns the result as a + thread. If the application of [f] to [x] raise an exception it + is catched and a thread is returned. + + Note that you must use {!wrap} instead of {!wrap1} if the + evaluation of [x] may raise an exception. + + for example the following code is not ok: + + {[ + wrap1 f (Hashtbl.find table key) + ]} + + you should write instead: + + {[ + wrap (fun () -> f (Hashtbl.find table key)) + ]} + *) + +val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t +val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t +val wrap4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e t +val wrap5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f t +val wrap6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g t +val wrap7 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h t + +(** {6 Multi-threads composition} *) + +val choose : 'a t list -> 'a t + (** [choose l] behaves as the first thread in [l] to terminate. If + several threads are already terminated, one is choosen at + random. + + Note: {!choose} leaves the local values of the current thread + unchanged. *) + +val nchoose : 'a t list -> 'a list t + (** [nchoose l] returns the value of all that have succcessfully + terminated. If all threads are sleeping, it waits for at least + one to terminates. If one the threads of [l] fails, [nchoose] + fails with the same exception. + + Note: {!nchoose} leaves the local values of the current thread + unchanged. *) + +val nchoose_split : 'a t list -> ('a list * 'a t list) t + (** [nchoose_split l] does the same as {!nchoose} but also retrurns + the list of threads that have not yet terminated. *) + +val join : unit t list -> unit t + (** [join l] waits for all threads in [l] to terminate. If one of + the threads fails, then [join l] will fails with the same + exception as the first one to terminate. + + Note: {!join} leaves the local values of the current thread + unchanged. *) + +val ( ) : 'a t -> 'a t -> 'a t + (** [t t'] is the same as [choose [t; t']] *) + +val ( <&> ) : unit t -> unit t -> unit t + (** [t <&> t'] is the same as [join [t; t']] *) + +val ignore_result : 'a t -> unit + (** [ignore_result t] start the thread [t] and ignores its result + value if the thread terminates sucessfully. However, if the + thread [t] fails, the exception is raised instead of being + ignored. + + You should use this function if you want to start a thread and + don't care what its return value is, nor when it terminates (for + instance, because it is looping). Note that if the thread [t] + yields and later fails, the exception will not be raised at this + point in the program. *) + +(** {6 Sleeping and resuming} *) + +type 'a u + (** The type of thread wakeners. *) + +val wait : unit -> 'a t * 'a u + (** [wait ()] is a pair of a thread which sleeps forever (unless it + is resumed by one of the functions [wakeup], [wakeup_exn] below) + and the corresponding wakener. This thread does not block the + execution of the remainder of the program (except of course, if + another thread tries to wait for its termination). *) + +val wakeup : 'a u -> 'a -> unit + (** [wakeup t e] makes the sleeping thread [t] terminate and return + the value of the expression [e]. *) + +val wakeup_exn : 'a u -> exn -> unit + (** [wakeup_exn t e] makes the sleeping thread [t] fail with the + exception [e]. *) + +val wakeup_later : 'a u -> 'a -> unit + (** Same as {!wakeup} but it is not guaranteed that the thread will + be wakeup immediately. *) + +val wakeup_later_exn : 'a u -> exn -> unit + (** Same as {!wakeup_exn} but it is not guaranteed that the thread + will be wakeup immediately. *) + +val waiter_of_wakener : 'a u -> 'a t + (** Returns the thread associated to a wakener. *) + +(** {6 Threads state} *) + +(** State of a thread *) +type 'a state = + | Return of 'a + (** The thread which has successfully terminated *) + | Fail of exn + (** The thread raised an exception *) + | Sleep + (** The thread is sleeping *) + +val state : 'a t -> 'a state + (** [state t] returns the state of a thread *) + +(** {6 Cancelable threads} *) + +(** Cancelable threads are the same as regular threads except that + they can be canceled. *) + +exception Canceled + (** Canceled threads fails with this exception *) + +val task : unit -> 'a t * 'a u + (** [task ()] is the same as [wait ()] except that threads created + with [task] can be canceled. *) + +val on_cancel : 'a t -> (unit -> unit) -> unit + (** [on_cancel t f] executes [f] when [t] is canceled. This is the + same as catching [Canceled]. *) + +val cancel : 'a t -> unit + (** [cancel t] cancels the threads [t]. This means that the deepest + sleeping thread created with [task] and connected to [t] is + woken up with the exception {!Canceled}. + + For example, in the following code: + + {[ + let waiter, wakener = task () in + cancel (waiter >> printl "plop") + ]} + + [waiter] will be woken up with {!Canceled}. + *) + +val pick : 'a t list -> 'a t + (** [pick l] is the same as {!choose}, except that it cancels all + sleeping threads when one terminates. + + Note: {!pick} leaves the local values of the current thread + unchanged. *) + +val npick : 'a t list -> 'a list t + (** [npick l] is the same as {!nchoose}, except that it cancels all + sleeping threads when one terminates. + + Note: {!npick} leaves the local values of the current thread + unchanged. *) + +val protected : 'a t -> 'a t + (** [protected thread] creates a new cancelable thread which behave + as [thread] except that cancelling it does not cancel + [thread]. *) + +(** {6 Pause} *) + +val pause : unit -> unit t + (** [pause ()] is a sleeping thread which is wake up on the next + call to {!wakeup_paused}. A thread created with [pause] can be + canceled. *) + +val wakeup_paused : unit -> unit + (** [wakeup_paused ()] wakes up all threads which suspended + themselves with {!pause}. + + This function is called by the scheduler, before entering the + main loop. You usually do not have to call it directly, except + if you are writing a custom scheduler. + + Note that if a paused thread resume and pause again, it will not + be wakeup at this point. *) + +val paused_count : unit -> int + (** [paused_count ()] returns the number of thread currently + paused. *) + +val register_pause_notifier : (int -> unit) -> unit + (** [register_pause_notifier f] register a function [f] that will be + called each time pause is called. The parameter passed to [f] is + the new number of threads paused. It is usefull to be able to + call {!wakeup_paused} when there is no scheduler *) + +(** {6 Misc} *) + +val on_success : 'a t -> ('a -> unit) -> unit + (** [on_success t f] executes [f] when [t] terminates without + failing. This is the same as: + + {[ + ignore_result (bind t (fun x -> f x; return ())) + ]} + + but a bit more efficient. + *) + +val on_failure : 'a t -> (exn -> unit) -> unit + (** [on_failure t f] executes [f] when [t] terminates and + fails. This is the same as: + + {[ + ignore_result (catch t (fun e -> f e; return ())) + ]} + + but a bit more efficient. + *) + +val on_termination : 'a t -> (unit -> unit) -> unit + (** [on_termination t f] executes [f] when [t] terminates. This is + the same as: + + {[ + ignore_result (finalize (fun () -> t) (fun () -> f (); return ())) + ]} + + but a bit more efficient. + *) + +(**/**) + +(* The functions below are probably not useful for the casual user. + They provide the basic primitives on which can be built multi- + threaded libraries such as Lwt_unix. *) + +val poll : 'a t -> 'a option + (* [poll e] returns [Some v] if the thread [e] is terminated and + returned the value [v]. If the thread failed with some + exception, this exception is raised. If the thread is still + running, [poll e] returns [None] without blocking. *) + +val apply : ('a -> 'b t) -> 'a -> 'b t + (* [apply f e] apply the function [f] to the expression [e]. If + an exception is raised during this application, it is caught + and the resulting thread fails with this exception. *) +(* Q: Could be called 'glue' or 'trap' or something? *) + +val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t +val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t +val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t +val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t + diff --git a/thirdparty/lwt-2.3.2/src/core/lwt.mllib b/thirdparty/lwt-2.3.2/src/core/lwt.mllib new file mode 100644 index 0000000..f9ddffb --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt.mllib @@ -0,0 +1,14 @@ +# OASIS_START +# DO NOT EDIT (digest: ecdfab02163af2abad730a4cf20c2630) +Lwt_condition +Lwt_list +Lwt +Lwt_mutex +Lwt_mvar +Lwt_pool +Lwt_sequence +Lwt_stream +Lwt_switch +Lwt_util +Lwt_pqueue +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_condition.ml b/thirdparty/lwt-2.3.2/src/core/lwt_condition.ml new file mode 100644 index 0000000..179d6d1 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_condition.ml @@ -0,0 +1,63 @@ +(******************************************************************************) +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_condition + ****************************************************************************** + * Copyright (c) 2009, Metaweb Technologies, Inc. + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * * Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials provided + * with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR + * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE + * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN + * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ******************************************************************************) + +open Lwt + +type 'a t = 'a Lwt.u Lwt_sequence.t + +let create = Lwt_sequence.create + +let wait ?mutex cvar = + let waiter, wakener = Lwt.task () in + let node = Lwt_sequence.add_r wakener cvar in + on_cancel waiter (fun () -> Lwt_sequence.remove node); + let () = + match mutex with + | Some m -> Lwt_mutex.unlock m + | None -> () + in + try_lwt + waiter + finally + match mutex with + | Some m -> Lwt_mutex.lock m + | None -> return () + +let signal cvar arg = + try + wakeup_later (Lwt_sequence.take_l cvar) arg + with Lwt_sequence.Empty -> + () + +let broadcast cvar arg = + let wakeners = Lwt_sequence.fold_r (fun x l -> x :: l) cvar [] in + Lwt_sequence.iter_node_l Lwt_sequence.remove cvar; + List.iter (fun wakener -> wakeup_later wakener arg) wakeners diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_condition.mli b/thirdparty/lwt-2.3.2/src/core/lwt_condition.mli new file mode 100644 index 0000000..8e011de --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_condition.mli @@ -0,0 +1,65 @@ +(******************************************************************************) +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_condition + ****************************************************************************** + * Copyright (c) 2009, Metaweb Technologies, Inc. + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * * Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials provided + * with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR + * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE + * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN + * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ******************************************************************************) + +(** Conditions *) + +(** Condition variables to synchronize between threads. *) + +type 'a t + (** Condition variable type. The type parameter denotes the type of + value propagated from notifier to waiter. *) + +val create : unit -> 'a t + (** [create ()] creates a new condition variable. *) + +val wait : ?mutex:Lwt_mutex.t -> 'a t -> 'a Lwt.t + (** [wait mutex condvar] will cause the current thread to block, + awaiting notification for a condition variable, [condvar]. If + provided, the [mutex] must have been previously locked (within + the scope of [Lwt_mutex.with_lock], for example) and is + temporarily unlocked until the condition is notified. Upon + notification, [mutex] is re-locked before [wait] returns and + the thread's activity is resumed. When the awaited condition + is notified, the value parameter passed to [notify] is + returned. *) + +val signal : 'a t -> 'a -> unit + (** [signal condvar value] notifies that a condition is ready. A + single waiting thread will be awoken and will receive the + notification value which will be returned from [wait]. Note + that condition notification is not "sticky", i.e. if there is + no waiter when [notify] is called, the notification will be + missed and the value discarded. *) + +val broadcast : 'a t -> 'a -> unit + (** [broadcast condvar value] notifies all waiting threads. Each + will be awoken in turn and will receive the same notification + value. *) diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_list.ml b/thirdparty/lwt-2.3.2/src/core/lwt_list.ml new file mode 100644 index 0000000..2b0fba2 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_list.ml @@ -0,0 +1,189 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_list + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt + +let rec iter_s f l = + match l with + | [] -> + return () + | x :: l -> + lwt () = f x in + iter_s f l + +let rec iter_p f l = + match l with + | [] -> + return () + | x :: l -> + let t = f x and lt = iter_p f l in + lwt () = t in + lt + +let rec map_s f l = + match l with + | [] -> + return [] + | x :: l -> + lwt x = f x in + lwt l = map_s f l in + return (x :: l) + +let rec map_p f l = + match l with + | [] -> + return [] + | x :: l -> + lwt x = f x and l = map_p f l in + return (x :: l) + +let rec rev_map_append_s acc f l = + match l with + | [] -> + return acc + | x :: l -> + lwt x = f x in + rev_map_append_s (x :: acc) f l + +let rev_map_s f l = + rev_map_append_s [] f l + +let rec rev_map_append_p acc f l = + match l with + | [] -> + acc + | x :: l -> + rev_map_append_p (lwt x = f x and l = acc in return (x :: l)) f l + +let rev_map_p f l = + rev_map_append_p (return []) f l + +let rec fold_left_s f acc l = + match l with + | [] -> + return acc + | x :: l -> + lwt acc = f acc x in + fold_left_s f acc l + +let rec fold_right_s f l acc = + match l with + | [] -> + return acc + | x :: l -> + lwt acc = fold_right_s f l acc in + f x acc + +let rec for_all_s f l = + match l with + | [] -> + return true + | x :: l -> + f x >>= function + | true -> + for_all_s f l + | false -> + return false + +let rec for_all_p f l = + match l with + | [] -> + return true + | x :: l -> + lwt bx = f x and bl = for_all_p f l in + return (bx && bl) + +let rec exists_s f l = + match l with + | [] -> + return false + | x :: l -> + f x >>= function + | true -> + return true + | false -> + exists_s f l + +let rec exists_p f l = + match l with + | [] -> + return false + | x :: l -> + lwt bx = f x and bl = exists_p f l in + return (bx || bl) + +let rec find_s f l = + match l with + | [] -> + raise_lwt Not_found + | x :: l -> + f x >>= function + | true -> + return x + | false -> + find_s f l + +let rec filter_s f l = + match l with + | [] -> + return [] + | x :: l -> + f x >>= function + | true -> + lwt l = filter_s f l in + return (x :: l) + | false -> + filter_s f l + +let rec filter_p f l = + match l with + | [] -> + return [] + | x :: l -> + lwt bx = f x and l = filter_p f l in + if bx then + return (x :: l) + else + return l + +let rec partition_s f l = + match l with + | [] -> + return ([], []) + | x :: l -> + lwt bx = f x in + lwt l_l, l_r = partition_s f l in + if bx then + return (x :: l_l, l_r) + else + return (l_l, x :: l_r) + +let rec partition_p f l = + match l with + | [] -> + return ([], []) + | x :: l -> + lwt bx = f x and l_l, l_r = partition_p f l in + if bx then + return (x :: l_l, l_r) + else + return (l_l, x :: l_r) diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_list.mli b/thirdparty/lwt-2.3.2/src/core/lwt_list.mli new file mode 100644 index 0000000..ff4e30c --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_list.mli @@ -0,0 +1,59 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_list + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** List helpers *) + +(** Note: this module use the same naming convention as + {!Lwt_stream}. *) + +(** {6 List iterators} *) + +val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t +val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + +val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t +val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t +val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + +val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t + +val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t + +(** {6 List scanning} *) + +val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t +val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + +val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t +val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + +(** {6 List searching} *) + +val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a Lwt.t + +val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t +val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + +val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t +val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_mutex.ml b/thirdparty/lwt-2.3.2/src/core/lwt_mutex.ml new file mode 100644 index 0000000..86d5211 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_mutex.ml @@ -0,0 +1,60 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_mutex + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt + +type t = { mutable locked : bool; mutable waiters : unit Lwt.u Lwt_sequence.t } + +let create () = { locked = false; waiters = Lwt_sequence.create () } + +let rec lock m = + if m.locked then begin + let (res, w) = Lwt.task () in + let node = Lwt_sequence.add_r w m.waiters in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + res + end else begin + m.locked <- true; + Lwt.return () + end + +let unlock m = + if m.locked then begin + if Lwt_sequence.is_empty m.waiters then + m.locked <- false + else + (* We do not use [Lwt.wakeup] here to avoid a stack overflow + when unlocking a lot of threads. *) + Lwt.wakeup_later (Lwt_sequence.take_l m.waiters) () + end + +let with_lock m f = + lwt () = lock m in + try_lwt + f () + finally + unlock m; + return () + +let is_locked m = m.locked +let is_empty m = Lwt_sequence.is_empty m.waiters diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_mutex.mli b/thirdparty/lwt-2.3.2/src/core/lwt_mutex.mli new file mode 100644 index 0000000..afbd483 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_mutex.mli @@ -0,0 +1,62 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_mutex + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Cooperative locks for mutual exclusion *) + +type t + (** Type of Lwt mutexes *) + +val create : unit -> t + (** [create ()] creates a new mutex, which is initially unlocked *) + +val lock : t -> unit Lwt.t + (** [lock mutex] lockcs the mutex, that is: + + - if the mutex is unlocked, then it is marked as locked and + {!lock} returns immediatly + + - if it is locked, then {!lock} waits for all threads waiting on + the mutex to terminate, then it resumes when the last one + unlocks the mutex + + Note: threads are wake up is the same order they try to lock the + mutex *) + +val unlock : t -> unit + (** [unlock mutex] unlock the mutex if no threads is waiting on + it. Otherwise it will eventually removes the first one and + resumes it. *) + +val is_locked : t -> bool + (** [locked mutex] returns whether [mutex] is currently locked *) + +val is_empty : t -> bool + (** [is_empty mutex] returns [true] if they are no thread waiting on + the mutex, and [false] otherwise *) + +val with_lock : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [with_lock lock f] is used to lock a mutex within a block scope. + The function [f ()] is called with the mutex locked, and its + result is returned from the call to {with_lock}. If an exception + is raised from f, the mutex is also unlocked before the scope of + {with_lock} is exited. *) diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_mvar.ml b/thirdparty/lwt-2.3.2/src/core/lwt_mvar.ml new file mode 100644 index 0000000..0666e35 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_mvar.ml @@ -0,0 +1,87 @@ +(* -*- Mode: Caml; indent-tabs-mode: nil -*- *) +(******************************************************************************) +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_mon + ****************************************************************************** + * Copyright (c) 2009, Metaweb Technologies, Inc. + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * * Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials provided + * with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR + * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE + * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN + * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ******************************************************************************) + +let return_unit = Lwt.return () + +type 'a t = { + mutable contents : 'a option; + (* Current contents *) + + mutable writers : ('a * unit Lwt.u) Lwt_sequence.t; + (* Threads waiting to put a value *) + + mutable readers : 'a Lwt.u Lwt_sequence.t; + (* Threads waiting for a value *) +} + +let create_empty () = + { contents = None; + writers = Lwt_sequence.create (); + readers = Lwt_sequence.create () } + +let create v = + { contents = Some v; + writers = Lwt_sequence.create (); + readers = Lwt_sequence.create () } + +let put mvar v = + match mvar.contents with + | None -> + begin match Lwt_sequence.take_opt_l mvar.readers with + | None -> + mvar.contents <- Some v + | Some w -> + Lwt.wakeup_later w v + end; + return_unit + | Some _ -> + let (res, w) = Lwt.task () in + let node = Lwt_sequence.add_r (v, w) mvar.writers in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + res + +let take mvar = + match mvar.contents with + | Some v -> + begin match Lwt_sequence.take_opt_l mvar.writers with + | Some(v', w) -> + mvar.contents <- Some v'; + Lwt.wakeup_later w () + | None -> + mvar.contents <- None + end; + Lwt.return v + | None -> + let (res, w) = Lwt.task () in + let node = Lwt_sequence.add_r w mvar.readers in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + res diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_mvar.mli b/thirdparty/lwt-2.3.2/src/core/lwt_mvar.mli new file mode 100644 index 0000000..17b825e --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_mvar.mli @@ -0,0 +1,63 @@ +(* -*- Mode: Caml; indent-tabs-mode: nil -*- *) +(******************************************************************************) +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_mon + ****************************************************************************** + * Copyright (c) 2009, Metaweb Technologies, Inc. + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * * Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials provided + * with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR + * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE + * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN + * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ******************************************************************************) + +(** Mailbox variables *) + +(** "Mailbox" variables implement a synchronising variable, used for + communication between concurrent threads. + + This code adapted from + {{:http://eigenclass.org/hiki.rb?cmd=view&p=lightweight-threads-with-lwt}Comparing lightweight threads (eigenclass.org)} *) + +type 'a t + (** The type of a mailbox variable. Mailbox variables are used to + communicate values between threads in a synchronous way. The + type parameter specifies the type of the value propagated from + [put] to [take]. *) + +val create : 'a -> 'a t + (** [create v] creates a new mailbox variable containing value [v]. *) + +val create_empty : unit -> 'a t + (** [create ()] creates a new empty mailbox variable. *) + +val put : 'a t -> 'a -> unit Lwt.t + (** [put mvar value] puts a value into a mailbox variable. This + value will remain in the mailbox until [take] is called to + remove it. If the mailbox is not empty, the current thread will + block until it is emptied. *) + +val take : 'a t -> 'a Lwt.t + (** [take mvar] will take any currently available value from the + mailbox variable. If no value is currently available, the + current thread will block, awaiting a value to be [put] by + another thread. *) diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_pool.ml b/thirdparty/lwt-2.3.2/src/core/lwt_pool.ml new file mode 100644 index 0000000..489418a --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_pool.ml @@ -0,0 +1,93 @@ +(* Lwt + * http://www.ocsigen.org + * Copyright (C) 2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later version. + * See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Lwt + +(* +XXX Close after some timeout +... +*) + +type 'a t = + { create : unit -> 'a Lwt.t; + check : 'a -> (bool -> unit) -> unit; + max : int; + mutable count : int; + list : 'a Queue.t; + waiters : 'a Lwt.u Lwt_sequence.t } + +let create m ?(check = fun _ f -> f true) create = + { max = m; + create = create; + check = check; + count = 0; + list = Queue.create (); + waiters = Lwt_sequence.create () } + +let create_member p = + try_lwt + p.count <- p.count + 1; (* must be done before p.create *) + lwt mem = p.create () in + return mem + with exn -> + (* create failed, so don't increment count *) + p.count <- p.count - 1; + raise_lwt exn + +let acquire p = + try + return (Queue.take p.list) + with Queue.Empty -> + if p.count < p.max then + create_member p + else begin + let waiter, wakener = task () in + let node = Lwt_sequence.add_r wakener p.waiters in + on_cancel waiter (fun () -> Lwt_sequence.remove node); + waiter + end + +let release p c = + try + wakeup_later (Lwt_sequence.take_l p.waiters) c + with Lwt_sequence.Empty -> + Queue.push c p.list + +let checked_release p c = + p.check c begin fun ok -> + if ok then + release p c + else + ignore (p.count <- p.count - 1; + lwt c = create_member p in + release p c; + return ()) + end + +let use p f = + lwt c = acquire p in + try_lwt + lwt r = f c in + release p c; + return r + with e -> + checked_release p c; + raise_lwt e diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_pool.mli b/thirdparty/lwt-2.3.2/src/core/lwt_pool.mli new file mode 100644 index 0000000..26ceda1 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_pool.mli @@ -0,0 +1,40 @@ +(* Lwt + * http://www.ocsigen.org + * Copyright (C) 2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later version. + * See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(** Creating pools (for example pools of connections to a database). *) + +(** Instead of creating a new connection each time you need one, + keep a pool of opened connections and reuse opened connections + that are free. + *) + +(** Type of pools *) +type 'a t + +(** [create n f] creates a new pool with at most [n] members. + [f] is the function to use to create a new pool member. *) +val create : + int -> ?check:('a -> (bool -> unit) -> unit) -> (unit -> 'a Lwt.t) -> 'a t + +(** [use p f] takes one free member of the pool [p] and gives it to the function + [f]. + *) +val use : 'a t -> ('a -> 'b Lwt.t) -> 'b Lwt.t diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.ml b/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.ml new file mode 100644 index 0000000..2c966a8 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.ml @@ -0,0 +1,108 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_pqueue + * Copyright (C) 1999-2004 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +module type OrderedType = + sig + type t + val compare: t -> t -> int + end + +module type S = + sig + type elt + type t + val empty: t + val is_empty: t -> bool + val add: elt -> t -> t + val union: t -> t -> t + val find_min: t -> elt + val lookup_min: t -> elt option + val remove_min: t -> t + val size: t -> int + end + +module Make(Ord: OrderedType) : (S with type elt = Ord.t) = + struct + type elt = Ord.t + + type t = tree list + and tree = Node of elt * int * tree list + + let root (Node (x, _, _)) = x + let rank (Node (_, r, _)) = r + let link (Node (x1, r1, c1) as t1) (Node (x2, r2, c2) as t2) = + let c = Ord.compare x1 x2 in + if c <= 0 then Node (x1, r1 + 1, t2::c1) else Node(x2, r2 + 1, t1::c2) + let rec ins t = + function + [] -> + [t] + | (t'::_) as ts when rank t < rank t' -> + t::ts + | t'::ts -> + ins (link t t') ts + + let empty = [] + let is_empty ts = ts = [] + let add x ts = ins (Node (x, 0, [])) ts + let rec union ts ts' = + match ts, ts' with + ([], _) -> ts' + | (_, []) -> ts + | (t1::ts1, t2::ts2) -> + if rank t1 < rank t2 then t1 :: union ts1 (t2::ts2) + else if rank t2 < rank t1 then t2 :: union (t1::ts1) ts2 + else ins (link t1 t2) (union ts1 ts2) + + let rec find_min = + function + [] -> raise Not_found + | [t] -> root t + | t::ts -> + let x = find_min ts in + let c = Ord.compare (root t) x in + if c < 0 then root t else x + + let lookup_min t = + try Some(find_min t) with Not_found -> None + + let rec get_min = + function + [] -> assert false + | [t] -> (t, []) + | t::ts -> + let (t', ts') = get_min ts in + let c = Ord.compare (root t) (root t') in + if c < 0 then (t, ts) else (t', t::ts') + + let remove_min = + function + [] -> raise Not_found + | ts -> + let (Node (x, r, c), ts) = get_min ts in + union (List.rev c) ts + + let rec size l = + let rec sizetree (Node (_,_,tl)) = 1 + size tl in + List.fold_left (fun s t -> s + sizetree t) 0 l + end diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.mli b/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.mli new file mode 100644 index 0000000..0fc86f1 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.mli @@ -0,0 +1,44 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_pqueue + * Copyright (C) 1999-2004 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +module type OrderedType = + sig + type t + val compare: t -> t -> int + end + +module type S = + sig + type elt + type t + val empty: t + val is_empty: t -> bool + val add: elt -> t -> t + val union: t -> t -> t + val find_min: t -> elt + val lookup_min: t -> elt option + val remove_min: t -> t + val size: t -> int + end + +module Make(Ord: OrderedType) : S with type elt = Ord.t diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_sequence.ml b/thirdparty/lwt-2.3.2/src/core/lwt_sequence.ml new file mode 100644 index 0000000..e2dbc89 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_sequence.ml @@ -0,0 +1,209 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_sequence + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +exception Empty + +type 'a t = { + mutable prev : 'a t; + mutable next : 'a t; +} + +type 'a node = { + mutable node_prev : 'a t; + mutable node_next : 'a t; + mutable node_data : 'a; + mutable node_active : bool; +} + +external seq_of_node : 'a node -> 'a t = "%identity" +external node_of_seq : 'a t -> 'a node = "%identity" + +(* +-----------------------------------------------------------------+ + | Operations on nodes | + +-----------------------------------------------------------------+ *) + +let get node = + node.node_data + +let set node data = + node.node_data <- data + +let remove node = + if node.node_active then begin + node.node_active <- false; + let seq = seq_of_node node in + seq.prev.next <- seq.next; + seq.next.prev <- seq.prev + end + +(* +-----------------------------------------------------------------+ + | Operations on sequences | + +-----------------------------------------------------------------+ *) + +let create () = + let rec seq = { prev = seq; next = seq } in + seq + +let is_empty seq = seq.next == seq + +let length seq = + let rec loop curr len = + if curr == seq then + len + else + let node = node_of_seq curr in + if node.node_active then + loop node.node_next (len + 1) + else + loop node.node_next len + in + loop seq.next 0 + +let add_l data seq = + let node = { node_prev = seq; node_next = seq.next; node_data = data; node_active = true } in + seq.next.prev <- seq_of_node node; + seq.next <- seq_of_node node; + node + +let add_r data seq = + let node = { node_prev = seq.prev; node_next = seq; node_data = data; node_active = true } in + seq.prev.next <- seq_of_node node; + seq.prev <- seq_of_node node; + node + +let take_l seq = + if is_empty seq then + raise Empty + else begin + let node = node_of_seq seq.next in + remove node; + node.node_data + end + +let take_r seq = + if is_empty seq then + raise Empty + else begin + let node = node_of_seq seq.prev in + remove node; + node.node_data + end + +let take_opt_l seq = + if is_empty seq then + None + else begin + let node = node_of_seq seq.next in + remove node; + Some node.node_data + end + +let take_opt_r seq = + if is_empty seq then + None + else begin + let node = node_of_seq seq.prev in + remove node; + Some node.node_data + end + +let transfer_l s1 s2 = + s2.next.prev <- s1.prev; + s1.prev.next <- s2.next; + s2.next <- s1.next; + s1.next.prev <- s2; + s1.prev <- s1; + s1.next <- s1 + +let transfer_r s1 s2 = + s2.prev.next <- s1.next; + s1.next.prev <- s2.prev; + s2.prev <- s1.prev; + s1.prev.next <- s2; + s1.prev <- s1; + s1.next <- s1 + +let iter_l f seq = + let rec loop curr = + if curr != seq then begin + let node = node_of_seq curr in + if node.node_active then f node.node_data; + loop node.node_next + end + in + loop seq.next + +let iter_r f seq = + let rec loop curr = + if curr != seq then begin + let node = node_of_seq curr in + if node.node_active then f node.node_data; + loop node.node_prev + end + in + loop seq.prev + +let iter_node_l f seq = + let rec loop curr = + if curr != seq then begin + let node = node_of_seq curr in + if node.node_active then f node; + loop node.node_next + end + in + loop seq.next + +let iter_node_r f seq = + let rec loop curr = + if curr != seq then begin + let node = node_of_seq curr in + if node.node_active then f node; + loop node.node_prev + end + in + loop seq.prev + +let fold_l f seq acc = + let rec loop curr acc = + if curr == seq then + acc + else + let node = node_of_seq curr in + if node.node_active then + loop node.node_next (f node.node_data acc) + else + loop node.node_next acc + in + loop seq.next acc + +let fold_r f seq acc = + let rec loop curr acc = + if curr == seq then + acc + else + let node = node_of_seq curr in + if node.node_active then + loop node.node_prev (f node.node_data acc) + else + loop node.node_next acc + in + loop seq.prev acc diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_sequence.mli b/thirdparty/lwt-2.3.2/src/core/lwt_sequence.mli new file mode 100644 index 0000000..7e60dc0 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_sequence.mli @@ -0,0 +1,137 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_sequence + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Mutable sequence of elements *) + +(** A sequence is an object holding a list of elements which support + the following operations: + + - adding an element to the left or the right in time and space O(1) + - taking an element from the left or the right in time and space O(1) + - removing a previously added element from a sequence in time and space O(1) + - removing an element while the sequence is being transversed. +*) + +type 'a t + (** Type of a sequence holding values of type ['a] *) + +type 'a node + (** Type of a node holding one value of type ['a] in a sequence *) + +(** {6 Operation on nodes} *) + +val get : 'a node -> 'a + (** Returns the contents of a node *) + +val set : 'a node -> 'a -> unit + (** Change the contents of a node *) + +val remove : 'a node -> unit + (** Removes a node from the sequence it is part of. It does nothing + if the node has already been removed. *) + +(** {6 Operations on sequence} *) + +val create : unit -> 'a t + (** [create ()] creates a new empty sequence *) + +val is_empty : 'a t -> bool + (** Returns [true] iff the given sequence is empty *) + +val length : 'a t -> int + (** Returns the number of elemenets in the given sequence. This is a + O(n) operation where [n] is the number of elements in the + sequence. *) + +val add_l : 'a -> 'a t -> 'a node + (** [add_l x s] adds [x] to the left of the sequence [s] *) + +val add_r : 'a -> 'a t -> 'a node + (** [add_l x s] adds [x] to the right of the sequence [s] *) + +exception Empty + (** Exception raised by [take_l] and [tale_s] and when the sequence + is empty *) + +val take_l : 'a t -> 'a + (** [take_l x s] remove and returns the leftmost element of [s] + + @raise Empty if the sequence is empty *) + +val take_r : 'a t -> 'a + (** [take_l x s] remove and returns the rightmost element of [s] + + @raise Empty if the sequence is empty *) + +val take_opt_l : 'a t -> 'a option + (** [take_opt_l x s] remove and returns [Some x] where [x] is the + leftmost element of [s] or [None] if [s] is empty *) + +val take_opt_r : 'a t -> 'a option + (** [take_opt_l x s] remove and returns [Some x] where [x] is the + rightmost element of [s] or [None] if [s] is empty *) + +val transfer_l : 'a t -> 'a t -> unit + (** [transfer_l s1 s2] removes all elements of [s1] and add them at + the left of [s2]. This operation runs in constant time and + space. *) + +val transfer_r : 'a t -> 'a t -> unit + (** [transfer_r s1 s2] removes all elements of [s1] and add them at + the right of [s2]. This operation runs in constant time and + space. *) + +(** {6 Sequence iterators} *) + +(** Note: it is OK to remove a node while traversing a sequence *) + +val iter_l : ('a -> unit) -> 'a t -> unit + (** [iter_l f s] applies [f] on all elements of [s] starting from + the left *) + +val iter_r : ('a -> unit) -> 'a t -> unit + (** [iter_l f s] applies [f] on all elements of [s] starting from + the right *) + +val iter_node_l : ('a node -> unit) -> 'a t -> unit + (** [iter_l f s] applies [f] on all nodes of [s] starting from + the left *) + +val iter_node_r : ('a node -> unit) -> 'a t -> unit + (** [iter_l f s] applies [f] on all nodes of [s] starting from + the right *) + +val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold_l f s] is: + {[ + fold_l f s x = f en (... (f e2 (f e1 x))) + ]} + where [e1], [e2], ..., [en] are the elements of [s] + *) + +val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold_r f s] is: + {[ + fold_r f s x = f e1 (f e2 (... (f en x))) + ]} + where [e1], [e2], ..., [en] are the elements of [s] + *) diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_stream.ml b/thirdparty/lwt-2.3.2/src/core/lwt_stream.ml new file mode 100644 index 0000000..270d529 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_stream.ml @@ -0,0 +1,759 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_stream + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt + +exception Empty + +type 'a t = { + next : unit -> 'a option Lwt.t; + (* The source of the stream *) + queue : 'a option Queue.t; + (* Queue of pending elements, which are not yet consumed *) + clones : 'a option Queue.t Weak.t ref; + (* List of queues of all clones of this event (including this + event) *) + mutex : Lwt_mutex.t; + (* Mutex to prevent concurrent access to [next] *) +} + +let add_clone wa q = + let len = Weak.length !wa in + (* loop search for a free cell in [wa] and fill it with [q]: *) + let rec loop i = + if i = len then begin + (* Growing *) + let clones = Weak.create (len + 1) in + Weak.blit !wa 0 clones 0 len; + wa := clones; + Weak.set clones len (Some q) + end else if Weak.check !wa i then + loop (i + 1) + else + Weak.set !wa i (Some q) + in + loop 0 + +let clone s = + let s' = { + next = s.next; + queue = Queue.copy s.queue; + clones = s.clones; + mutex = s.mutex; + } in + add_clone s'.clones s'.queue; + s' + +let from f = + let s = { + next = f; + queue = Queue.create (); + clones = ref(Weak.create 1); + mutex = Lwt_mutex.create (); + } in + Weak.set !(s.clones) 0 (Some s.queue); + s + +let of_list l = + let l = ref l in + from (fun () -> + match !l with + | [] -> return None + | x :: l' -> l := l'; return (Some x)) + +let of_array a = + let len = Array.length a and i = ref 0 in + from (fun () -> + if !i = len then + return None + else begin + let c = Array.unsafe_get a !i in + incr i; + return (Some c) + end) + +let of_string s = + let len = String.length s and i = ref 0 in + from (fun () -> + if !i = len then + return None + else begin + let c = String.unsafe_get s !i in + incr i; + return (Some c) + end) + +module EQueue : +sig + type 'a t + val create : unit -> 'a t * ('a option -> unit) + val pop : 'a t -> 'a option Lwt.t +end = +struct + type 'a state = + | No_mail + | Waiting of 'a option Lwt.u + | Full of 'a option Queue.t + + type 'a t = { + mutable state : 'a state; + } + + let create () = + let box = { state = No_mail } in + let weak_box = Weak.create 1 in + Weak.set weak_box 0 (Some box); + let push v = + match Weak.get weak_box 0 with + | None -> () + | Some box -> + match box.state with + | No_mail -> + let q = Queue.create () in + Queue.push v q; + box.state <- Full q + | Waiting wakener -> + box.state <- No_mail; + wakeup_later wakener v + | Full q -> + Queue.push v q + in + (box, push) + + let pop b = match b.state with + | No_mail -> + let waiter, wakener = task () in + Lwt.on_cancel waiter (fun () -> b.state <- No_mail); + b.state <- Waiting wakener; + waiter + | Waiting _ -> + (* Calls to next are serialized, so this case will never + happened *) + assert false + | Full q -> + let v = Queue.take q in + if Queue.is_empty q then b.state <- No_mail; + return v +end + +let create () = + let box, push = EQueue.create () in + (from (fun () -> EQueue.pop box), push) + +let push_clones wa x = + for i = 0 to Weak.length wa - 1 do + match Weak.get wa i with + | Some q -> + Queue.push x q + | None -> + () + done + +let peek s = + if Queue.is_empty s.queue then + Lwt_mutex.with_lock s.mutex begin fun () -> + if Queue.is_empty s.queue then begin + lwt result = s.next () in + push_clones !(s.clones) result; + return result + end else + return (Queue.top s.queue) + end + else + return (Queue.top s.queue) + +let rec force n s = + if Queue.length s.queue >= n then + return () + else + Lwt_mutex.with_lock s.mutex begin fun () -> + if Queue.length s.queue >= n then + return false + else begin + lwt result = s.next () in + push_clones !(s.clones) result; + if result = None then + return false + else + return true + end + end >>= function + | true -> + force n s + | false -> + return () + +let npeek n s = + lwt () = force n s in + let l, _ = + Queue.fold + (fun (l, n) x -> + if n > 0 then + match x with + | Some x -> (x :: l, n - 1) + | None -> (l, n) + else + (l, n)) + ([], n) s.queue + in + return (List.rev l) + +let rec get s = + if Queue.is_empty s.queue then + Lwt_mutex.with_lock s.mutex begin fun () -> + if Queue.is_empty s.queue then begin + lwt x = s.next () in + (* This prevent from calling s.next when the stream has + terminated: *) + if x = None then Queue.push None s.queue; + let wa = !(s.clones) in + for i = 0 to Weak.length wa - 1 do + match Weak.get wa i with + | Some q when q != s.queue -> + Queue.push x q + | _ -> + () + done; + return x + end else begin + let x = Queue.take s.queue in + if x = None then Queue.push None s.queue; + return x + end + end + else begin + let x = Queue.take s.queue in + if x = None then Queue.push None s.queue; + return x + end + +let nget n s = + let rec loop n = + if n <= 0 then + return [] + else + get s >>= function + | Some x -> + lwt l = loop (n - 1) in + return (x :: l) + | None -> + return [] + in + loop n + +let get_while f s = + let rec loop () = + peek s >>= function + | Some x -> + let test = f x in + if test then begin + ignore (Queue.take s.queue); + lwt l = loop () in + return (x :: l) + end else + return [] + | None -> + return [] + in + loop () + +let get_while_s f s = + let rec loop () = + peek s >>= function + | Some x -> + lwt test = f x in + if test then begin + ignore (Queue.take s.queue); + lwt l = loop () in + return (x :: l) + end else + return [] + | None -> + return [] + in + loop () + +let next s = get s >>= function + | Some x -> return x + | None -> raise_lwt Empty + +let last_new s = + match Lwt.state (peek s) with + | Return None -> + raise_lwt Empty + | Sleep -> + next s + | Fail exn -> + raise_lwt exn + | Return(Some x) -> + let _ = Queue.take s.queue in + let rec loop last = + match Lwt.state (peek s) with + | Sleep | Return None -> + return last + | Return(Some x) -> + let _ = Queue.take s.queue in + loop x + | Fail exn -> + raise_lwt exn + in + loop x + +let to_list s = + let rec loop () = + get s >>= function + | Some x -> + lwt l = loop () in + return (x :: l) + | None -> + return [] + in + loop () + +let to_string s = + let buf = Buffer.create 42 in + let rec loop () = + get s >>= function + | Some x -> + Buffer.add_char buf x; + loop () + | None -> + return (Buffer.contents buf) + in + loop () + +let junk s = + lwt _ = get s in + return () + +let njunk n s = + let rec loop n = + if n <= 0 then + return () + else + lwt _ = get s in + loop (n - 1) + in + loop n + +let junk_while f s = + let rec loop () = + peek s >>= function + | Some x -> + let test = f x in + if test then begin + ignore (Queue.take s.queue); + loop () + end else + return () + | None -> + return () + in + loop () + +let junk_while_s f s = + let rec loop () = + peek s >>= function + | Some x -> + lwt test = f x in + if test then begin + ignore (Queue.take s.queue); + loop () + end else + return () + | None -> + return () + in + loop () + +let junk_old s = + let rec loop () = + match Lwt.state (peek s) with + | Sleep -> + return () + | _ -> + ignore (Queue.take s.queue); + loop () + in + loop () + +let get_available s = + let rec loop () = + match Lwt.state (peek s) with + | Sleep | Return None -> + [] + | Return(Some x) -> + ignore (Queue.take s.queue); + x :: loop () + | Fail exn -> + raise exn + in + loop () + +let get_available_up_to n s = + let rec loop = function + | 0 -> + [] + | n -> + match Lwt.state (peek s) with + | Sleep | Return None -> + [] + | Return(Some x) -> + ignore (Queue.take s.queue); + x :: loop (n - 1) + | Fail exn -> + raise exn + in + loop n + +let is_empty s = peek s >|= fun x -> x = None + +let map f s = + from (fun () -> get s >>= function + | Some x -> + let x = f x in + return (Some x) + | None -> + return None) + +let map_s f s = + from (fun () -> get s >>= function + | Some x -> + lwt x = f x in + return (Some x) + | None -> + return None) + +let filter f s = + let rec next () = + get s >>= function + | Some x as result -> + let test = f x in + if test then + return result + else + next () + | None -> + return None + in + from next + +let filter_s f s = + let rec next () = + get s >>= function + | Some x as result -> + lwt test = f x in + if test then + return result + else + next () + | None -> + return None + in + from next + +let filter_map f s = + let rec next () = + get s >>= function + | Some x -> + let x = f x in + (match x with + | Some _ -> + return x + | None -> + next ()) + | None -> + return None + in + from next + +let filter_map_s f s = + let rec next () = + get s >>= function + | Some x -> + lwt x = f x in + (match x with + | Some _ -> + return x + | None -> + next ()) + | None -> + return None + in + from next + +let map_list f s = + let pendings = ref [] in + let rec next () = + match !pendings with + | [] -> + get s >>= (function + | Some x -> + let l = f x in + pendings := l; + next () + | None -> + return None) + | x :: l -> + pendings := l; + return (Some x) + in + from next + +let map_list_s f s = + let pendings = ref [] in + let rec next () = + match !pendings with + | [] -> + get s >>= (function + | Some x -> + lwt l = f x in + pendings := l; + next () + | None -> + return None) + | x :: l -> + pendings := l; + return (Some x) + in + from next + +let flatten s = + map_list (fun l -> l) s + +let fold f s acc = + let rec loop acc = + get s >>= function + | Some x -> + let acc = f x acc in + loop acc + | None -> + return acc + in + loop acc + +let fold_s f s acc = + let rec loop acc = + get s >>= function + | Some x -> + lwt acc = f x acc in + loop acc + | None -> + return acc + in + loop acc + +let iter f s = + let rec loop () = + get s >>= function + | Some x -> + let () = f x in + loop () + | None -> + return () + in + loop () + +let iter_s f s = + let rec loop () = + get s >>= function + | Some x -> + lwt () = f x in + loop () + | None -> + return () + in + loop () + +let iter_p f s = + let rec loop () = + get s >>= function + | Some x -> + f x <&> loop () + | None -> + return () + in + loop () + +let find f s = + let rec loop () = + get s >>= function + | Some x as result -> + let test = f x in + if test then + return result + else + loop () + | None -> + return None + in + loop () + +let find_s f s = + let rec loop () = + get s >>= function + | Some x as result -> + lwt test = f x in + if test then + return result + else + loop () + | None -> + return None + in + loop () + +let rec find_map f s = + let rec loop () = + get s >>= function + | Some x -> + let x = f x in + (match x with + | Some _ -> + return x + | None -> + loop ()) + | None -> + return None + in + loop () + +let rec find_map_s f s = + let rec loop () = + get s >>= function + | Some x -> + lwt x = f x in + (match x with + | Some _ -> + return x + | None -> + loop ()) + | None -> + return None + in + loop () + +let rec combine s1 s2 = + let next () = + lwt n1 = get s1 and n2 = get s2 in + match n1, n2 with + | Some x1, Some x2 -> + return (Some(x1, x2)) + | _ -> + return None + in + from next + +let append s1 s2 = + let current_s = ref s1 and s1_finished = ref false in + let rec next () = + get !current_s >>= function + | Some _ as result -> + return result + | None -> + if !s1_finished then + return None + else begin + s1_finished := true; + current_s := s2; + next () + end + in + from next + +let concat s_top = + let current_s = ref(from(fun () -> return None)) in + let rec next () = + get !current_s >>= function + | Some _ as result -> + return result + | None -> + get s_top >>= function + | Some s -> + current_s := s; + next () + | None -> + return None + in + from next + +let choose streams = + let source s = (s, peek s >|= fun x -> (s, x)) in + let streams = ref (List.rev_map source streams) in + let rec next () = + match !streams with + | [] -> + return None + | l -> + lwt s, x = Lwt.choose (List.map snd l) in + let l = List.remove_assq s l in + match x with + | Some _ -> + lwt () = junk s in + streams := source s :: l; + return x + | None -> + next () + in + from next + +let parse s f = + let s' = clone s in + try_lwt + f s + with exn -> + Queue.clear s.queue; + Queue.transfer s'.queue s.queue; + raise_lwt exn + +let hexdump stream = + let buf = Buffer.create 80 and num = ref 0 in + from begin fun _ -> + nget 16 stream >>= function + | [] -> + return None + | l -> + Buffer.clear buf; + Printf.bprintf buf "%08x| " !num; + num := !num + 16; + let rec bytes pos = function + | [] -> + blanks pos + | x :: l -> + if pos = 8 then Buffer.add_char buf ' '; + Printf.bprintf buf "%02x " (Char.code x); + bytes (pos + 1) l + and blanks pos = + if pos < 16 then begin + if pos = 8 then + Buffer.add_string buf " " + else + Buffer.add_string buf " "; + blanks (pos + 1) + end + in + bytes 0 l; + Buffer.add_string buf " |"; + List.iter (fun ch -> Buffer.add_char buf (if ch >= '\x20' && ch <= '\x7e' then ch else '.')) l; + Buffer.add_char buf '|'; + return (Some(Buffer.contents buf)) + end diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_stream.mli b/thirdparty/lwt-2.3.2/src/core/lwt_stream.mli new file mode 100644 index 0000000..dfefbf4 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_stream.mli @@ -0,0 +1,242 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_stream + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Data streams *) + +type 'a t + (** Type of a stream holding values of type ['a] *) + +(** Naming convention: in this module all function taking a function + which is applied to all element of the streams are suffixed by: + + - [_s] when the function returns a thread and calls are serialised + - [_p] when the function returns a thread and calls are parallelised +*) + +(** {6 Construction} *) + +val from : (unit -> 'a option Lwt.t) -> 'a t + (** [from f] creates an stream from the given input function. [f] is + called each time more input is needed, and the stream ends when + [f] returns [None]. *) + +val create : unit -> 'a t * ('a option -> unit) + (** [create ()] returns a new stream and a push function *) + +val of_list : 'a list -> 'a t + (** [of_list l] creates a stream returning all elements of [l] *) + +val of_array : 'a array -> 'a t + (** [of_array a] creates a stream returning all elements of [a] *) + +val of_string : string -> char t + (** [of_string str] creates a stream returning all characters of + [str] *) + +val clone : 'a t -> 'a t + (** [clone st] clone the given stream. Operations on each stream + will not affect the other. + + For example: + + {[ + # let st1 = Lwt_stream.of_list [1; 2; 3];; + val st1 : int Lwt_stream.t = + # let st2 = Lwt_stream.clone st1;; + val st2 : int Lwt_stream.t = + # lwt x = Lwt_stream.next st1;; + val x : int = 1 + # lwt y = Lwt_stream.next st2;; + val y : int = 1 + ]} + *) + +(** {6 Destruction} *) + +val to_list : 'a t -> 'a list Lwt.t + (** Returns the list of elements of the given stream *) + +val to_string : char t -> string Lwt.t + (** Returns the word composed of all characters of the given + stream *) + +(** {6 Data retreival} *) + +exception Empty + (** Exception raised when trying to retreive data from an empty + stream. *) + +val peek : 'a t -> 'a option Lwt.t + (** [peek st] returns the first element of the stream, if any, + without removing it. *) + +val npeek : int -> 'a t -> 'a list Lwt.t + (** [npeek n st] returns at most the first [n] elements of [st], + without removing them. *) + +val get : 'a t -> 'a option Lwt.t + (** [get st] remove and returns the first element of the stream, if + any. *) + +val nget : int -> 'a t -> 'a list Lwt.t + (** [nget n st] remove and returns at most the first [n] elements of + [st]. *) + +val get_while : ('a -> bool) -> 'a t -> 'a list Lwt.t +val get_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a list Lwt.t + (** [get_while f st] returns the longest prefix of [st] where all + elements satisfy [f]. *) + +val next : 'a t -> 'a Lwt.t + (** [next st] remove and returns the next element of the stream, of + fail with {!Empty} if the stream is empty. *) + +val last_new : 'a t -> 'a Lwt.t + (** [next_new st] if no element are available on [st] without + sleeping, then it is the same as [next st]. Otherwise it removes + all elements of [st] that are ready except the last one, and + return it. + + If fails with {!Empty} if the stream has no more elements *) + +val junk : 'a t -> unit Lwt.t + (** [junk st] remove the first element of [st]. *) + +val njunk : int -> 'a t -> unit Lwt.t + (** [njunk n st] removes at most the first [n] elements of the + stream. *) + +val junk_while : ('a -> bool) -> 'a t -> unit Lwt.t +val junk_while_s : ('a -> bool Lwt.t) -> 'a t -> unit Lwt.t + (** [junk_while f st] removes all elements at the beginning of the + streams which satisfy [f]. *) + +val junk_old : 'a t -> unit Lwt.t + (** [junk_old st] removes all elements that are ready to be read + without yeilding from [st]. + + For example the [read_password] function of [Lwt_read_line] use + that to junk key previously typed by the user. + *) + +val get_available : 'a t -> 'a list + (** [get_available l] returns all available elements of [l] without + blocking *) + +val get_available_up_to : int -> 'a t -> 'a list + (** [get_available_up_to l n] returns up to [n] elements of [l] + without blocking *) + +val is_empty : 'a t -> bool Lwt.t + (** [is_empty enum] returns wether the given stream is empty *) + +(** {6 Stream transversal} *) + +(** Note: all the following functions are destructive. + + For example: + + {[ + # let st1 = Lwt_stream.of_list [1; 2; 3];; + val st1 : int Lwt_stream.t = + # let st2 = Lwt_stream.map string_of_int st1;; + val st2 : string Lwt_stream.t = + # lwt x = Lwt_stream.next st1;; + val x : int = 1 + # lwt y = Lwt_stream.next st2;; + val y : string = "2" + ]} +*) + +val choose : 'a t list -> 'a t + (** [choose l] creates an stream from a list of streams. The + resulting stream will returns elements returned by any stream of + [l] in an unspecified order. *) + +val map : ('a -> 'b) -> 'a t -> 'b t +val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t + (** [map f st] maps the value returned by [st] with [f] *) + +val filter : ('a -> bool) -> 'a t -> 'a t +val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t + (** [filter f st] keeps only value [x] such that [f x] is [true] *) + +val filter_map : ('a -> 'b option) -> 'a t -> 'b t +val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t + (** [filter_map f st] filter and map [st] at the same time *) + +val map_list : ('a -> 'b list) -> 'a t -> 'b t +val map_list_s : ('a -> 'b list Lwt.t) -> 'a t -> 'b t + (** [map_list f st] applies [f] on each element of [st] and flattens + the lists returned *) + +val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b Lwt.t +val fold_s : ('a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t + (** [fold f s x] fold_like function for streams. *) + +val iter : ('a -> unit) -> 'a t -> unit Lwt.t +val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t +val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t + (** [iter f s] iterates over all elements of the stream *) + +val find : ('a -> bool) -> 'a t -> 'a option Lwt.t +val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t + (** [find f s] find an element in a stream. *) + +val find_map : ('a -> 'b option) -> 'a t -> 'b option Lwt.t +val find_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b option Lwt.t + (** [find f s] find and map at the same time. *) + +val combine : 'a t -> 'b t -> ('a * 'b) t + (** [combine s1 s2] combine two streams. The stream will ends when + the first stream ends. *) + +val append : 'a t -> 'a t -> 'a t + (** [append s1 s2] returns a stream which returns all elements of + [s1], then all elements of [s2] *) + +val concat : 'a t t -> 'a t + (** [concat st] returns the concatenation of all streams of [st]. *) + +val flatten : 'a list t -> 'a t + (** [flatten st = map_list (fun l -> l) st] *) + +(** {6 Parsing} *) + +val parse : 'a t -> ('a t -> 'b Lwt.t) -> 'b Lwt.t + (** [parse st f] parses [st] with [f]. If [f] raise an exception, + [st] is restored to its previous state. *) + +(** {6 Misc} *) + +val hexdump : char t -> string t + (** [hexdump byte_stream] returns a stream which is the same as the + output of [hexdump -C]. + + Basically, here is a simple implementation of [hexdump -C]: + + {[ + open Lwt + open Lwt_io + let () = Lwt_main.run (write_lines stdout (Lwt_stream.hexdump (read_lines stdin))) + ]} + *) diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_switch.ml b/thirdparty/lwt-2.3.2/src/core/lwt_switch.ml new file mode 100644 index 0000000..150ed11 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_switch.ml @@ -0,0 +1,73 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_switch + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt + +exception Off + +type on_switch = { + mutable hooks : (unit -> unit Lwt.t) list; +} + +type state = + | St_on of on_switch + | St_off + +type t = { mutable state : state } + +let create () = { state = St_on { hooks = [] } } + +let is_on switch = + match switch.state with + | St_on _ -> true + | St_off -> false + +let check = function + | Some{ state = St_off } -> raise Off + | _ -> () + +let add_hook switch hook = + match switch with + | Some{ state = St_on os } -> + os.hooks <- hook :: os.hooks + | Some{ state = St_off } -> + raise Off + | None -> + () + +let add_hook_or_exec switch hook = + match switch with + | Some{ state = St_on os } -> + os.hooks <- hook :: os.hooks; + return () + | Some{ state = St_off } -> + hook () + | None -> + return () + +let turn_off switch = + match switch.state with + | St_on { hooks = hooks } -> + switch.state <- St_off; + Lwt_list.iter_p (fun hook -> apply hook ()) hooks + | St_off -> + return () diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_switch.mli b/thirdparty/lwt-2.3.2/src/core/lwt_switch.mli new file mode 100644 index 0000000..8a8431c --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_switch.mli @@ -0,0 +1,111 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_switch + * Copyright (C) 2010 Jérémiem Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Lwt switches *) + +(** Switch have two goals: + + - being able to free multiple resources at the same time, + - offer a better alternative than always returning an id to free + some resource. + + For example, considers the following interface: + + {[ + type id + + val free : id -> unit Lwt.t + + val f : unit -> id Lwt.t + val g : unit -> id Lwt.t + val h : unit -> id Lwt.t + ]} + + Now you want to calls [f], [g] and [h] in parallel. You can + simply do: + + {[ + lwt idf = f () and idg = g () and idh = h () in + ... + ]} + + However, one may wants to handle possible failures of [f ()], [g + ()] and [h ()], and disable all allocated resources if one of + these three threads fails. This may be hard since you have to + remember which one failed and which one returned correctly. + + Now we change a little bit the interface: + + {[ + val f : ?switch : Lwt_switch.t -> unit -> id Lwt.t + val g : ?switch : Lwt_switch.t -> unit -> id Lwt.t + val h : ?switch : Lwt_switch.t -> unit -> id Lwt.t + ]} + + and the code becomes: + + {[ + let switch = Lwt_switch.create () in + try_lwt + lwt idf = f ~switch () and idg = g ~switch () and idh = h ~switch () in + ... + with exn -> + lwt () = Lwt_switch.turn_off switch in + raise_lwt exn + ]} +*) + +type t + (** Type of switches. *) + +val create : unit -> t + (** [create ()] creates a new switch. *) + +val is_on : t -> bool + (** [is_on switch] returns [true] if the switch is currently on, and + [false] otherwise. *) + +val turn_off : t -> unit Lwt.t + (** [turn_off switch] turns off the switch. It calls all registered + hooks, waits for all of them to terminates, and the returns. If + one of the hook failed, then it will fail with one of the + exception raised by hooks. If the switch is already off, then it + does nothing. *) + +exception Off + (** Exception raised when trying to add a hook to a switch that is + already off. *) + +val check : t option -> unit + (** [check switch] does nothing if [switch] is [None] or contains an + switch that is currently on, and raise {!Off} otherwise. *) + +val add_hook : t option -> (unit -> unit Lwt.t) -> unit + (** [add_hook switch f] registers [f] so it will be called when + {!turn_off} is invoked. It does nothing if [switch] is + [None]. If [switch] contains an switch that is already off then + {!Off} is raised. *) + +val add_hook_or_exec : t option -> (unit -> unit Lwt.t) -> unit Lwt.t + (** [add_hook_or_exec switch f] is the same as {!add_hook} except + that if the switch is already off, then [f] is called + immediatly. *) diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_util.ml b/thirdparty/lwt-2.3.2/src/core/lwt_util.ml new file mode 100644 index 0000000..5669755 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_util.ml @@ -0,0 +1,117 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_util + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt + +let rec iter f l = + let l = List.fold_left (fun acc a -> f a :: acc) [] l in + let l = List.rev l in + List.fold_left (fun rt t -> t >>= fun () -> rt) (Lwt.return ()) l + +let rec iter_serial f l = + match l with + [] -> return () + | a :: r -> f a >>= (fun () -> iter_serial f r) + +let rec map f l = + match l with + [] -> + return [] + | v :: r -> + let t = f v in + let rt = map f r in + t >>= (fun v' -> + rt >>= (fun l' -> + return (v' :: l'))) + +let map_with_waiting_action f wa l = + let rec loop l = + match l with + [] -> + return [] + | v :: r -> + let t = f v in + let rt = loop r in + t >>= (fun v' -> + (* Perform the specified "waiting action" for the next *) + (* item in the list. *) + if r <> [] then + wa (List.hd r) + else + (); + rt >>= (fun l' -> + return (v' :: l'))) + in + if l <> [] then + wa (List.hd l) + else + (); + loop l + +let rec map_serial f l = + match l with + [] -> + return [] + | v :: r -> + f v >>= (fun v' -> + map_serial f r >>= (fun l' -> + return (v' :: l'))) + +let rec fold_left f a = function + | [] -> return a + | b::l -> f a b >>= fun v -> fold_left f v l + +let join = Lwt.join + +type region = + { mutable size : int; + mutable count : int; + waiters : (unit Lwt.u * int) Queue.t } + +let make_region count = { size = count; count = 0; waiters = Queue.create () } + +let resize_region reg sz = reg.size <- sz + +let leave_region reg sz = + try + if reg.count - sz >= reg.size then raise Queue.Empty; + let (w, sz') = Queue.take reg.waiters in + reg.count <- reg.count - sz + sz'; + Lwt.wakeup_later w () + with Queue.Empty -> + reg.count <- reg.count - sz + +let run_in_region_1 reg sz thr = + (catch + (fun () -> thr () >>= (fun v -> leave_region reg sz; return v)) + (fun e -> leave_region reg sz; raise_lwt e)) + +let run_in_region reg sz thr = + if reg.count >= reg.size then begin + let (res, w) = wait () in + Queue.add (w, sz) reg.waiters; + res >>= (fun () -> run_in_region_1 reg sz thr) + end else begin + reg.count <- reg.count + sz; + run_in_region_1 reg sz thr + end diff --git a/thirdparty/lwt-2.3.2/src/core/lwt_util.mli b/thirdparty/lwt-2.3.2/src/core/lwt_util.mli new file mode 100644 index 0000000..e296a4c --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/core/lwt_util.mli @@ -0,0 +1,80 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_util + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Note: This lodule is deprecated. Use {!Lwt_list} and {!Lwt_pool} + instead. *) + +(** {2 Lists iterators} *) + +val iter : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + (** [iter f l] start a thread for each element in [l]. The threads + are started according to the list order, but then can run + concurrently. It terminates when all the threads are + terminated, if all threads are successful. It fails if any of + the threads fail. *) + +val iter_serial : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + (** Similar to [iter] but wait for one thread to terminate before + starting the next one. *) + +val map : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + (** [map f l] apply [f] to each element in [l] and collect the + results of the threads thus created. The threads are started + according to the list order, but then can run concurrently. + [map f l] fails if any of the threads fail. *) + +val map_with_waiting_action : + ('a -> 'b Lwt.t) -> ('a -> unit) -> 'a list -> 'b list Lwt.t + (** [map_with_waiting_action f wa l] apply [f] to each element + in [l] and collect the results of the threads thus created. + The threads are started according to the list order, but + then can run concurrently. The difference with [map f l] is + that function wa will be called on the element that the + function is waiting for its termination. *) + +val map_serial : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + (** Similar to [map] but wait for one thread to terminate before + starting the next one. *) + +val fold_left : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t + (** Similar to [List.fold_left]. *) + +(****) + +(** {2 Regions} *) + +type region + +val make_region : int -> region + (** [make_region sz] create a region of size [sz]. *) +val resize_region : region -> int -> unit + (** [resize_region reg sz] resize the region [reg] to size [sz]. *) +val run_in_region : region -> int -> (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [run_in_region reg size f] execute the thread produced by the + function [f] in the region [reg]. The thread is not started + before some room is available in the region. *) + +(**/**) + +val join : unit Lwt.t list -> unit Lwt.t + (** Same as [Lwt.join] *) diff --git a/thirdparty/lwt-2.3.2/src/extra/lwt-extra.mllib b/thirdparty/lwt-2.3.2/src/extra/lwt-extra.mllib new file mode 100644 index 0000000..8171343 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/extra/lwt-extra.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 73d5d5d814da6fce812bc449a2dcd20c) +Lwt_lib +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/extra/lwt_lib.ml b/thirdparty/lwt-2.3.2/src/extra/lwt_lib.ml new file mode 100644 index 0000000..ae30526 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/extra/lwt_lib.ml @@ -0,0 +1,134 @@ +(* Ocsigen + * http://www.ocsigen.org + * lwt_lib.ml Copyright (C) 2007 Pierre Clairambault + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later version. + * See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Weak +open Unix +open Lwt + +let switch_time = 30. + +exception Not_in_table +(* We use a specific Not_in_table exception, because since we're caching + * threads, we can't for the moment behave differently whether a request + * is not found in the table or not found as a host.*) + + +module WeakHashtbl = Make( + struct + type t = string * (Unix.host_entry Lwt.t) * float + let equal = (fun (a,b,c) -> fun (a',b',c') -> a=a') + let hash = fun (a,b,c) -> Hashtbl.hash a + end +) + +open WeakHashtbl + +let keeper : (((string*(Unix.host_entry Lwt.t)*float) list) * + ((string*(Unix.host_entry Lwt.t)*float) list)) ref = ref ([],[]) +let cache = create 0 +let dummy_addr : Unix.host_entry = + {h_name="dummy"; + h_aliases=[||]; + h_addrtype=Unix.PF_INET; + h_addr_list = [||]} + +let cache_find d = try + match (find cache (d,return dummy_addr,0.)) with (_,h,t) -> (h,t) + with + |Not_found -> raise Not_in_table + |e -> raise e + +let gethostbyname d = + Lwt.catch + (fun _ -> + let (h,t) = cache_find d + and t' = Unix.time () in + match (t'>t+.60.) with + | true -> + (remove cache) (d,h,t); + raise_lwt Not_in_table + | false -> h) + (function + | Not_in_table -> + let t = Unix.time() and + h = Lwt_preemptive.detach Unix.gethostbyname d in + let entry = (d,h,t) in + add cache entry; + (match !keeper with (a,b) -> keeper:= (entry::a,b)); + h + | e -> raise_lwt e) +(* Begin getaddrinfo caching *) + + +module WeakAddrInfo = Make( + struct + type t = string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float + let equal = (fun (h,s,o,i,t) -> fun (h',s',o',i',t') -> (h,s,o)=(h',s',o')) + let hash = fun (h,s,o,i,t) -> Hashtbl.hash (h,s,o) + end +) + +let keeper6 : (((string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float) list) * + ((string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float) list)) ref = ref + ([],[]) + +let switch_thread : unit Lwt.t= + let rec switch_worker () = + Lwt_unix.sleep switch_time >>= fun () -> + (match !keeper with (a,b) -> keeper:=([],a)); + (match !keeper6 with (a,b) -> keeper6:=([],a)); + switch_worker () + in + switch_worker() + +let cache6 = WeakAddrInfo.create 0 + +let cache_find6 d s o = try + match (WeakAddrInfo.find cache6 (d,s,o,return [],0.)) with (_,_,_,i,t) -> (i,t) + with + |Not_found -> raise Not_in_table + |e -> raise e + + +let getaddrinfo d s o = + Lwt.catch + (fun _ -> + let (i,t) = cache_find6 d s o + and t' = Unix.time() in + match (t'>t+.60.) with + | true -> + WeakAddrInfo.remove cache6 (d,s,o,i,t); + raise_lwt Not_in_table + | false -> i) + (function + | Not_in_table -> + let t = Unix.time () and + i = Lwt_preemptive.detach (Unix.getaddrinfo d s) o in + let entry = (d,s,o,i,t) in + WeakAddrInfo.add cache6 entry; + (match !keeper6 with (a,b) -> keeper6 := (entry::a,b)); + i + | e -> raise_lwt e) + + +let getnameinfo s l = + (*VVV implmenter !!! *) + Lwt_preemptive.detach (Unix.getnameinfo s) l diff --git a/thirdparty/lwt-2.3.2/src/extra/lwt_lib.mli b/thirdparty/lwt-2.3.2/src/extra/lwt_lib.mli new file mode 100644 index 0000000..7f48007 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/extra/lwt_lib.mli @@ -0,0 +1,44 @@ +(* Ocsigen + * http://www.ocsigen.org + * lwt_lib.mli Copyright (C) 2007 Pierre Clairambault + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later version. + * See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(** Cooperative unix system calls *) + +(** This module transform non-cooperative functions of the standard + library into cooperative ones by launching them into system + threads. + + Indeed, lots of functions of the [Unix] modules, corresponding to + functions of the standard C library may take times to + complete. For example [gethostbyname] may use DNS resolution, + users informations may be stored in a ldap database, ... + + Since these functions are implemented (in the standard C library) + using blocking IOs, if you use them directly, you program may + hang. *) + +val getaddrinfo : string -> string -> Unix.getaddrinfo_option list -> Unix.addr_info list Lwt.t + (** Cooperative getaddrinfo with cache (using Lwt_preemptive.detach) *) + +val gethostbyname : string -> Unix.host_entry Lwt.t + (** Cooperative gethostbyname with cache (using Lwt_preemptive.detach) *) + +val getnameinfo : Unix.sockaddr -> Unix.getnameinfo_option list -> Unix.name_info Lwt.t + (** Cooperative getnameinfo with cache (using Lwt_preemptive.detach) *) diff --git a/thirdparty/lwt-2.3.2/src/glib/liblwt-glib.clib b/thirdparty/lwt-2.3.2/src/glib/liblwt-glib.clib new file mode 100644 index 0000000..d26011b --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/glib/liblwt-glib.clib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 905c14a6abfdc3cc49bbc233df66ff99) +lwt_glib_stubs.o +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/glib/lwt-glib.mllib b/thirdparty/lwt-2.3.2/src/glib/lwt-glib.mllib new file mode 100644 index 0000000..f99b29f --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/glib/lwt-glib.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: dfe8b7bfa132aa66ad19dbdbf3bcbaaa) +Lwt_glib +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/glib/lwt_glib.ml b/thirdparty/lwt-2.3.2/src/glib/lwt_glib.ml new file mode 100644 index 0000000..0196e29 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/glib/lwt_glib.ml @@ -0,0 +1,132 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module glib + * Copyright (C) 2009-2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +type source = { + fd : Unix.file_descr; + check_readable : bool; + check_writable : bool; +} + +external glib_init : unit -> unit = "lwt_glib_init" +external glib_stop : unit -> unit = "lwt_glib_stop" + +type state = + | State_none + | State_glib_into_lwt of (unit -> unit) Lwt_sequence.node * (unit -> unit) Lwt_sequence.node + | State_lwt_into_glib of Lwt_engine.t + +let state = ref State_none + +(* +-----------------------------------------------------------------+ + | Glib-based engine | + +-----------------------------------------------------------------+ *) + +external glib_poll : (Unix.file_descr * bool * bool) list -> int -> int -> (Unix.file_descr * bool * bool) list = "lwt_glib_poll" + +class engine = object + inherit Lwt_engine.poll_based + method private poll fds timeout = glib_poll fds (List.length fds) (truncate (timeout *. 1000.)) +end + +(* +-----------------------------------------------------------------+ + | Glib --> Lwt based integration | + +-----------------------------------------------------------------+ *) + +external glib_get_sources : unit -> source array * float = "lwt_glib_get_sources" +external glib_check : unit -> unit = "lwt_glib_check" +external glib_mark_readable : int -> unit = "lwt_glib_mark_readable" "noalloc" +external glib_mark_writable : int -> unit = "lwt_glib_mark_readable" "noalloc" + +let events = ref [] +let check = ref true + +let enter () = + if !check then begin + check := false; + let engine = Lwt_engine.get () in + assert (!events = []); + let sources, timeout = glib_get_sources () in + for i = 0 to Array.length sources - 1 do + let src = sources.(i) in + if src.check_readable then + events := engine#on_readable src.fd (fun _ -> glib_mark_readable i) :: !events; + if src.check_writable then + events := engine#on_writable src.fd (fun _ -> glib_mark_writable i) :: !events + done; + if timeout = 0. then + ignore (Lwt_main.yield ()) + else if timeout > 0. then + events := engine#on_timer timeout false ignore :: !events + end + +let leave () = + if not !check then begin + check := true; + List.iter Lwt_engine.stop_event !events; + events := []; + glib_check () + end + +(* +-----------------------------------------------------------------+ + | Installation/removal | + +-----------------------------------------------------------------+ *) + +let install ?mode () = + match !state with + | State_lwt_into_glib _ | State_glib_into_lwt _ -> + () + | State_none -> + let mode = + match mode with + | Some mode -> mode + | None -> if Lwt_sys.windows then `lwt_into_glib else `glib_into_lwt + in + glib_init (); + match mode with + | `glib_into_lwt -> + state := State_glib_into_lwt(Lwt_sequence.add_l enter Lwt_main.enter_iter_hooks, + Lwt_sequence.add_l leave Lwt_main.leave_iter_hooks) + | `lwt_into_glib -> + let engine = Lwt_engine.get () in + Lwt_engine.set ~destroy:false (new engine); + state := State_lwt_into_glib engine + +let remove () = + match !state with + | State_none -> + () + | State_glib_into_lwt(node_enter, node_leave) -> + state := State_none; + Lwt_sequence.remove node_enter; + Lwt_sequence.remove node_leave; + List.iter Lwt_engine.stop_event !events; + events := []; + glib_stop () + | State_lwt_into_glib engine -> + Lwt_engine.set engine + +(* +-----------------------------------------------------------------+ + | Misc | + +-----------------------------------------------------------------+ *) + +external iter : bool -> unit = "lwt_glib_iter" +external wakeup : unit -> unit = "lwt_glib_wakeup" diff --git a/thirdparty/lwt-2.3.2/src/glib/lwt_glib.mli b/thirdparty/lwt-2.3.2/src/glib/lwt_glib.mli new file mode 100644 index 0000000..5d97b09 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/glib/lwt_glib.mli @@ -0,0 +1,103 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_glib + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Glib integration *) + +(** This module allow to use Lwt in GTK applications. + + Here is what you have to do to make Lwt and GTK work together: + - call {!install} at the beginning of your program (before or + after GMain.init, it does not matter) + - do not call GMain.main, write your application as a normal Lwt + application instead. + + For example: + + {[ + let () = Lwt_main.run ( + (* Initializes GTK. *) + ignore (GMain.init ()); + + (* Install Lwt<->Glib integration. *) + Lwt_glib.install (); + + (* Thread which is wakeup when the main window is closed. *) + let waiter, wakener = Lwt.wait () in + + (* Create a window. *) + let window = GWindow.window () in + + (* Display something inside the window. *) + ignore (GMisc.label ~text:"Hello, world!" ~packing:window#add ()); + + (* Quit when the window is closed. *) + ignore (window#connect#destroy (Lwt.wakeup wakener)); + + (* Show the window. *) + window#show (); + + (* Wait for it to be closed. *) + waiter + ) + ]} + *) + +val install : ?mode : [ `glib_into_lwt | `lwt_into_glib ] -> unit -> unit + (** Install the Glib<->Lwt integration. + + If [mode] is [`glib_into_lwt] then glib will use the Lwt main + loop, and if [mode] is [`lwt_into_glib] then Lwt will use the + Glib main loop. + + The first mode is better but for some unknown reason it does not + work under Windows, so the second is used as default on Windows + while the first one is used as default on Unix. + + If the integration is already active, this function does + nothing. *) + +val remove : unit -> unit + (** Remove the Glib<->Lwt integration. *) + +val iter : bool -> unit + (** This function is not related to Lwt. [iter may_block] does the + same as [Glib.Main.iteration may_block] but can safely be called + in a multi-threaded program, it will not block the whole + program. + + For example: + + {[ + let main () = + while true do + Lwt_glib.iter true + done + + let thread = Thread.create main () + ]} + + Note: you can call this function only from one thread at a time, + otherwise it will raise [Failure]. *) + +val wakeup : unit -> unit + (** If one thread is blocking on {!iter}, then [wakeup ()] make + {!iter} to return immediatly. *) diff --git a/thirdparty/lwt-2.3.2/src/glib/lwt_glib_stubs.c b/thirdparty/lwt-2.3.2/src/glib/lwt_glib_stubs.c new file mode 100644 index 0000000..d6318cb --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/glib/lwt_glib_stubs.c @@ -0,0 +1,275 @@ +/* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_glib_stubs + * Copyright (C) 2009-2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + */ + +#include +#include +#include +#include +#include +#include +#include +#include + +#include "../unix/lwt_unix.h" + +GMainContext *gc; +GPollFD *gpollfds = NULL; +gint fds_count = 0; +gint n_fds; +gint max_priority; + +/* +-----------------------------------------------------------------+ + | Polling | + +-----------------------------------------------------------------+ */ + +CAMLprim value lwt_glib_poll(value val_fds, value val_count, value val_timeout) +{ + gint timeout, lwt_timeout; + long count; + int i; + GPollFD *gpollfd; + gint events, revents; + + CAMLparam3(val_fds, val_count, val_timeout); + CAMLlocal5(node, src, node_result, src_result, tmp); + + count = Long_val(val_count); + + g_main_context_dispatch(gc); + g_main_context_prepare(gc, &max_priority); + + while (fds_count < count + (n_fds = g_main_context_query(gc, max_priority, &timeout, gpollfds, fds_count))) { + free(gpollfds); + fds_count = n_fds + count; + gpollfds = lwt_unix_malloc(fds_count * sizeof (GPollFD)); + } + + /* Clear all revents fields. */ + for (i = 0; i < n_fds + count; i++) gpollfds[i].revents = 0; + + /* Add all Lwt fds. */ + for (i = n_fds, node = val_fds; i < n_fds + count; i++, node = Field(node, 1)) { + src = Field(node, 0); + gpollfd = gpollfds + i; +#if defined(LWT_ON_WINDOWS) + gpollfd->fd = Handle_val(Field(src, 0)); +#else + gpollfd->fd = Int_val(Field(src, 0)); +#endif + events = 0; + if (Bool_val(Field(src, 1))) events |= G_IO_IN; + if (Bool_val(Field(src, 2))) events |= G_IO_OUT; + gpollfd->events = events; + } + + lwt_timeout = Int_val(val_timeout); + if (timeout < 0 || (lwt_timeout >= 0 && lwt_timeout < timeout)) + timeout = lwt_timeout; + + /* Do the blocking call. */ + g_main_context_get_poll_func(gc)(gpollfds, n_fds + count, timeout); + g_main_context_check(gc, max_priority, gpollfds, n_fds); + + /* Build the result. */ + node_result = Val_int(0); + for (i = n_fds, node = val_fds; i < n_fds + count; i++, node = Field(node, 1)) { + src_result = caml_alloc_tuple(3); + src = Field(node, 0); + Field(src_result, 0) = Field(src, 0); + revents = gpollfds[i].revents; + Field(src_result, 1) = Val_bool(revents & G_IO_IN); + Field(src_result, 2) = Val_bool(revents & G_IO_OUT); + tmp = caml_alloc_tuple(2); + Field(tmp, 0) = src_result; + Field(tmp, 1) = node_result; + node_result = tmp; + } + + CAMLreturn(node_result); +} + +/* +-----------------------------------------------------------------+ + | Get sources | + +-----------------------------------------------------------------+ */ + +#if defined(LWT_ON_WINDOWS) + +static value alloc_fd(HANDLE handle) +{ + value res = win_alloc_handle(handle); + int opt; + int optlen = sizeof(opt); + if (getsockopt((SOCKET)handle, SOL_SOCKET, SO_TYPE, (char *)&opt, &optlen) == 0) + Descr_kind_val(res) = KIND_SOCKET; + return res; +} + +#endif + +CAMLprim value lwt_glib_get_sources() +{ + gint timeout; + int i; + GPollFD *gpollfd; + + CAMLparam0(); + CAMLlocal4(fd, fds, src, result); + + g_main_context_dispatch(gc); + g_main_context_prepare(gc, &max_priority); + + while (fds_count < (n_fds = g_main_context_query(gc, max_priority, &timeout, gpollfds, fds_count))) { + free(gpollfds); + fds_count = n_fds; + gpollfds = lwt_unix_malloc(fds_count * sizeof (GPollFD)); + } + + fds = caml_alloc_tuple(n_fds); + for (i = 0; i < n_fds; i++) { + gpollfd = gpollfds + i; + gpollfd->revents = 0; + +#if defined(LWT_ON_WINDOWS) + /* On windows, glib file descriptors are handles */ + fd = alloc_fd((HANDLE)gpollfd->fd); +#else + fd = Val_int(gpollfd->fd); +#endif + + src = caml_alloc_tuple(3); + Field(src, 0) = fd; + Field(src, 1) = Val_bool(gpollfd->events & G_IO_IN); + Field(src, 2) = Val_bool(gpollfd->events & G_IO_OUT); + + Field(fds, i) = src; + } + + result = caml_alloc_tuple(2); + Store_field(result, 0, fds); + Store_field(result, 1, caml_copy_double(timeout * 1e-3)); + + CAMLreturn(result); +} + +/* +-----------------------------------------------------------------+ + | Marking | + +-----------------------------------------------------------------+ */ + +CAMLprim value lwt_glib_mark_readable(value i) +{ + gpollfds[Int_val(i)].revents |= G_IO_IN; + return Val_unit; +} + +CAMLprim value lwt_glib_mark_writable(value i) +{ + gpollfds[Int_val(i)].revents |= G_IO_OUT; + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | Check | + +-----------------------------------------------------------------+ */ + +CAMLprim value lwt_glib_check() +{ + g_main_context_check(gc, max_priority, gpollfds, n_fds); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | Initialization/stopping | + +-----------------------------------------------------------------+ */ + +CAMLprim value lwt_glib_init() +{ + gc = g_main_context_default(); + g_main_context_ref(gc); + return Val_unit; +} + +CAMLprim value lwt_glib_stop() +{ + g_main_context_unref(gc); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | Misc | + +-----------------------------------------------------------------+ */ + +CAMLprim value lwt_glib_iter(value may_block) +{ + GMainContext *gc; + gint max_priority, timeout; + GPollFD *pollfds = NULL; + gint pollfds_size = 0; + gint nfds; + gint i; + + /* Get the main context. */ + gc = g_main_context_default(); + + /* Try to acquire it. */ + if (!g_main_context_acquire(gc)) + caml_failwith("Lwt_glib.iter"); + + /* Dispatch pending events. */ + g_main_context_dispatch(gc); + + /* Prepare the context for polling. */ + g_main_context_prepare(gc, &max_priority); + + /* Get all file descriptors to poll. */ + while (pollfds_size < (nfds = g_main_context_query(gc, max_priority, &timeout, pollfds, pollfds_size))) { + free(pollfds); + pollfds_size = nfds; + pollfds = lwt_unix_malloc(pollfds_size * sizeof (GPollFD)); + } + + /* Clear all revents fields. */ + for (i = 0; i < nfds; i++) pollfds[i].revents = 0; + + /* Set the timeout to 0 if we do not want to block. */ + if (!Bool_val(may_block)) timeout = 0; + + /* Do the blocking call. */ + caml_enter_blocking_section(); + g_main_context_get_poll_func(gc)(pollfds, nfds, timeout); + caml_leave_blocking_section(); + + /* Let glib parse the result. */ + g_main_context_check(gc, max_priority, pollfds, nfds); + + /* Release the context. */ + g_main_context_release(gc); + + free(pollfds); + + return Val_unit; +} + +CAMLprim value lwt_glib_wakeup() +{ + g_main_context_wakeup(g_main_context_default()); + return Val_unit; +} diff --git a/thirdparty/lwt-2.3.2/src/preemptive/lwt-preemptive.mllib b/thirdparty/lwt-2.3.2/src/preemptive/lwt-preemptive.mllib new file mode 100644 index 0000000..25230f1 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/preemptive/lwt-preemptive.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 7a98b43f4d640061bceed7638c0c7efd) +Lwt_preemptive +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.ml b/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.ml new file mode 100644 index 0000000..8d25623 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.ml @@ -0,0 +1,195 @@ +(* Ocsigen + * http://www.ocsigen.org + * Module lwt_preemptive.ml + * Copyright (C) 2005 Nataliya Guts, Vincent Balat, Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * 2009 Jrmie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later version. + * See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +let section = Lwt_log.Section.make "lwt(preemptive)" + +open Lwt +open Lwt_io + +(* +-----------------------------------------------------------------+ + | Parameters | + +-----------------------------------------------------------------+ *) + +(* Minimum number of preemptive threads: *) +let min_threads : int ref = ref 0 + +(* Maximum number of preemptive threads: *) +let max_threads : int ref = ref 0 + +(* Size of the waiting queue: *) +let max_thread_queued = ref 1000 + +let get_max_number_of_threads_queued _ = + !max_thread_queued + +let set_max_number_of_threads_queued n = + if n < 0 then invalid_arg "Lwt_preemptive.set_max_number_of_threads_queued"; + max_thread_queued := n + +(* The function for logging errors: *) +let error_log = ref (fun msg -> ignore (Lwt_log.error ~section msg)) + +(* The total number of preemptive threads currently running: *) +let threads_count = ref 0 + +(* +-----------------------------------------------------------------+ + | Preemptive threads management | + +-----------------------------------------------------------------+ *) + +type thread = { + task_channel: (int * (unit -> unit)) Event.channel; + (* Channel used to communicate notification id and tasks to the + worker thread. *) + + mutable thread : Thread.t; + (* The worker thread. *) + + mutable reuse : bool; + (* Whether the thread must be readded to the pool when the work is + done. *) +} + +(* Pool of worker threads: *) +let workers : thread Queue.t = Queue.create () + +(* Queue of clients waiting for a worker to be available: *) +let waiters : thread Lwt.u Lwt_sequence.t = Lwt_sequence.create () + +(* Code executed by a worker: *) +let rec worker_loop worker = + let id, task = Event.sync (Event.receive worker.task_channel) in + task (); + (* If there is too much threads, exit. This can happen if the user + decreased the maximum: *) + if !threads_count > !max_threads then worker.reuse <- false; + (* Tell the main thread that work is done: *) + Lwt_unix.send_notification id; + if worker.reuse then worker_loop worker + +(* create a new worker: *) +let make_worker _ = + incr threads_count; + let worker = { + task_channel = Event.new_channel (); + thread = Thread.self (); + reuse = true; + } in + worker.thread <- Thread.create worker_loop worker; + worker + +(* Add a worker to the pool: *) +let add_worker worker = + match Lwt_sequence.take_opt_l waiters with + | None -> + Queue.add worker workers + | Some w -> + wakeup w worker + +(* Wait for worker to be available, then return it: *) +let rec get_worker _ = + if not (Queue.is_empty workers) then + return (Queue.take workers) + else if !threads_count < !max_threads then + return (make_worker ()) + else begin + let (res, w) = Lwt.task () in + let node = Lwt_sequence.add_r w waiters in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + res + end + +(* +-----------------------------------------------------------------+ + | Initialisation, and dynamic parameters reset | + +-----------------------------------------------------------------+ *) + +let get_bounds _ = (!min_threads, !max_threads) + +let set_bounds (min, max) = + if min < 0 || max < min then invalid_arg "Lwt_preemptive.set_bounds"; + let diff = min - !threads_count in + min_threads := min; + max_threads := max; + (* Launch new workers: *) + for i = 1 to diff do + add_worker (make_worker ()) + done + +let initialized = ref false + +let init min max errlog = + initialized := true; + error_log := errlog; + set_bounds (min, max) + +let simple_init _ = + if not !initialized then begin + initialized := true; + set_bounds (0, 4) + end + +let nbthreads _ = !threads_count +let nbthreadsqueued _ = Lwt_sequence.fold_l (fun _ x -> x + 1) waiters 0 +let nbthreadsbusy _ = !threads_count - Queue.length workers + +(* +-----------------------------------------------------------------+ + | Detaching | + +-----------------------------------------------------------------+ *) + +let detach f args = + simple_init (); + let result = ref `Nothing in + (* The task for the worker thread: *) + let task () = + try + result := `Success(f args) + with exn -> + result := `Failure exn + in + lwt worker = get_worker () in + let waiter, wakener = wait () in + let id = + Lwt_unix.make_notification ~once:true + (fun () -> + match !result with + | `Nothing -> + wakeup_exn wakener (Failure "Lwt_preemptive.detach") + | `Success value -> + wakeup wakener value + | `Failure exn -> + wakeup_exn wakener exn) + in + try_lwt + (* Send the id and the task to the worker: *) + Event.sync (Event.send worker.task_channel (id, task)); + waiter + finally + if worker.reuse then + (* Put back the worker to the pool: *) + add_worker worker + else begin + decr threads_count; + (* Or wait for the thread to terminates, to free its associated + resources: *) + Thread.join worker.thread + end; + return () diff --git a/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.mli b/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.mli new file mode 100644 index 0000000..625d4fb --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.mli @@ -0,0 +1,70 @@ +(* Ocsigen + * http://www.ocsigen.org + * Module lwt_preemptive.ml + * Copyright (C) 2005 Nataliya Guts, Vincent Balat, Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * 2009 Jrmie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later version. + * See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(** This module allows to mix preemptive threads with [Lwt] + cooperative threads. It maintains an extensible pool of preemptive + threads to with you can detach computations. *) + +val detach : ('a -> 'b) -> 'a -> 'b Lwt.t + (** detaches a computation to a preemptive thread. *) + +val init : int -> int -> (string -> unit) -> unit + (** [init min max log] initialises this module. i.e. it launches the + minimum number of preemptive threads and starts the {b + dispatcher}. + + @param min is the minimum number of threads + @param max is the maximum number of threads + @param log is used to log error messages + + If {!Lwt_preemptive} has already been initialised, this call + only modify bounds and the log function, and return the + dispatcher thread. *) + +val simple_init : unit -> unit + (** [simple_init ()] does a {i simple initialization}. i.e. with + default parameters if the library is not yet initialised. + + Note: this function is automatically called {!detach}. *) + +val get_bounds : unit -> int * int + (** [get_bounds ()] returns the minimum and the maximum number of + preemptive threads. *) + +val set_bounds : int * int -> unit + (** [set_bounds (min, max)] set the minimum and the maximum number + of preemptive threads. *) + +val set_max_number_of_threads_queued : int -> unit + (** Sets the size of the waiting queue, if no more preemptive + threads are available. When the queue is full, {!detach} will + sleep until a thread is available. *) + +val get_max_number_of_threads_queued : unit -> int + (** Returns the size of the waiting queue, if no more threads are + available *) + +(**/**) +val nbthreads : unit -> int +val nbthreadsbusy : unit -> int +val nbthreadsqueued : unit -> int diff --git a/thirdparty/lwt-2.3.2/src/react/lwt-react.mllib b/thirdparty/lwt-2.3.2/src/react/lwt-react.mllib new file mode 100644 index 0000000..f614f68 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/react/lwt-react.mllib @@ -0,0 +1,6 @@ +# OASIS_START +# DO NOT EDIT (digest: 8916665f5b5252b5a633514708d91e4b) +Lwt_event +Lwt_signal +Lwt_react +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/react/lwt_event.ml b/thirdparty/lwt-2.3.2/src/react/lwt_event.ml new file mode 100644 index 0000000..fc7d969 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/react/lwt_event.ml @@ -0,0 +1,54 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_event + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +include Lwt_react.E + +(* +-----------------------------------------------------------------+ + | Notifiers | + +-----------------------------------------------------------------+ *) + +type notifier = unit React.event Lwt_sequence.node + +let notifiers = Lwt_sequence.create () + +let disable n = + Lwt_sequence.remove n; + React.E.stop (Lwt_sequence.get n) + +let notify f event = + Lwt_sequence.add_l (React.E.map f event) notifiers + +let notify_p f event = + Lwt_sequence.add_l (React.E.map (fun x -> Lwt.ignore_result (f x)) event) notifiers + +let notify_s f event = + let mutex = Lwt_mutex.create () in + Lwt_sequence.add_l (React.E.map (fun x -> Lwt.ignore_result (Lwt_mutex.with_lock mutex (fun () -> f x))) event) notifiers + +let always_notify f event = + ignore (notify f event) + +let always_notify_p f event = + ignore (notify_p f event) + +let always_notify_s f event = + ignore (notify_s f event) diff --git a/thirdparty/lwt-2.3.2/src/react/lwt_event.mli b/thirdparty/lwt-2.3.2/src/react/lwt_event.mli new file mode 100644 index 0000000..9d45f20 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/react/lwt_event.mli @@ -0,0 +1,58 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_event + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Events utilities *) + +(** This module is deprecated, you should use {!Lwt_react.E} + instead. *) + +open React + +val with_finaliser : (unit -> unit) -> 'a event -> 'a event +val next : 'a event -> 'a Lwt.t +val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event +val from : (unit -> 'a Lwt.t) -> 'a event +val to_stream : 'a event -> 'a Lwt_stream.t +val of_stream : 'a Lwt_stream.t -> 'a event +val delay : 'a event Lwt.t -> 'a event +val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event +val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event +val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event +val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event +val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event +val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event +val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event +val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event +val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event +val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event +val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event +val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event +val run_s : 'a Lwt.t event -> 'a event +val run_p : 'a Lwt.t event -> 'a event +type notifier +val disable : notifier -> unit +val notify : ('a -> unit) -> 'a event -> notifier +val notify_p : ('a -> unit Lwt.t) -> 'a event -> notifier +val notify_s : ('a -> unit Lwt.t) -> 'a event -> notifier +val always_notify : ('a -> unit) -> 'a event -> unit +val always_notify_p : ('a -> unit Lwt.t) -> 'a event -> unit +val always_notify_s : ('a -> unit Lwt.t) -> 'a event -> unit diff --git a/thirdparty/lwt-2.3.2/src/react/lwt_react.ml b/thirdparty/lwt-2.3.2/src/react/lwt_react.ml new file mode 100644 index 0000000..7e79e4b --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/react/lwt_react.ml @@ -0,0 +1,461 @@ +(* + * lwt_react.ml + * ------------ + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of lwt. + *) + +open Lwt + +type 'a event = 'a React.event +type 'a signal = 'a React.signal + +module E = struct + include React.E + + (* +---------------------------------------------------------------+ + | Lwt-specific utilities | + +---------------------------------------------------------------+ *) + + let finalise f _ = f () + + let with_finaliser f event = + let r = ref () in + Gc.finalise (finalise f) r; + map (fun x -> ignore r; x) event + + let next ev = + let waiter, wakener = Lwt.task () in + let ev = map (fun x -> Lwt.wakeup wakener x) (once ev) in + Lwt.on_cancel waiter (fun () -> stop ev); + waiter + + let limit f e = + (* Thread which prevent [e] to occur while it is sleeping *) + let limiter = ref (return ()) in + + (* The occurence that is delayed until the limiter returns. *) + let delayed = ref None in + + (* The resulting event. *) + let event, push = create () in + + let iter = + fmap + (fun x -> + if state !limiter = Sleep then begin + (* The limiter is sleeping, we queue the event for later + delivering. *) + match !delayed with + | Some cell -> + (* An occurence is alreayd queued, replace it. *) + cell := x; + None + | None -> + let cell = ref x in + delayed := Some cell; + on_success !limiter (fun () -> push !cell); + None + end else begin + (* Set the limiter for future events. *) + limiter := f (); + (* Send the occurence now. *) + push x; + None + end) + e + in + + select [iter; event] + + let stop_from wakener () = + wakeup wakener None + + let from f = + let event, push = create () in + let abort_waiter, abort_wakener = Lwt.wait () in + let rec loop () = + pick [f () >|= (fun x -> Some x); abort_waiter] >>= function + | Some v -> + push v; + loop () + | None -> + stop event; + return () + in + ignore_result (pause () >>= loop); + with_finaliser (stop_from abort_wakener) event + + module EQueue : + sig + type 'a t + val create : 'a React.event -> 'a t + val pop : 'a t -> 'a option Lwt.t + end = + struct + + type 'a state = + | No_mail + | Waiting of 'a option Lwt.u + | Full of 'a Queue.t + + type 'a t = { + mutable state : 'a state; + mutable event : unit React.event; + (* field used to prevent garbage collection *) + } + + let create event = + let box = { state = No_mail; event = never } in + let push v = + match box.state with + | No_mail -> + let q = Queue.create () in + Queue.push v q; + box.state <- Full q + | Waiting wakener -> + box.state <- No_mail; + wakeup_later wakener (Some v) + | Full q -> + Queue.push v q + in + box.event <- map push event; + box + + let pop b = match b.state with + | No_mail -> + let waiter, wakener = task () in + Lwt.on_cancel waiter (fun () -> b.state <- No_mail); + b.state <- Waiting wakener; + waiter + | Waiting _ -> + (* Calls to next are serialized, so this case will never + happened *) + assert false + | Full q -> + let v = Queue.take q in + if Queue.is_empty q then b.state <- No_mail; + return (Some v) + end + + let to_stream event = + let box = EQueue.create event in + Lwt_stream.from (fun () -> EQueue.pop box) + + let stop_stream wakener () = + wakeup wakener None + + let of_stream stream = + let event, push = create () in + let abort_waiter, abort_wakener = Lwt.wait () in + let rec loop () = + pick [Lwt_stream.get stream; abort_waiter] >>= function + | Some value -> + push value; + loop () + | None -> + stop event; + return () + in + ignore_result (pause () >>= loop); + with_finaliser (stop_stream abort_wakener) event + + let delay thread = + match poll thread with + | Some e -> + e + | None -> + let event, send = create () in + on_success thread (fun e -> send e; stop event); + switch never event + + let keeped = ref [] + + let keep e = + keeped := map ignore e :: !keeped + + (* +---------------------------------------------------------------+ + | Event transofrmations | + +---------------------------------------------------------------+ *) + + let run_p e = + let event, push = create () in + let iter = fmap (fun t -> on_success t push; None) e in + select [iter; event] + + let run_s e = + let event, push = create () in + let mutex = Lwt_mutex.create () in + let iter = fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) e in + select [iter; event] + + let map_p f e = + let event, push = create () in + let iter = fmap (fun x -> on_success (f x) push; None) e in + select [iter; event] + + let map_s f e = + let event, push = create () in + let mutex = Lwt_mutex.create () in + let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) e in + select [iter; event] + + let app_p ef e = + let event, push = create () in + let iter = fmap (fun (f, x) -> on_success (f x) push; None) (app (map (fun f x -> (f, x)) ef) e) in + select [iter; event] + + let app_s ef e = + let event, push = create () in + let mutex = Lwt_mutex.create () in + let iter = fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (app (map (fun f x -> (f, x)) ef) e) in + select [iter; event] + + let filter_p f e = + let event, push = create () in + let iter = fmap (fun x -> on_success (f x) (function true -> push x | false -> ()); None) e in + select [iter; event] + + let filter_s f e = + let event, push = create () in + let mutex = Lwt_mutex.create () in + let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) e in + select [iter; event] + + let fmap_p f e = + let event, push = create () in + let iter = fmap (fun x -> on_success (f x) (function Some x -> push x | None -> ()); None) e in + select [iter; event] + + let fmap_s f e = + let event, push = create () in + let mutex = Lwt_mutex.create () in + let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) e in + select [iter; event] + + let diff_s f e = + let previous = ref None in + let event, push = create () in + let mutex = Lwt_mutex.create () in + let iter = + fmap + (fun x -> + match !previous with + | None -> + previous := Some x; + None + | Some y -> + previous := Some x; + on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push; + None) + e + in + select [iter; event] + + let accum_s ef acc = + let acc = ref acc in + let event, push = create () in + let mutex = Lwt_mutex.create () in + let iter = fmap (fun f -> on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc)) (fun x -> acc := x; push x); None) ef in + select [iter; event] + + let fold_s f acc e = + let acc = ref acc in + let event, push = create () in + let mutex = Lwt_mutex.create () in + let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc x)) (fun x -> acc := x; push x); None) e in + select [iter; event] + + let rec rev_fold f acc = function + | [] -> + return acc + | x :: l -> + lwt acc = rev_fold f acc l in + f acc x + + let merge_s f acc el = + let event, push = create () in + let mutex = Lwt_mutex.create () in + let iter = fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (merge (fun acc x -> x :: acc) [] el) in + select [iter; event] +end + +module S = struct + include React.S + + (* +---------------------------------------------------------------+ + | Lwt-specific utilities | + +---------------------------------------------------------------+ *) + + let finalise f _ = f () + + let with_finaliser f signal = + let r = ref () in + Gc.finalise (finalise f) r; + map (fun x -> ignore r; x) signal + + let limit ?eq f s = + (* Thread which prevent [s] to changes while it is sleeping *) + let limiter = ref (f ()) in + + (* The occurence that is delayed until the limiter returns. *) + let delayed = ref None in + + (* The resulting event. *) + let event, push = E.create () in + + let iter = + E.fmap + (fun x -> + if state !limiter = Sleep then begin + (* The limiter is sleeping, we queue the event for later + delivering. *) + match !delayed with + | Some cell -> + (* An occurence is alreayd queued, replace it. *) + cell := x; + None + | None -> + let cell = ref x in + delayed := Some cell; + on_success !limiter (fun () -> push !cell); + None + end else begin + (* Set the limiter for future events. *) + limiter := f (); + (* Send the occurence now. *) + push x; + None + end) + (changes s) + in + + hold ?eq (value s) (E.select [iter; event]) + + let keeped = ref [] + + let keep s = + keeped := map ignore s :: !keeped + + (* +---------------------------------------------------------------+ + | Signal transofrmations | + +---------------------------------------------------------------+ *) + + let run_s ?eq s = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in + lwt x = Lwt_mutex.with_lock mutex (fun () -> value s) in + return (hold ?eq x (E.select [iter; event])) + + let map_s ?eq f s = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in + lwt x = Lwt_mutex.with_lock mutex (fun () -> f (value s)) in + return (hold ?eq x (E.select [iter; event])) + + let app_s ?eq sf s = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in + lwt x = Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s)) in + return (hold ?eq x (E.select [iter; event])) + + let filter_s ?eq f i s = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in + let x = value s in + Lwt_mutex.with_lock mutex (fun () -> f x) >>= function + | true -> + return (hold ?eq x (E.select [iter; event])) + | false -> + return (hold ?eq i (E.select [iter; event])) + + let fmap_s ?eq f i s = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in + Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= function + | Some x -> + return (hold ?eq x (E.select [iter; event])) + | None -> + return (hold ?eq i (E.select [iter; event])) + + let diff_s f s = + let previous = ref (value s) in + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = + E.fmap + (fun x -> + let y = !previous in + previous := x; + on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push; + None) + (changes s) + in + E.select [iter; event] + + let sample_s f e s = + E.map_s (fun x -> f x (value s)) e + + let accum_s ?eq ef i = + hold ?eq i (E.accum_s ef i) + + let fold_s ?eq f i e = + hold ?eq i (E.fold_s f i e) + + let rec rev_fold f acc = function + | [] -> + return acc + | x :: l -> + lwt acc = rev_fold f acc l in + f acc x + + let merge_s ?eq f acc sl = + let s = merge (fun acc x -> x :: acc) [] sl in + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in + lwt x = Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s)) in + return (hold ?eq x (E.select [iter; event])) + + let l1_s ?eq f s1 = + map_s ?eq f s1 + + let l2_s ?eq f s1 s2 = + map_s ?eq (fun (x1, x2) -> f x1 x2) (l2 (fun x1 x2 -> (x1, x2)) s1 s2) + + let l3_s ?eq f s1 s2 s3 = + map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) (l3 (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3) + + let l4_s ?eq f s1 s2 s3 s4 = + map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) (l4 (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4) + + let l5_s ?eq f s1 s2 s3 s4 s5 = + map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) (l5 (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5) + + let l6_s ?eq f s1 s2 s3 s4 s5 s6 = + map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) (l6 (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6) + + (* +---------------------------------------------------------------+ + | Monadic interface | + +---------------------------------------------------------------+ *) + + let return = + const + + let bind ?eq s f = + switch ?eq (f (value s)) (E.map f (changes s)) + + let bind_s ?eq s f = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in + lwt x = Lwt_mutex.with_lock mutex (fun () -> f (value s)) in + Lwt.return (switch ?eq x (E.select [iter; event])) +end diff --git a/thirdparty/lwt-2.3.2/src/react/lwt_react.mli b/thirdparty/lwt-2.3.2/src/react/lwt_react.mli new file mode 100644 index 0000000..b5ef32c --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/react/lwt_react.mli @@ -0,0 +1,166 @@ +(* + * lwt_react.mli + * ------------- + * Copyright : (c) 2011, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of lwt. + *) + +(** React utilities *) + +(** This module is a replacement for the React module. You can open it + instead of the React module in order to get all react's functions + plus Lwt ones. *) + +type 'a event = 'a React.event + (** Type of events. *) + +type 'a signal = 'a React.signal + (** Type of signals. *) + +module E : sig + include module type of React.E + + (** {6 Lwt-specific utilities} *) + + val with_finaliser : (unit -> unit) -> 'a event -> 'a event + (** [with_finaliser f e] returns an event [e'] which behave as + [e], except that [f] is called when [e'] is garbage + collected. *) + + val next : 'a event -> 'a Lwt.t + (** [next e] returns the next occurrence of [e] *) + + val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event + (** [limit f e] limits the rate of [e] with [f]. + + For example, to limit the rate of an event to 1 per second you + can use: [limit (fun () -> Lwt_unix.sleep 1.0) event]. *) + + val from : (unit -> 'a Lwt.t) -> 'a event + (** [from f] creates an event which occurs each [f ()] returns a + value. If [f] raises an exception, the event is just + stopped. *) + + val to_stream : 'a event -> 'a Lwt_stream.t + (** Creates a stream holding all values occurring on the given + event *) + + val of_stream : 'a Lwt_stream.t -> 'a event + (** [of_stream stream] creates an event which occurs each time a + value is available on the stream. *) + + val delay : 'a event Lwt.t -> 'a event + (** [delay thread] is an event which does not occurs until + [thread] returns. Then it behaves as the event returned by + [thread]. *) + + val keep : 'a event -> unit + (** [keep e] keeps a reference to [e] so it will never be garbage + collected. *) + + (** {6 Threaded versions of React transformation functions} *) + + (** The following functions behave as their [React] counterpart, + except that they takes functions that may yield. + + As usual the [_s] suffix is used when calls are serialized, and + the [_p] suffix is used when they are not. + + Note that [*_p] functions may not preserve event order. *) + + val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event + val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event + + val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event + val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event + + val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event + val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event + + val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event + val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event + + val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event + + val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event + + val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event + + val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event + + val run_s : 'a Lwt.t event -> 'a event + val run_p : 'a Lwt.t event -> 'a event +end + +module S : sig + include module type of React.S + + (** {6 Monadic interface} *) + + val return : 'a -> 'a signal + (** Same as [const]. *) + + val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal + (** [bind ?eq s f] is initially [f x] where [x] is the current + value of [s]. Each time [s] changes to a new value [y], [bind + signal f] is set to [f y], until the next change of + [signal]. *) + + val bind_s : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal Lwt.t) -> 'b signal Lwt.t + (** Same as {!bind} except that [f] returns a thread. Calls to [f] + are serialized. *) + + (** {6 Lwt-specific utilities} *) + + val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal + (** [with_finaliser f s] returns a signal [s'] which behave as + [s], except that [f] is called when [s'] is garbage + collected. *) + + val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal + (** [limit f s] limits the rate of [s] update with [f]. + + For example, to limit it to 1 per second, you can use: [limit + (fun () -> Lwt_unix.sleep 1.0) s]. *) + + val keep : 'a signal -> unit + (** [keep s] keeps a reference to [s] so it will never be garbage + collected. *) + + (** {6 Threaded versions of React transformation functions} *) + + (** The following functions behave as their [React] counterpart, + except that they takes functions that may yield. + + The [_s] suffix means that calls are serialized. + *) + + val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'a signal -> 'b signal Lwt.t + + val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t + + val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal Lwt.t + + val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal Lwt.t + + val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event + + val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event + + val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal + + val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal + + val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal Lwt.t + + val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t + val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'a signal -> 'b signal -> 'c signal Lwt.t + val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal Lwt.t + val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal Lwt.t + val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal Lwt.t + val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal Lwt.t + + val run_s : ?eq : ('a -> 'a -> bool) -> 'a Lwt.t signal -> 'a signal Lwt.t +end diff --git a/thirdparty/lwt-2.3.2/src/react/lwt_signal.ml b/thirdparty/lwt-2.3.2/src/react/lwt_signal.ml new file mode 100644 index 0000000..069b14c --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/react/lwt_signal.ml @@ -0,0 +1,175 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_signal + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +include Lwt_react.S + +open Lwt_react +open Lwt + +(* +-----------------------------------------------------------------+ + | Notifiers | + +-----------------------------------------------------------------+ *) + +type notifier = unit React.signal Lwt_sequence.node + +let notifiers = Lwt_sequence.create () + +let disable n = + Lwt_sequence.remove n; + stop (Lwt_sequence.get n) + +let notify f signal = + Lwt_sequence.add_l (S.map f signal) notifiers + +let notify_p f signal = + Lwt_sequence.add_l (S.map (fun x -> Lwt.ignore_result (f x)) signal) notifiers + +let notify_s f signal = + let mutex = Lwt_mutex.create () in + Lwt_sequence.add_l (S.map (fun x -> Lwt.ignore_result (Lwt_mutex.with_lock mutex (fun () -> f x))) signal) notifiers + +let always_notify f signal = + ignore (notify f signal) + +let always_notify_p f signal = + ignore (notify_p f signal) + +let always_notify_s f signal = + ignore (notify_s f signal) + +(* +-----------------------------------------------------------------+ + | Lwt-specific utilities | + +-----------------------------------------------------------------+ *) + +let delay thread = + match poll thread with + | Some signal -> + let event1, send1 = React.E.create () in + let event2, send2 = React.E.create () in + ignore ( + (* If the thread has already terminated, we make a pause to + prevent the first occurence to be lost *) + lwt () = pause () in + send1 (value signal); + send2 (changes signal); + React.E.stop event1; + React.E.stop event2; + return () + ); + React.E.switch event1 event2 + | None -> + let event1, send1 = React.E.create () in + let event2, send2 = React.E.create () in + ignore ( + lwt signal = thread in + send1 (value signal); + send2 (changes signal); + React.E.stop event1; + React.E.stop event2; + return () + ); + React.E.switch event1 event2 + +(* +-----------------------------------------------------------------+ + | Signal transofrmations | + +-----------------------------------------------------------------+ *) + +let run_s ?eq i s = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in + on_success (Lwt_mutex.with_lock mutex (fun () -> value s)) push; + hold ?eq i (E.select [iter; event]) + +let map_s ?eq f i s = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in + on_success (Lwt_mutex.with_lock mutex (fun () -> f (value s))) push; + hold ?eq i (E.select [iter; event]) + +let app_s ?eq sf i s = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in + on_success (Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s))) push; + hold ?eq i (E.select [iter; event]) + +let filter_s ?eq f i s = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in + let x = value s in + on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) + (function + | true -> + push x + | false -> + ()); + hold ?eq i (E.select [iter; event]) + +let fmap_s ?eq f i s = + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in + on_success + (Lwt_mutex.with_lock mutex (fun () -> f (value s))) + (function + | Some x -> + push x + | None -> + ()); + hold ?eq i (E.select [iter; event]) + +let rec rev_fold f acc = function + | [] -> + return acc + | x :: l -> + lwt acc = rev_fold f acc l in + f acc x + +let merge_s ?eq f acc sl = + let s = merge (fun acc x -> x :: acc) [] sl in + let event, push = E.create () in + let mutex = Lwt_mutex.create () in + let iter = E.fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in + on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s))) push; + hold ?eq acc (E.select [iter; event]) + +let l1_s ?eq f i s1 = + map_s ?eq f i s1 + +let l2_s ?eq f i s1 s2 = + map_s ?eq (fun (x1, x2) -> f x1 x2) i (l2 (fun x1 x2 -> (x1, x2)) s1 s2) + +let l3_s ?eq f i s1 s2 s3 = + map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) i (l3 (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3) + +let l4_s ?eq f i s1 s2 s3 s4 = + map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) i (l4 (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4) + +let l5_s ?eq f i s1 s2 s3 s4 s5 = + map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) i (l5 (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5) + +let l6_s ?eq f i s1 s2 s3 s4 s5 s6 = + map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) i (l6 (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6) diff --git a/thirdparty/lwt-2.3.2/src/react/lwt_signal.mli b/thirdparty/lwt-2.3.2/src/react/lwt_signal.mli new file mode 100644 index 0000000..05e18b2 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/react/lwt_signal.mli @@ -0,0 +1,57 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_event + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Signals utilities *) + +(** This module is deprecated, you should use {!Lwt_react.S} + instead. *) + +open React +val return : 'a -> 'a signal +val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal +val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal +val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal +val delay : 'a signal Lwt.t -> 'a event +val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'b -> 'a signal -> 'b signal +val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'b -> 'a signal -> 'b signal +val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal +val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal +val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event +val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event +val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal +val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal +val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal +val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'b -> ('a signal -> 'b signal) +val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'c -> ('a signal -> 'b signal -> 'c signal) +val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'd -> ('a signal -> 'b signal -> 'c signal -> 'd signal) +val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'e -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal) +val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'f -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal) +val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'g -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal) +val run_s : ?eq : ('a -> 'a -> bool) -> 'a -> 'a Lwt.t signal -> 'a signal +type notifier +val disable : notifier -> unit +val notify : ('a -> unit) -> 'a signal -> notifier +val notify_p : ('a -> unit Lwt.t) -> 'a signal -> notifier +val notify_s : ('a -> unit Lwt.t) -> 'a signal -> notifier +val always_notify : ('a -> unit) -> 'a signal -> unit +val always_notify_p : ('a -> unit Lwt.t) -> 'a signal -> unit +val always_notify_s : ('a -> unit Lwt.t) -> 'a signal -> unit diff --git a/thirdparty/lwt-2.3.2/src/simple_top/lwt-simple-top.mllib b/thirdparty/lwt-2.3.2/src/simple_top/lwt-simple-top.mllib new file mode 100644 index 0000000..0553636 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/simple_top/lwt-simple-top.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: de6ce24e129acca71e8908d2344cd786) +Lwt_simple_top +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/simple_top/lwt_simple_top.ml b/thirdparty/lwt-2.3.2/src/simple_top/lwt_simple_top.ml new file mode 100644 index 0000000..8bea865 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/simple_top/lwt_simple_top.ml @@ -0,0 +1,47 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_simple_top + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* Integration with the toplevel for people who do not have the + enhanced toplevel (package lwt.top, which require ocaml-text). *) + +open Lwt +open Lwt_io + +let read_input_non_interactive prompt buffer len = + let rec loop i = + if i = len then + return (i, false) + else + read_char_opt stdin >>= function + | Some c -> + buffer.[i] <- c; + if c = '\n' then + return (i + 1, false) + else + loop (i + 1) + | None -> + return (i, true) + in + Lwt_main.run (write stdout prompt >> loop 0) + +let _ = + Toploop.read_interactive_input := read_input_non_interactive diff --git a/thirdparty/lwt-2.3.2/src/ssl/lwt-ssl.mllib b/thirdparty/lwt-2.3.2/src/ssl/lwt-ssl.mllib new file mode 100644 index 0000000..3320232 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/ssl/lwt-ssl.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: ab07ef30d9c1dd9dd2a1f2eef22e9d68) +Lwt_ssl +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.ml b/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.ml new file mode 100644 index 0000000..182504e --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.ml @@ -0,0 +1,175 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_ssl + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +type t = + Plain + | SSL of Ssl.socket + +type socket = Lwt_unix.file_descr * t + +let is_ssl s = + match snd s with + Plain -> false + | _ -> true + +let wrap_call f () = + try + f () + with + (Ssl.Connection_error err | Ssl.Accept_error err | + Ssl.Read_error err | Ssl.Write_error err) as e -> + match err with + Ssl.Error_want_read -> + raise Lwt_unix.Retry_read + | Ssl.Error_want_write -> + raise Lwt_unix.Retry_write + | _ -> + raise e + +let repeat_call fd f = + try + Lwt_unix.check_descriptor fd; + Lwt.return (wrap_call f ()) + with + Lwt_unix.Retry_read -> + Lwt_unix.register_action Lwt_unix.Read fd (wrap_call f) + | Lwt_unix.Retry_write -> + Lwt_unix.register_action Lwt_unix.Write fd (wrap_call f) + | e -> + raise_lwt e + +(****) + +let plain fd = (fd, Plain) + +let embed_socket fd context = (fd, SSL(Ssl.embed_socket (Lwt_unix.unix_file_descr fd) context)) + +let ssl_accept fd ctx = + let socket = Ssl.embed_socket (Lwt_unix.unix_file_descr fd) ctx in + Lwt.bind + (repeat_call fd (fun () -> Ssl.accept socket)) (fun () -> + Lwt.return (fd, SSL socket)) + +let ssl_connect fd ctx = + let socket = Ssl.embed_socket (Lwt_unix.unix_file_descr fd) ctx in + Lwt.bind + (repeat_call fd (fun () -> Ssl.connect socket)) (fun () -> + Lwt.return (fd, SSL socket)) + +let read (fd, s) buf pos len = + match s with + | Plain -> + Lwt_unix.read fd buf pos len + | SSL s -> + if len = 0 then + Lwt.return 0 + else + repeat_call fd + (fun () -> + try + Ssl.read s buf pos len + with Ssl.Read_error Ssl.Error_zero_return -> + 0) + +let read_bytes (fd, s) buf pos len = + match s with + | Plain -> + Lwt_bytes.read fd buf pos len + | SSL s -> + if len = 0 then + Lwt.return 0 + else + repeat_call fd + (fun () -> + try + let str = String.create len in + let n = Ssl.read s str 0 len in + Lwt_bytes.blit_string_bytes str 0 buf pos len; + n + with Ssl.Read_error Ssl.Error_zero_return -> + 0) + +let write (fd, s) buf pos len = + match s with + | Plain -> + Lwt_unix.write fd buf pos len + | SSL s -> + if len = 0 then + Lwt.return 0 + else + repeat_call fd + (fun () -> + Ssl.write s buf pos len) + +let write_bytes (fd, s) buf pos len = + match s with + | Plain -> + Lwt_bytes.write fd buf pos len + | SSL s -> + if len = 0 then + Lwt.return 0 + else + repeat_call fd + (fun () -> + let str = String.create len in + Lwt_bytes.blit_bytes_string buf pos str 0 len; + Ssl.write s str 0 len) + +let wait_read (fd, s) = + match s with + Plain -> Lwt_unix.wait_read fd + | SSL _ -> Lwt_unix.yield () + +let wait_write (fd, s) = + match s with + Plain -> Lwt_unix.wait_write fd + | SSL _ -> Lwt_unix.yield () + +let out_channel_of_descr s = + Lwt_io.make ~mode:Lwt_io.output (fun buf pos len -> write_bytes s buf pos len) + +let in_channel_of_descr s = + Lwt_io.make ~mode:Lwt_io.input (fun buf pos len -> read_bytes s buf pos len) + +let ssl_shutdown (fd, s) = + match s with + Plain -> Lwt.return () + | SSL s -> repeat_call fd (fun () -> Ssl.shutdown s) + +let shutdown (fd, _) cmd = Lwt_unix.shutdown fd cmd + +let close (fd, _) = Lwt_unix.close fd + +let abort (fd, _) = Lwt_unix.abort fd + +let get_fd (fd,socket) = + match socket with + | Plain -> Lwt_unix.unix_file_descr fd + | SSL socket -> (Ssl.file_descr_of_socket socket) + +let getsockname s = + Unix.getsockname (get_fd s) + +let getpeername s = + Unix.getpeername (get_fd s) + diff --git a/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.mli b/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.mli new file mode 100644 index 0000000..6b30c78 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.mli @@ -0,0 +1,58 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_ssl + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** OCaml-SSL integration *) + +type socket + +val ssl_accept : Lwt_unix.file_descr -> Ssl.context -> socket Lwt.t +val ssl_connect : Lwt_unix.file_descr -> Ssl.context -> socket Lwt.t +val plain : Lwt_unix.file_descr -> socket +val embed_socket : Lwt_unix.file_descr -> Ssl.context -> socket + +val read : socket -> string -> int -> int -> int Lwt.t +val write : socket -> string -> int -> int -> int Lwt.t + +val read_bytes : socket -> Lwt_bytes.t -> int -> int -> int Lwt.t +val write_bytes : socket -> Lwt_bytes.t -> int -> int -> int Lwt.t + +(* Really wait on a plain socket, just yield over SSL *) +val wait_read : socket -> unit Lwt.t +val wait_write : socket -> unit Lwt.t + +val shutdown : socket -> Unix.shutdown_command -> unit +val close : socket -> unit Lwt.t + +val out_channel_of_descr : socket -> Lwt_chan.out_channel +val in_channel_of_descr : socket -> Lwt_chan.in_channel + +val ssl_shutdown : socket -> unit Lwt.t + +val abort : socket -> exn -> unit + +(** Are we using an SSL socket? *) +val is_ssl : socket -> bool + +val getsockname : socket -> Unix.sockaddr + +val getpeername : socket -> Unix.sockaddr diff --git a/thirdparty/lwt-2.3.2/src/text/liblwt-text.clib b/thirdparty/lwt-2.3.2/src/text/liblwt-text.clib new file mode 100644 index 0000000..c80b437 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/text/liblwt-text.clib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 49d58712acb378a903b0dfd06803031a) +lwt_text_stubs.o +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/text/lwt-text.mllib b/thirdparty/lwt-2.3.2/src/text/lwt-text.mllib new file mode 100644 index 0000000..d643573 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/text/lwt-text.mllib @@ -0,0 +1,6 @@ +# OASIS_START +# DO NOT EDIT (digest: 445f786e72bdc58b36891d69973effc4) +Lwt_text +Lwt_term +Lwt_read_line +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/text/lwt_read_line.ml b/thirdparty/lwt-2.3.2/src/text/lwt_read_line.ml new file mode 100644 index 0000000..618abd9 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/text/lwt_read_line.ml @@ -0,0 +1,1639 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_read_line + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt +open Lwt_text +open Lwt_term + +module TextSet = Set.Make(Text) +type text_set = TextSet.t + +type edition_state = Text.t * Text.t +type history = Text.t list +type prompt = Lwt_term.styled_text +type password_style = [ `empty | `clear | `text of Text.t ] + +class clipboard = + let signal, setter = React.S.create "" in +object + method set text = setter text + method contents = signal +end + +let clipboard = new clipboard + +exception Interrupt + +(* +-----------------------------------------------------------------+ + | Completion | + +-----------------------------------------------------------------+ *) + +type completion_mode = [ `classic | `real_time | `none ] + +type completion_result = { + comp_state : edition_state; + comp_words : text_set; +} + +type completion = edition_state -> completion_result Lwt.t + +let no_completion state = return { + comp_state = state; + comp_words = TextSet.empty; +} + +let common_prefix a b = + let lena = String.length a and lenb = String.length b in + let rec loop i = + if i = lena || i = lenb || (a.[i] <> b.[i]) then + String.sub a 0 i + else + loop (i + 1) + in + loop 0 + +let lookup word words = + let words = TextSet.filter (fun word' -> Text.starts_with word' word) words in + if TextSet.is_empty words then + ("", TextSet.empty) + else + (TextSet.fold common_prefix words (TextSet.choose words), words) + +let complete ?(suffix=" ") before word after words = + let prefix, words = lookup word words in + match TextSet.cardinal words with + | 0 -> + { comp_state = (before ^ word, after); + comp_words = TextSet.empty } + | 1 -> + { comp_state = (before ^ prefix ^ suffix, after); + comp_words = words } + | _ -> + { comp_state = (before ^ prefix, after); + comp_words = words } + +(* +-----------------------------------------------------------------+ + | Commands | + +-----------------------------------------------------------------+ *) + +module Command = +struct + + type t = + | Nop + | Char of Text.t + | Backward_delete_char + | Forward_delete_char + | Beginning_of_line + | End_of_line + | Complete + | Meta_complete + | Kill_line + | Backward_kill_line + | Accept_line + | Backward_delete_word + | Forward_delete_word + | History_next + | History_previous + | Break + | Clear_screen + | Insert + | Refresh + | Backward_char + | Forward_char + | Set_mark + | Paste + | Copy + | Cut + | Uppercase + | Lowercase + | Capitalize + | Backward_word + | Forward_word + | Backward_search + | Complete_left + | Complete_right + | Complete_up + | Complete_down + | Complete_first + | Complete_last + | Undo + | Delete_char_or_list + + let names = [ + (Nop, "nop"); + (Backward_delete_char, "backward-delete-char"); + (Forward_delete_char, "forward-delete-char"); + (Beginning_of_line, "beginning-of-line"); + (End_of_line, "end-of-line"); + (Complete, "complete"); + (Meta_complete, "meta-complete"); + (Kill_line, "kill-line"); + (Backward_kill_line, "backward-kill-line"); + (Accept_line, "accept-line"); + (Backward_delete_word, "backward-delete-word"); + (Forward_delete_word, "forward-delete-word"); + (History_next, "history-next"); + (History_previous, "history-previous"); + (Break, "break"); + (Clear_screen, "clear-screen"); + (Insert, "insert"); + (Refresh, "refresh"); + (Backward_char, "backward-char"); + (Forward_char, "forward-char"); + (Set_mark, "set-mark"); + (Paste, "paste"); + (Copy, "copy"); + (Cut, "cut"); + (Uppercase, "uppercase"); + (Lowercase, "lowercase"); + (Capitalize, "capitalize"); + (Backward_word, "backward-word"); + (Forward_word, "forward-word"); + (Complete_left, "complete-left"); + (Complete_right, "complete-right"); + (Complete_up, "complete-up"); + (Complete_down, "complete-down"); + (Backward_search, "backward-search"); + (Complete_first, "complete-first"); + (Complete_last, "complete-last"); + (Undo, "undo"); + (Delete_char_or_list, "delete-char-or-list"); + ] + + let to_string = function + | Char ch -> + Printf.sprintf "Char %S" ch + | command -> + let rec search = function + | (command', name) :: _ when command = command' -> + name + | _ :: rest -> + search rest + | [] -> + assert false + in + search names + + let of_string name = + let rec search = function + | (command, name') :: _ when name = name' -> + command + | _ :: rest -> + search rest + | [] -> + failwith "Lwt_read_line.Command.of_stirng: cannot convert string to command" + in + search names + + let of_key = function + | Key_up -> History_previous + | Key_down -> History_next + | Key_left -> Backward_char + | Key_right -> Forward_char + | Key_home -> Beginning_of_line + | Key_end -> End_of_line + | Key_insert -> Insert + | Key_delete -> Forward_delete_char + | Key_control '@' -> Set_mark + | Key_control 'a' -> Beginning_of_line + | Key_control 'd' -> Delete_char_or_list + | Key_control 'e' -> End_of_line + | Key_control 'h' -> Backward_delete_word + | Key_control 'i' -> Complete + | Key_control 'j' -> Accept_line + | Key_control 'k' -> Kill_line + | Key_control 'l' -> Clear_screen + | Key_control 'm' -> Accept_line + | Key_control 'n' -> Backward_char + | Key_control 'p' -> Forward_char + | Key_control 'r' -> Backward_search + | Key_control 'u' -> Backward_kill_line + | Key_control 'w' -> Cut + | Key_control 'y' -> Paste + | Key_control '_' -> Undo + | Key_control '?' -> Backward_delete_char + | Key "\027u" -> Uppercase + | Key "\027l" -> Lowercase + | Key "\027c" -> Capitalize + | Key ("\027Oc" | "\027[1;5C") -> Forward_word + | Key ("\027Od" | "\027[1;5D") -> Backward_word + | Key ("\027\027[A" | "\027[1;3A") -> Complete_up + | Key ("\027\027[B" | "\027[1;3B") -> Complete_down + | Key ("\027\027[C" | "\027[1;3C") -> Complete_right + | Key ("\027\027[D" | "\027[1;3D") -> Complete_left + | Key ("\027\027[7~" | "\027[1;3H") -> Complete_first + | Key ("\027\027[8~" | "\027[1;3F") -> Complete_last + | Key ("\027\n" | "\194\141") -> Char "\n" + | Key ("\027\t" | "\194\137") -> Meta_complete + | Key ("\027w" | "\195\183") -> Copy + | Key ("\027[3^" | "\027[3;5~") -> Forward_delete_word + | Key ch when Text.length ch = 1 && Text.is_print ch -> Char ch + | _ -> Nop +end + +(* +-----------------------------------------------------------------+ + | Read-line engine | + +-----------------------------------------------------------------+ *) + +module Engine = +struct + open Command + + type selection_state = { + sel_text : Text.t; + sel_mark : Text.pointer; + sel_cursor : Text.pointer; + } + + type search_state = { + search_word : Text.t; + search_history : history; + search_init_history : history; + } + + type mode = + | Edition of edition_state + | Selection of selection_state + | Search of search_state + + type state = { + mode : mode; + history : history * history; + } + + let init history = { + mode = Edition("", ""); + history = (history, []); + } + + let all_input state = match state.mode with + | Edition(before, after) -> + before ^ after + | Selection sel -> + sel.sel_text + | Search search -> + match search.search_history with + | [] -> + "" + | phrase :: _ -> + phrase + + let edition_state state = match state.mode with + | Edition(before, after) -> + (before, after) + | Selection sel -> + (Text.chunk (Text.pointer_l sel.sel_text) sel.sel_cursor, + Text.chunk sel.sel_cursor (Text.pointer_r sel.sel_text)) + | Search search -> + match search.search_history with + | [] -> + ("", "") + | phrase :: _ -> + (phrase, "") + + (* Reset the mode to the edition mode: *) + let reset state = match state.mode with + | Edition _ -> + state + | Selection sel -> + { state with mode = Edition(Text.chunk (Text.pointer_l sel.sel_text) sel.sel_cursor, + Text.chunk sel.sel_cursor (Text.pointer_r sel.sel_text)) } + | Search search -> + { state with mode = Edition((match search.search_history with + | [] -> + "" + | phrase :: _ -> + phrase), "") } + + let split_first_word text = + let rec find_last ptr = + match Text.next ptr with + | Some(ch, ptr) when Text.is_alnum ch -> + find_last ptr + | _ -> + ptr + in + let rec find_first ptr = + match Text.next ptr with + | Some(ch, ptr') -> + if Text.is_alnum ch then + let ptr' = find_last ptr' in + (Text.chunk (Text.pointer_l text) ptr, + Text.chunk ptr ptr', + Text.chunk ptr' (Text.pointer_r text)) + else + find_first ptr' + | None -> + (text, "", "") + in + find_first (Text.pointer_l text) + + let split_last_word text = + let rec find_first ptr = + match Text.prev ptr with + | Some(ch, ptr) when Text.is_alnum ch -> + find_first ptr + | _ -> + ptr + in + let rec find_last ptr = + match Text.prev ptr with + | Some(ch, ptr') -> + if Text.is_alnum ch then + let ptr' = find_first ptr' in + (Text.chunk (Text.pointer_l text) ptr', + Text.chunk ptr' ptr, + Text.chunk ptr (Text.pointer_r text)) + else + find_last ptr' + | None -> + (text, "", "") + in + find_last (Text.pointer_r text) + + let rec update ~engine_state ?(clipboard=clipboard) ~command () = + (* Helpers for updating the mode state only: *) + let edition st = { engine_state with mode = Edition st } + and selection st = { engine_state with mode = Selection st } + and search st = { engine_state with mode = Search st } in + match engine_state.mode with + | Selection sel -> + (* Change the cursor position: *) + let maybe_set_cursor = function + | Some(_, ptr) -> + selection { sel with sel_cursor = ptr } + | None -> + engine_state + in + + begin match command with + | Nop -> + engine_state + + | Forward_char -> + maybe_set_cursor (Text.next sel.sel_cursor) + + | Backward_char -> + maybe_set_cursor (Text.prev sel.sel_cursor) + + | Forward_word -> + let rec skip ptr = + match Text.next ptr with + | Some(ch, ptr) -> + if Text.is_alnum ch then find ptr else skip ptr + | None -> + ptr + and find ptr = + match Text.next ptr with + | Some(ch, ptr') -> + if Text.is_alnum ch then find ptr' else ptr + | None -> + ptr + in + selection { sel with sel_cursor = skip sel.sel_cursor } + + | Backward_word -> + let rec skip ptr = + match Text.prev ptr with + | Some(ch, ptr) -> + if Text.is_alnum ch then find ptr else skip ptr + | None -> + ptr + and find ptr = + match Text.prev ptr with + | Some(ch, ptr') -> + if Text.is_alnum ch then find ptr' else ptr + | None -> + ptr + in + selection { sel with sel_cursor = skip sel.sel_cursor } + + | Beginning_of_line -> + selection { sel with sel_cursor = Text.pointer_l sel.sel_text } + + | End_of_line -> + selection { sel with sel_cursor = Text.pointer_r sel.sel_text } + + | Copy -> + let a = min sel.sel_cursor sel.sel_mark and b = max sel.sel_cursor sel.sel_mark in + clipboard#set (Text.chunk a b); + edition (Text.chunk (Text.pointer_l sel.sel_text) sel.sel_cursor, + Text.chunk sel.sel_cursor (Text.pointer_r sel.sel_text)) + + | Cut -> + let a = min sel.sel_cursor sel.sel_mark and b = max sel.sel_cursor sel.sel_mark in + clipboard#set (Text.chunk a b); + edition (Text.chunk (Text.pointer_l sel.sel_text) a, + Text.chunk b (Text.pointer_r sel.sel_text)) + + | command -> + (* If the user sent another command, reset the mode to + edition and process the command: *) + update ~engine_state:(reset engine_state) ~clipboard ~command () + end + + | Edition(before, after) -> + begin match command with + | Char ch -> + edition (before ^ ch, after) + + | Set_mark -> + let txt = before ^ after in + let ptr = Text.pointer_at txt (Text.length before) in + selection { sel_text = txt; + sel_mark = ptr; + sel_cursor = ptr } + + | Paste -> + edition (before ^ (React.S.value clipboard#contents), after) + + | Backward_delete_char -> + edition (Text.rchop before, after) + + | Forward_delete_char -> + edition (before, Text.lchop after) + + | Beginning_of_line -> + edition ("", before ^ after) + + | End_of_line -> + edition (before ^ after, "") + + | Kill_line -> + clipboard#set after; + edition (before, "") + + | Backward_kill_line -> + clipboard#set before; + edition ("", after) + + | History_previous -> + begin match engine_state.history with + | ([], _) -> + engine_state + | (line :: hist_before, hist_after) -> + { mode = Edition(line, ""); + history = (hist_before, (before ^ after) :: hist_after) } + end + + | History_next -> + begin match engine_state.history with + | (_, []) -> + engine_state + | (hist_before, line :: hist_after) -> + { mode = Edition(line, ""); + history = ((before ^ after) :: hist_before, hist_after) } + end + + | Backward_char -> + if before = "" then + engine_state + else + edition (Text.rchop before, + Text.get before (-1) ^ after) + + | Forward_char -> + if after = "" then + engine_state + else + edition (before ^ (Text.get after 0), + Text.lchop after) + + | Uppercase -> + let a, b, c = split_first_word after in + edition (before ^ a ^ Text.upper b, c) + + | Lowercase -> + let a, b, c = split_first_word after in + edition (before ^ a ^ Text.lower b, c) + + | Capitalize -> + let a, b, c = split_first_word after in + edition (before ^ a ^ Text.capitalize (Text.lower b), c) + + | Backward_word -> + let a, b, c = split_last_word before in + edition (a, b ^ c ^ after) + + | Forward_word -> + let a, b, c = split_first_word after in + edition (before ^ a ^ b, c) + + | Backward_delete_word -> + let a, b, c = split_last_word before in + edition (a, c ^ after) + + | Forward_delete_word -> + let a, b, c = split_first_word after in + edition (before ^ a, c) + + | Backward_search -> + let hist_before, hist_after = engine_state.history in + let history = List.rev_append hist_after ((before ^ after) :: hist_before) in + search { search_word = ""; + search_history = history; + search_init_history = history } + + | _ -> + engine_state + end + + | Search st -> + let lookup word history = + let rec aux history = match history with + | [] -> + [] + | phrase :: rest -> + if Text.contains phrase word then + history + else + aux rest + in + aux history + in + + begin match command with + | Char ch -> + let word = st.search_word ^ ch in + search { + st with + search_word = word; + search_history = lookup word st.search_history; + } + + | Backward_search -> + search { + st with + search_history = match st.search_history with + | [] -> [] + | _ :: rest -> lookup st.search_word rest + } + + | Backward_delete_char -> + if st.search_word <> "" then + let word = Text.rchop st.search_word in + search { + st with + search_word = word; + search_history = lookup word st.search_init_history; + } + else + search st + + | cmd -> + let phrase = match st.search_history with + | [] -> "" + | phrase :: _ -> phrase + in + edition (phrase, "") + end +end + +(* +-----------------------------------------------------------------+ + | Rendering | + +-----------------------------------------------------------------+ *) + +let rec repeat f n = + if n <= 0 then + return () + else + lwt () = f () in + repeat f (n - 1) + +let print_words oc screen_width words = match List.filter ((<>) "") words with + | [] -> + return () + | words -> + let max_width = List.fold_left (fun x word -> max x (Text.length word)) 0 words + 1 in + let count = List.length words in + let columns = max 1 (screen_width / max_width) in + let lines = + if count < columns then + 1 + else + let l = count / columns in + if columns mod count = 0 then l else l + 1 + in + let column_width = screen_width / columns in + let m = Array.make_matrix lines columns "" in + let rec fill_display line column = function + | [] -> + () + | word :: words -> + m.(line).(column) <- word; + let line = line + 1 in + if line < lines then + fill_display line column words + else + fill_display 0 (column + 1) words + in + fill_display 0 0 words; + for_lwt line = 0 to lines - 1 do + lwt () = + for_lwt column = 0 to columns - 1 do + let word = m.(line).(column) in + lwt () = write oc word in + let len = Text.length word in + if len < column_width then + repeat (fun () -> write_char oc " ") (column_width - len) + else + return () + done + in + write_char oc "\n" + done + +module Terminal = +struct + open Engine + open Command + + type state = { + printed_before : styled_text; + (* The text displayed before the cursor *) + printed_after : styled_text; + (* The text displayed after the cursor *) + box : bool; + (* Tell whether a box is currently displayed *) + display_start : int; + (* For dynamic completion. It is the index of the first displayed word. *) + } + + let init = { printed_before = []; printed_after = []; display_start = 0; box = false } + + type box = + | Box_none + | Box_empty + | Box_words of text_set * int + | Box_message of string + + let make_completion index columns words = + let rec aux ofs idx = function + | [] -> + [Text(Text.repeat (columns - ofs) " ")] + | word :: words -> + let len = Text.length word in + let ofs' = ofs + len in + if ofs' <= columns then + if idx = index then + Inverse :: Text word :: Reset :: + if ofs' + 1 > columns then + [] + else + Text "│" :: aux (ofs' + 1) (idx + 1) words + else + Text word :: + if ofs' + 1 > columns then + [] + else + Text "│" :: aux (ofs' + 1) (idx + 1) words + else + [Text(Text.sub word 0 (columns - ofs))] + in + aux 0 0 words + + let make_bar delimiter columns words = + let buf = Buffer.create (columns * 3) in + let rec aux ofs = function + | [] -> + for i = ofs + 1 to columns do + Buffer.add_string buf "─" + done; + Buffer.contents buf + | word :: words -> + let len = Text.length word in + let ofs' = ofs + len in + if ofs' <= columns then begin + for i = 1 to len do + Buffer.add_string buf "─" + done; + if ofs' + 1 > columns then + Buffer.contents buf + else begin + Buffer.add_string buf delimiter; + aux (ofs' + 1) words + end + end else begin + for i = ofs + 1 to columns do + Buffer.add_string buf "─" + done; + Buffer.contents buf + end + in + aux 0 words + + let rec drop count l = + if count <= 0 then + l + else match l with + | [] -> [] + | e :: l -> drop (count - 1) l + + let rec goto_beginning_of_line = function + | 0 -> + [Text "\r"] + | 1 -> + [Text "\027[F"] + | n -> + Text "\027[F" :: goto_beginning_of_line (n - 1) + + let rec compute_position columns acc = function + | [] -> + acc + | Text txt :: rest -> + let acc = Text.fold (fun ch (column, line) -> + match ch with + | "\n" -> + (0, line + 1) + | _ -> + if column = columns then + (1, line + 1) + else + (column + 1, line)) txt acc in + compute_position columns acc rest + | _ :: rest -> + compute_position columns acc rest + + let _draw columns old_render_state new_render_state = + + let new_width_before, new_height_before = + compute_position columns (0, 0) new_render_state.printed_before + and old_width_before, old_height_before = + compute_position columns (0, 0) old_render_state.printed_before in + + let new_render_state, new_width_before, new_height_before = + (* If we terminates on the right margin, we add a "\n" to ensure + that the cursor will be printed at the beginning of the next + line: *) + if new_width_before = columns then + ({ new_render_state with printed_before = new_render_state.printed_before @ [Text "\n"] }, 0, new_height_before + 1) + else + (new_render_state, new_width_before, new_height_before) + in + + let new_width_total, new_height_total = + compute_position columns (new_width_before, new_height_before) new_render_state.printed_after + and old_width_total, old_height_total = + compute_position columns (old_width_before, old_height_before) old_render_state.printed_after in + + (* Produce a sequence erasing n lines: *) + let rec eraser acc = function + | 0 -> acc + | n -> eraser (Text "\027[K\n" :: acc) (n - 1) + in + + let text = List.flatten [ + (* Go back by the number of rows of the previous text: *) + goto_beginning_of_line old_height_before; + + (* Erase all old contents: *) + eraser [Text "\027[K"] old_height_total; + + (* Go back to the starting point: *) + goto_beginning_of_line old_height_total; + + (* Print all new contents: *) + new_render_state.printed_before; + new_render_state.printed_after; + + (* Go back again to the beginning of printed text: *) + goto_beginning_of_line new_height_total; + + (* Prints again the text before the cursor, to put the cursor at + the right place: *) + new_render_state.printed_before; + ] in + + (text, new_render_state) + + (* Render the current state on the terminal, and returns the new + terminal rendering state: *) + let draw ~columns ?(map_text=fun x -> x) ?(box=Box_none) ~render_state ~engine_state ~prompt () = + match engine_state.mode with + | Search st -> + let printed_before = Reset :: prompt @ [Reset; Text "(reverse-i-search)'"; Text st.search_word] in + let printed_after = match st.search_history with + | [] -> + [Text "'"] + | phrase :: _ -> + let ptr_start = match Text.find phrase st.search_word with + | Some ptr -> + ptr + | None -> + (* The first phrase of st.search_history is a + phrase containing st.search_word, so this + case will never happen *) + assert false + in + let ptr_end = Text.move (Text.length st.search_word) ptr_start in + [Text "': "; + Text(Text.chunk (Text.pointer_l phrase) ptr_start); + Underlined; + Text(Text.chunk ptr_start ptr_end); + Reset; + Text(Text.chunk ptr_end (Text.pointer_r phrase))] + in + _draw columns render_state { render_state with + printed_before = printed_before; + printed_after = printed_after } + + | _ -> + (* Text before and after the cursor, according to the current mode: *) + let before, after = match engine_state.mode with + | Edition(before, after) -> + ([Text(map_text before)], [Text(map_text after)]) + | Selection sel -> + let a = min sel.sel_cursor sel.sel_mark and b = max sel.sel_cursor sel.sel_mark in + let part_before = [Text(map_text (Text.chunk (Text.pointer_l sel.sel_text) a))] + and part_selected = [Underlined; Text(map_text (Text.chunk a b)); Reset] + and part_after = [Text(map_text (Text.chunk (Text.pointer_r sel.sel_text) b))] in + if sel.sel_cursor < sel.sel_mark then + (part_before, part_selected @ part_after) + else + (part_before @ part_selected, part_after) + | Search _ -> + assert false + in + + (* All the text printed before the cursor: *) + let printed_before = List.flatten [[Reset]; prompt; [Reset]; before] in + + match box with + | Box_none -> + _draw columns render_state + { render_state with + printed_before = printed_before; + printed_after = after; + box = false } + + | Box_message message -> + let bar = Text(Text.repeat (columns - 2) "─") in + let message_len = Text.length message in + let message = if message_len + 2 > columns then Text.sub message 0 (columns - 2) else message in + let printed_after = + after @ + [Text "\n"; + Text "┌"; bar; Text "┐\n"; + Text "│"; Text message; Text(String.make (columns - 2 - message_len) ' '); Text "│\n"; + Text "└"; bar; Text "┘"] + in + _draw columns render_state + { render_state with + printed_before = printed_before; + printed_after = printed_after; + box = true } + + | Box_empty -> + let bar = Text(Text.repeat (columns - 2) "─") in + let printed_after = + after @ + [Text "\n"; + Text "┌"; bar; Text "┐\n"; + Text "│"; Text(Text.repeat (columns - 2) " "); Text "│\n"; + Text "└"; bar; Text "┘"] + in + _draw columns render_state + { render_state with + printed_before = printed_before; + printed_after = printed_after; + box = true } + + | Box_words(words, position) -> + let words = TextSet.elements words and count = TextSet.cardinal words in + + (* Sets the index of the first displayed words such + that the cursor is displayed: *) + let display_start = + + (* Given a list of words and an offset, it returns + the index of the last word that can be + dusplayed *) + let rec compute_end offset index words = + match words with + | [] -> + index - 1 + | word :: words -> + let offset = offset + Text.length word in + if offset <= columns - 1 then + compute_end (offset + 1) (index + 1) words + else + index - 1 + in + + if position < render_state.display_start then + (* The cursor is before the left margin *) + let rev_index = count - position - 1 in + count - compute_end 1 rev_index (drop rev_index (List.rev words)) - 1 + else if compute_end 1 render_state.display_start (drop render_state.display_start words) < position then + (* The cursor is after the right margin *) + position + else + (* The cursor points to a word which is + displayed *) + render_state.display_start + in + + let words = drop display_start words in + let printed_after = + List.flatten + [after; + [Text "\n"; + Text "┌"; Text(make_bar "┬" (columns - 2) words); Text "┐\n"; + Text "│"]; + make_completion (position - display_start) (columns - 2) words; + [Text "│\n"; + Text "└"; Text(make_bar "┴" (columns - 2) words); Text "┘"]] + in + + _draw columns render_state + { display_start = display_start; + box = true; + printed_before = printed_before; + printed_after = printed_after } + + let last_draw ~columns ?(map_text=fun x -> x) ~render_state ~engine_state ~prompt () = + let printed = prompt @ [Reset; Text(map_text(all_input engine_state)); Text "\n"] in + fst (_draw columns render_state { render_state with + printed_before = printed; + printed_after = [] }) + + let erase ~columns ~render_state () = + goto_beginning_of_line (snd(compute_position columns (0, 0) render_state.printed_before)) @ [Text "\027[J"] +end + +(* +-----------------------------------------------------------------+ + | Controlling a running instance | + +-----------------------------------------------------------------+ *) + +module Control = +struct + type 'a t = { + result : 'a Lwt.t; + send_command : Command.t -> unit; + hide : unit -> unit Lwt.t; + show : unit -> unit Lwt.t; + } + + type prompt = Engine.state React.signal -> Lwt_term.styled_text React.signal + + let fake w = { result = w; + send_command = ignore; + hide = return; + show = return } + + let result ctrl = ctrl.result + let send_command ctrl command = ctrl.send_command command + let accept ctrl = ctrl.send_command Command.Accept_line + let interrupt ctrl = ctrl.send_command Command.Break + let hide ctrl = ctrl.hide () + let show ctrl = ctrl.show () + + (* +---------------------------------------------------------------+ + | Instance parameters | + +---------------------------------------------------------------+ *) + + open Command + + let set_nth set n = + let module M = struct exception Return of string end in + try + let _ = TextSet.fold (fun x n -> if n = 0 then raise (M.Return x) else n - 1) set n in + invalid_arg "Lwt_read_line.set_nth" + with M.Return x -> + x + + let read_command () = read_key () >|= Command.of_key + + (* State of a read-line instance *) + type state = { + render : Terminal.state; + engine : Engine.state; + box : Terminal.box; + prompt : Lwt_term.styled_text; + visible : bool; + old_states : edition_state list; + } + + type event = + | Ev_command of Command.t + | Ev_prompt of Lwt_term.styled_text + | Ev_box of Terminal.box + | Ev_completion of completion_result + | Ev_screen_size_changed + | Ev_hide of unit Lwt.u + | Ev_show of unit Lwt.u + + let engine_state state = state.engine + let render_state state = state.render + + (* +---------------------------------------------------------------+ + | Read-line generator | + +---------------------------------------------------------------+ *) + + let default_prompt _ = React.S.const [Text "# "] + + let rec truncate_list n l = match n, l with + | 0, l -> + l + | _, [] -> + [] + | n, x :: l -> + if n > 0 then + x :: truncate_list (n - 1) l + else + [] + + let make ?(history=[]) ?(complete=no_completion) ?(clipboard=clipboard) ?(mode=`real_time) + ?(map_text=fun x -> x) ?(filter=fun s c -> return c) ~map_result ?(prompt=default_prompt) () = + (* Signal holding the last engine state before waiting for a new + command: *) + let engine_state, set_engine_state = React.S.create (Engine.init history) in + + let prompt = prompt engine_state in + + (* The thread of the last launched completion *) + let completion_thread = ref (return ()) in + + (*** Events ***) + + (* Thread of the last [read_command]. It is cancelled when + read-line terminates. *) + let last_read_command_thread = ref (raise_lwt Exit) in + + (* Events typed by the user: *) + let user_events = Lwt_stream.from (fun () -> + let t = read_command () in + last_read_command_thread := t; + lwt command = t in + return (Some(Ev_command command))) in + + (* Events sent by the program: *) + let program_events, push_event = Lwt_stream.create () in + let push_event event = push_event (Some event) in + + (* Screan resizing *) + let size_events = Lwt_event.to_stream (React.E.stamp (React.S.changes Lwt_term.size) Ev_screen_size_changed) in + + (* Prompt events *) + let prompt_events = Lwt_event.to_stream (React.E.map (fun prompt -> Ev_prompt prompt) (React.S.changes prompt)) in + + (* All events *) + let events = Lwt_stream.choose [user_events; program_events; size_events; prompt_events] in + + (*** Box for `real_time mode ***) + + (* Contains the last suggested completion: *) + let last_completion = ref None in + + (* If [true], [update_box] will generate an [Ev_completion] when + completion is done, instead of an [Ev_box]. *) + let want_completion = ref false in + + let update_box = + match mode with + | `real_time -> + React.S.map + (function + | { Engine.mode = Engine.Selection _ } -> + push_event (Ev_box(Terminal.Box_message "")) + | { Engine.mode = Engine.Search _ } -> + push_event (Ev_box Terminal.Box_none) + | { Engine.mode = Engine.Edition edition_state } -> + last_completion := None; + want_completion := false; + completion_thread := begin + let thread = complete edition_state >|= fun x -> `Result x in + let start_date = Unix.time () in + (* Animation to make the user happy: *) + let rec loop anim = + pick [thread; Lwt_unix.sleep 0.1 >> return `Timeout] >>= function + | `Result comp -> + last_completion := Some comp.comp_state; + if !want_completion then + push_event (Ev_completion comp) + else + push_event (Ev_box(Terminal.Box_words(comp.comp_words, 0))); + return () + | `Timeout -> + let delta = truncate (Unix.time () -. start_date) in + let seconds = delta mod 60 + and minutes = (delta / 60) mod 60 + and hours = (delta / (60 * 60)) mod 24 + and days = (delta / (60 * 60 * 24)) in + let message = + if days = 0 then + Printf.sprintf "working %s %02d:%02d:%02d" (List.hd anim) hours minutes seconds + else if days = 1 then + Printf.sprintf "working %s 1 day %02d:%02d:%02d" (List.hd anim) hours minutes seconds + else + Printf.sprintf "working %s %d days %02d:%02d:%02d" (List.hd anim) days hours minutes seconds + in + push_event (Ev_box(Terminal.Box_message message)); + loop (List.tl anim) + in + let rec anim = "─" :: "\\" :: "│" :: "/" :: anim in + let thread = loop anim in + Lwt.on_cancel thread (fun () -> push_event (Ev_box Terminal.Box_empty)); + thread + end) + engine_state + | `classic | `none -> + React.S.const () + in + + (*** Main loop ***) + + (* Draw the state on the terminal and update the rendering + state: *) + let draw state = + let text, render_state = + Terminal.draw + ~columns:(React.S.value columns) + ~box:state.box + ~render_state:state.render + ~engine_state:state.engine + ~prompt:state.prompt + ~map_text + () + in + lwt () = printc text in + return { state with render = render_state } + in + + (* - [prev] is the last displayed state + - [state] is the current state *) + let rec loop prev state = + let thread = Lwt_stream.next events in + match Lwt.state thread with + | Sleep -> + (* This may update the prompt and dynamic completion: *) + set_engine_state state.engine; + (* Check a second time since the last command may have + created new messages: *) + begin match Lwt.state thread with + | Sleep -> + (* Redraw screen if the event queue is empty *) + lwt state = (if state.visible && prev <> state then draw else return) state in + lwt event = thread in + process_event state event (loop state) + + | Return event -> + process_event state event (loop prev) + + | Fail exn -> + raise_lwt exn + end + + | Return event -> + process_event state event (loop prev) + + | Fail exn -> + raise_lwt exn + + (* loop_refresh redraw the current state, even if it haa not + changed: *) + and loop_refresh state = + let thread = Lwt_stream.next events in + match Lwt.state thread with + | Sleep -> + set_engine_state state.engine; + begin match Lwt.state thread with + | Sleep -> + lwt state = (if state.visible then draw else return) state in + lwt event = thread in + process_event state event (loop state) + + | Return event -> + process_event state event loop_refresh + + | Fail exn -> + raise_lwt exn + end + + | Return event -> + process_event state event loop_refresh + + | Fail exn -> + raise_lwt exn + + and process_event state event loop = match event with + | Ev_prompt prompt -> + loop { state with prompt = prompt } + + | Ev_screen_size_changed -> + lwt () = printc (Terminal.erase ~columns:(React.S.value columns) ~render_state:state.render ()) in + loop_refresh { state with render = Terminal.init } + + | Ev_hide wakener -> + if state.visible then begin + lwt () = printc (Terminal.erase ~columns:(React.S.value columns) ~render_state:state.render ()) in + wakeup wakener (); + loop { state with render = Terminal.init; visible = false } + end else + loop state + + | Ev_show wakener -> + if not state.visible then begin + lwt state = draw state in + wakeup wakener (); + loop { state with visible = true } + end else + loop state + + | Ev_box box -> + loop { state with box = box } + + | Ev_completion comp -> + let state = { state with engine = { state.engine with Engine.mode = Engine.Edition comp.comp_state } } in + if mode = `classic && TextSet.cardinal comp.comp_words > 1 then + lwt () = + printc (Terminal.last_draw + ~columns:(React.S.value columns) + ~render_state:state.render + ~engine_state:state.engine + ~prompt:state.prompt + ~map_text + ()) + in + lwt () = print_words stdout (React.S.value Lwt_term.columns) (TextSet.elements comp.comp_words) in + loop_refresh { state with render = Terminal.init } + else + loop state + + | Ev_command command -> + if not (command = Complete && mode = `real_time) then + (* Cancel completion on user input: *) + Lwt.cancel !completion_thread; + + (* Save the command for possible [Undo] command *) + let state = + match command, state.engine with + | Undo, _ -> + state + | _, { Engine.mode = Engine.Edition es } -> begin + let old_states = + match state.old_states with + | es' :: _ when es = es' -> + state.old_states + | old_states -> + es :: old_states + in + { state with old_states = truncate_list 1000 old_states } + end + | _ -> + state + in + + (* User-provided filter *) + lwt command = filter state command in + + (* Commands that need pre-processing *) + lwt command = match command, state.engine.Engine.mode with + | Delete_char_or_list, Engine.Edition ("", "") -> return Break + | Delete_char_or_list, Engine.Edition (_, "") -> return Complete + | Delete_char_or_list, Engine.Edition (_, _) -> return Forward_delete_char + | _ -> return command + in + + match command with + | Nop -> + loop state + + | Undo -> begin + match state.old_states with + | [] -> + loop state + | s :: l -> + loop { state with + engine = { state.engine with Engine.mode = Engine.Edition s }; + old_states = l } + end + + | Complete_right -> + begin match state.box with + | Terminal.Box_words(words, index) when index < TextSet.cardinal words - 1 -> + loop { state with box = Terminal.Box_words(words, index + 1) } + | _ -> + loop state + end + + | Complete_left -> + begin match state.box with + | Terminal.Box_words(words, index) when index > 0 -> + loop { state with box = Terminal.Box_words(words, index - 1) } + | _ -> + loop state + end + + | Complete_first -> + begin match state.box with + | Terminal.Box_words(words, index) -> + loop { state with box = Terminal.Box_words(words, 0) } + | _ -> + loop state + end + + | Complete_last -> + begin match state.box with + | Terminal.Box_words(words, index) when not (TextSet.is_empty words)-> + loop { state with box = Terminal.Box_words(words, TextSet.cardinal words - 1) } + | _ -> + loop state + end + + | Complete -> + begin match mode with + | `none -> + loop state + | `classic -> + let state = { state with engine = Engine.reset state.engine } in + completion_thread := begin + lwt comp = complete (Engine.edition_state state.engine) in + push_event (Ev_completion comp); + return () + end; + loop state + | `real_time -> + match !last_completion with + | Some comp_state -> + loop { state with engine = { state.engine with Engine.mode = Engine.Edition comp_state } } + | None -> + want_completion := true; + loop state + end + + | Meta_complete -> + if mode = `real_time then begin + let state = { state with engine = Engine.reset state.engine } in + match state.box with + | Terminal.Box_words(words, index) when not (TextSet.is_empty words) -> + let before, after = Engine.edition_state state.engine in + let word = set_nth words index in + let word_len = Text.length word and before_len = Text.length before in + (* [search] searches the longest suffix of + [before] which is a prefix of [word]: *) + let rec search ptr idx = + if Text.equal_at ptr (Text.sub word 0 idx) then + loop { state with engine = { state.engine with Engine.mode = Engine.Edition(before ^ Text.sub word idx (word_len - idx), after) } } + else + match Text.next ptr with + | None -> raise_lwt (Failure "invalid completion") + | Some(ch, ptr) -> search ptr (idx - 1) + in + if word_len > before_len then + search (Text.pointer_l before) before_len + else + search (Text.pointer_at before (-word_len)) word_len + | _ -> + loop state + end else + loop state + + | Clear_screen -> + lwt () = clear_screen () in + loop_refresh state + + | Refresh -> + loop_refresh state + + | Accept_line -> + return (state, `Accept) + + | Break -> + return (state,`Interrupt) + + | command -> + loop { state with engine = Engine.update ~engine_state:state.engine ~clipboard ~command () } + + in + + let result = with_raw_mode begin fun () -> + + (* Wait for edition to terminate *) + lwt state, result = loop_refresh { + render = Terminal.init; + engine = React.S.value engine_state; + box = Terminal.Box_none; + prompt = React.S.value prompt; + visible = true; + old_states = []; + } in + + (* Cleanup *) + React.S.stop update_box; + Lwt.cancel !last_read_command_thread; + + (* Do the last draw *) + lwt () = printc (Terminal.last_draw + ~columns:(React.S.value columns) + ~render_state:state.render + ~engine_state:state.engine + ~prompt:state.prompt + ~map_text + ()) + in + + match result with + | `Accept -> + map_result (Engine.all_input state.engine) + | `Interrupt -> + raise_lwt Interrupt + end in + { + result = result; + send_command = (fun command -> push_event (Ev_command command)); + hide = (fun () -> + let waiter, wakener = Lwt.wait () in + push_event (Ev_hide wakener); + waiter); + show = (fun () -> + let waiter, wakener = Lwt.wait () in + push_event (Ev_show wakener); + waiter); + } + + (* +---------------------------------------------------------------+ + | Predefined instances | + +---------------------------------------------------------------+ *) + + let make_prompt prompt = React.S.value (prompt (React.S.const (Engine.init []))) + + let read_line ?history ?complete ?clipboard ?mode ?(prompt=default_prompt) () = + lwt stdin_isatty = Lwt_unix.isatty Lwt_unix.stdin + and stdout_isatty = Lwt_unix.isatty Lwt_unix.stdout in + if stdin_isatty && stdout_isatty then + return (make ?history ?complete ?clipboard ?mode ~prompt ~map_result:return ()) + else + return (fake (lwt () = write stdout (strip_styles (make_prompt prompt)) in + Lwt_text.read_line stdin)) + + let read_password ?clipboard ?(style:password_style=`text "*") ?prompt () = + lwt stdin_isatty = Lwt_unix.isatty Lwt_unix.stdin + and stdout_isatty = Lwt_unix.isatty Lwt_unix.stdout in + if stdin_isatty && stdout_isatty then + let map_text = match style with + | `text ch -> (fun txt -> Text.map (fun _ -> ch) txt) + | `clear -> (fun x -> x) + | `empty -> (fun _ -> "") + and filter state = function + | Backward_search -> + (* Drop search commands *) + return Nop + | command -> + return command + in + return (make ?clipboard ~map_text ~mode:`none ~filter ?prompt ~map_result:return ()) + else + fail (Failure "Lwt_read_line.read_password: not running in a terminal") + + let read_keyword ?history ?(case_sensitive=false) ?mode ?(prompt=default_prompt) ~values () = + let compare = if case_sensitive then Text.compare else Text.icompare in + let rec assoc key = function + | [] -> None + | (key', value) :: l -> + if compare key key' = 0 then + Some value + else + assoc key l + in + lwt stdin_isatty = Lwt_unix.isatty Lwt_unix.stdin + and stdout_isatty = Lwt_unix.isatty Lwt_unix.stdout in + if stdin_isatty && stdout_isatty then + let words = List.fold_left (fun acc (key, value) -> TextSet.add key acc) TextSet.empty values in + let filter state = function + | Accept_line -> + let text = Engine.all_input state.engine in + if List.exists (fun (key, value) -> compare key text = 0) values then + return Accept_line + else + return Nop + | command -> + return command + and map_result text = match assoc text values with + | Some value -> + return value + | None -> + assert false + and complete (before, after) = + return (complete "" before after words) + in + return (make ?history ?mode ~prompt ~filter ~map_result ~complete ()) + else + return (fake (lwt () = write stdout (strip_styles (make_prompt prompt)) in + lwt txt = Lwt_text.read_line stdin in + match assoc txt values with + | Some value -> + return value + | None -> + raise_lwt (Failure "Lwt_read_line.read_keyword: invalid input"))) + + let read_yes_no ?history ?mode ?prompt () = + read_keyword ?history ?mode ?prompt ~values:[("yes", true); ("no", false)] () +end + +(* +-----------------------------------------------------------------+ + | Simple calls | + +-----------------------------------------------------------------+ *) + +let default_prompt = [Text "# "] + +let read_line ?history ?complete ?clipboard ?mode ?(prompt=default_prompt) () = + Control.read_line ?history ?complete ?clipboard ?mode ~prompt:(fun _ -> React.S.const prompt) () >>= Control.result + +let read_password ?clipboard ?style ?(prompt=default_prompt) () = + Control.read_password ?clipboard ?style ~prompt:(fun _ -> React.S.const prompt) () >>= Control.result + +let read_keyword ?history ?case_sensitive ?mode ?(prompt=default_prompt) ~values () = + Control.read_keyword ?history ?case_sensitive ?mode ~prompt:(fun _ -> React.S.const prompt) ~values () >>= Control.result + +let read_yes_no ?history ?mode ?(prompt=default_prompt) () = + Control.read_yes_no ?history ?mode ~prompt:(fun _ -> React.S.const prompt) () >>= Control.result + +(* +-----------------------------------------------------------------+ + | History | + +-----------------------------------------------------------------+ *) + +let add_entry line history = + if Text.strip line = "" then + history + else + if (match history with [] -> false | x :: _ -> x = line) then + history + else + line :: history + +let escape line = + Text.map (function + | "\n" -> "\\n" + | "\\" -> "\\\\" + | ch -> ch) line + +let unescape line = + let buf = Buffer.create (String.length line) in + let rec loop ptr = match Text.next ptr with + | Some("\\", ptr) -> + begin match Text.next ptr with + | Some("\\", ptr) -> + Buffer.add_string buf "\\"; + loop ptr + | Some("n", ptr) -> + Buffer.add_string buf "\n"; + loop ptr + | Some(ch, ptr) -> + Buffer.add_string buf "\\"; + Buffer.add_string buf ch; + loop ptr + | None -> + Buffer.add_string buf "\\"; + Buffer.contents buf + end + | Some(ch, ptr) -> + Buffer.add_string buf ch; + loop ptr + | None -> + Buffer.contents buf + in + loop (Text.pointer_l line) + +let rec load_lines ic acc = + Lwt_io.read_line_opt ic >>= function + | Some l -> + load_lines ic (unescape l :: acc) + | None -> + return acc + +let load_history name = + if Sys.file_exists name then + Lwt_io.with_file ~mode:Lwt_io.input name (fun ic -> load_lines ic []) + else + return [] + +let rec merge h1 h2 = match h1, h2 with + | l1 :: h1, l2 :: h2 when l1 = l2 -> + l1 :: merge h1 h2 + | _ -> + h1 @ h2 + +let save_history name history = + lwt on_disk_history = load_history name in + Lwt_io.lines_to_file name (Lwt_stream.map escape (Lwt_stream.of_list (merge (List.rev on_disk_history) (List.rev history)))) diff --git a/thirdparty/lwt-2.3.2/src/text/lwt_read_line.mli b/thirdparty/lwt-2.3.2/src/text/lwt_read_line.mli new file mode 100644 index 0000000..c5d0539 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/text/lwt_read_line.mli @@ -0,0 +1,453 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_read_line + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Interactive line input *) + +(** {6 Definitions} *) + +exception Interrupt + (** Exception raised when the user press [Ctrl^D] *) + +type edition_state = Text.t * Text.t + (** An edition state, it is a pair of two UTF-8 encoded strings: + + - the input before the cursor + - the input after the cursor *) + +type prompt = Lwt_term.styled_text + (** A prompt. It may contains colors. *) + +type text_set = Set.Make(Text).t + +(** {8 Completion} *) + +(** Result of a completion function: *) +type completion_result = { + comp_state : edition_state; + (** The new edition state *) + + comp_words : text_set; + (** A list of possibilities *) +} + +type completion = edition_state -> completion_result Lwt.t + (** Type of a completion function. It takes as argument the + current edition state. + + Note: the thread launched by the completion function is + cancelled using {!Lwt.cancel} if the user continue typing + text. *) + +val lookup : Text.t -> text_set -> (Text.t * text_set) + (** [lookup word words] lookup for completion of [word] into + [words]. It returns [(prefix, possibilities)] where + [possibilities] are all words starting with [word] and [prefix] + is the longest common prefix of [possibilities]. *) + +val complete : ?suffix : Text.t -> Text.t -> Text.t -> Text.t -> text_set -> completion_result + (** [complete ?suffix before word after words] basic completion + functions. [words] is a list of possible completions for + [word]. + + If completion succeed [suffix] is append to the resulting + text. It defaults to [" "]. *) + +val print_words : Lwt_text.output_channel -> int -> string list -> unit Lwt.t + (** [print_words oc columns strs] pretty-prints a list of words. *) + +(** {8 History} *) + +type history = Text.t list + (** Type of an history *) + +val add_entry : Text.t -> history -> history + (** [add_entry line history] returns the history [history] plus + [line] at the beginning. If [line] already appears at the + beginning or contains only spaces, it is discarded. *) + +val save_history : string -> history -> unit Lwt.t + (** [save_history filename history] saves [history] to + [filename]. History is saved by separating lines with a null + character. *) + +val load_history : string -> history Lwt.t + (** [load_history filename] loads history from [filename]. Returns + the empty history if the the file does not exit. *) + +(** {8 Clipboards} *) + +(** Type of a clipboard. *) +class clipboard : object + method set : Text.t -> unit + method contents : Text.t React.signal +end + +val clipboard : clipboard + (** The global clipboard. All read-line instances which do not use a + specific clipboard use this one. *) + +(** {6 High-level functions} *) + +type completion_mode = [ `classic | `real_time | `none ] + (** The completion mode. + + - [`classic] means that when the user hit [Tab] a list of + possible completions is proposed, + + - [`real_time] means that possible completions are shown to + the user as he types, and he can navigate in them with + [Meta+left], [Meta+right] + + - [`none] means no completion at all *) + +val read_line : + ?history : history -> + ?complete : completion -> + ?clipboard : clipboard -> + ?mode : completion_mode -> + ?prompt : prompt -> unit -> Text.t Lwt.t + (** [readline ?history ?complete ?mode ?prompt ()] inputs some text + from the user. If input is not a terminal, it defaults to + [Lwt_text.read_line Lwt_text.stdin]. + + If @param mode contains the current completion mode. It defaults + to [`real_time]. + + @param prompt defaults to [Lwt_term.Text "# "] *) + +type password_style = [ `empty | `clear | `text of Text.t ] + (** Style which indicate how the password is echoed to the user: + + - with [`empty] nothing is printed + - with [`clear] the password is displayed has it + - with [`text ch] all characters are replaced by [ch] *) + +val read_password : + ?clipboard : clipboard -> + ?style : password_style -> + ?prompt : prompt -> unit -> Text.t Lwt.t + (** [read_password ?clipboard ?clear ~prompt ()] inputs a password + from the user. This function fails if input is not a terminal. + + @param style defaults to [`text "*"]. + *) + +val read_keyword : + ?history : history -> + ?case_sensitive : bool -> + ?mode : completion_mode -> + ?prompt : prompt -> + values : (Text.t * 'value) list -> unit -> 'value Lwt.t + (** [read_keyword ?history ?case_sensitive ?mode ~prompt ~keywords + ()] reads one word which is a member of [words]. And returns + which keyword the user choosed. + + [case_sensitive] default to [false]. *) + +val read_yes_no : ?history : history -> ?mode : completion_mode -> ?prompt : prompt -> unit -> bool Lwt.t + (** [read_yes_no ?history ?dynamic prompt ()] is the same as: + + {[ + read_keyword ?history ?dynamic prompt [("yes", true); ("no", false)] () + ]} + *) + +(** {6 Low-level interaction} *) + +(** This part allow you to implements your own read-line function, or + just to use the readline engine in another context (message box, + ...). *) + +(** Readline commands *) +module Command : sig + + (** Type of all read-line function: *) + type t = + | Nop + (** Command which do nothing. Unknown keys maps to this commands. *) + | Char of Text.t + (** Any printable character. *) + | Backward_delete_char + | Forward_delete_char + | Beginning_of_line + | End_of_line + | Complete + | Meta_complete + | Kill_line + | Backward_kill_line + | Accept_line + | Backward_delete_word + | Forward_delete_word + | History_next + | History_previous + | Break + | Clear_screen + | Insert + | Refresh + | Backward_char + | Forward_char + | Set_mark + | Paste + | Copy + | Cut + | Uppercase + | Lowercase + | Capitalize + | Backward_word + | Forward_word + | Backward_search + | Complete_left + | Complete_right + | Complete_up + | Complete_down + | Complete_first + | Complete_last + | Undo + | Delete_char_or_list + + val to_string : t -> string + (** [to_string cmd] returns a string representation of a command *) + + val of_string : string -> t + (** [of_string cld] tries to convert a command name to a + command. @raise Failure if it fails. *) + + val names : (t * string) list + (** [names] is the list of all commands (except [Char ch]) with + their name. *) + + val of_key : Lwt_term.key -> t + (** [of_key key] returns the command to which a key is mapped. *) +end + +(** Engine *) +module Engine : sig + + (** Note: this part know nothing about rendering or completion. *) + + (** State when the user is doing selection: *) + type selection_state = { + sel_text : Text.t; + (** The whole input text on which the selection is working *) + sel_mark : Text.pointer; + (** Pointer to the mark *) + sel_cursor : Text.pointer; + (** Pointer to the cursor *) + } + + (** State when searching in the history *) + type search_state = { + search_word : Text.t; + (** The word we are looking for *) + search_history : history; + (** Position in history. The first element is a sentence + containing the searched word *) + search_init_history : history; + (** The initial history, before searching for a word *) + } + + (** The engine mode: *) + type mode = + | Edition of edition_state + (** The user is typing some text *) + | Selection of selection_state + (** The user is selecting some text *) + | Search of search_state + (** The user is searching the given word in the history *) + + (** An engine state: *) + type state = { + mode : mode; + history : history * history; + (** Cursor to the history position. *) + } + + val init : history -> state + (** [init history] return a initial state using the given + history *) + + val reset : state -> state + (** [reset state] reset the given state, if the user was doing a + selection, it is canceled *) + + val update : engine_state : state -> ?clipboard : clipboard -> command : Command.t -> unit -> state + (** [update ~state ?clipboard ~command ()] update an engine state by + processing the given command. It returns the new state, and + may have the side effect of changing the clipboard contents. + + [clipboard] defaults to the global clipboard. + *) + + val edition_state : state -> edition_state + (** Returns the edition state of a state, whatever its mode is. *) + + val all_input : state -> Text.t + (** Returns the current complete user input. *) +end + +(** Rendering to the terminal *) +module Terminal : sig + + type state + (** State of rendering *) + + val init : state + (** Initial state *) + + (** The following functions are the one used by read-line functions + of this module. *) + + (** Box for the completion: *) + type box = + | Box_none + (** No box at all *) + | Box_empty + (** An empty box *) + | Box_words of text_set * int + (** [BM_words(words, position)] is a box with the given list + of words. [position] is the position of the selected word + in the list.. *) + | Box_message of string + (** A box containing only the given message *) + + val draw : + columns : int -> + ?map_text : (Text.t -> Text.t) -> + ?box : box -> + render_state : state -> + engine_state : Engine.state -> + prompt : prompt -> unit -> Lwt_term.styled_text * state + (** [draw ~column ?map_text ?bar ~render_state ~engine_state + prompt ()] returns [(text, state)] where [state] is the new + rendering state, and [text] is a text containing escape + sequences. When printed, it will update the displayed state. + + @param map_text is a function used to map user input before + printing it, for example to hide passwords. + @param message is a message to display if completion is not + yet available. + @param box defaults to {!Box_none}. *) + + val last_draw : + columns : int -> + ?map_text : (Text.t -> Text.t) -> + render_state : state -> + engine_state : Engine.state -> + prompt : prompt -> unit -> Lwt_term.styled_text + (** Draw for the last time, i.e. the cursor is left after the text + and not at current position. *) + + val erase : columns : int -> render_state : state -> unit -> Lwt_term.styled_text + (** [erase ~columns ~render_state ()] returns a text which will + erase everything (the prompt, user input, completion, ...). + + After an erase, the rendering state is [init]. *) +end + +(** {6 Advanced use} *) + +(** Controlling a running read-line instance *) +module Control : sig + + type 'a t + (** Type of a running read-line instance, returning a value of + type ['a] *) + + (** {6 Control} *) + + val result : 'a t -> 'a Lwt.t + (** Threads waiting for the read-line instance to terminates *) + + val send_command : 'a t -> Command.t -> unit + (** [send_command instance command] sends the given command to the + read-line instance *) + + val accept : 'a t -> unit + (** [accept instance = send_command instance Command.Accept_line] *) + + val interrupt : 'a t -> unit + (** [accept instance = send_command instance Command.Break] *) + + val hide : 'a t -> unit Lwt.t + (** Hides everything (prompt, user input, completion box) until + {!show} is called. *) + + val show : 'a t -> unit Lwt.t + (** Un-hide everything *) + + (** Note: in case the input is not a terminal, read-line instances + are not controllable. i.e. {!accept}, {!refresh}, ... have no + effect. *) + + (** {6 Creation of read-line instances} *) + + type prompt = Engine.state React.signal -> Lwt_term.styled_text React.signal + (** The prompt a signal which may depends on the engine state *) + + type state + (** State of an instance *) + + val engine_state : state -> Engine.state + (** Return the engine state of the given state *) + + val render_state : state -> Terminal.state + (** Return the rendering state of the given state *) + + val make : + ?history : history -> + ?complete : completion -> + ?clipboard : clipboard -> + ?mode : [ completion_mode | `none ] -> + ?map_text : (Text.t -> Text.t) -> + ?filter : (state -> Command.t -> Command.t Lwt.t) -> + map_result : (Text.t -> 'a Lwt.t) -> + ?prompt : prompt -> unit -> 'a t + (** Creates a new read-line instance with the given + parameters. [filter] is called to handle commands. You can + return {!Command.Nop} to drop a command. *) + + (** {6 Predefined instances} *) + + val read_line : + ?history : history -> + ?complete : completion -> + ?clipboard : clipboard -> + ?mode : completion_mode -> + ?prompt : prompt -> unit -> Text.t t Lwt.t + + val read_password : + ?clipboard : clipboard -> + ?style : password_style -> + ?prompt : prompt -> unit -> Text.t t Lwt.t + + val read_keyword : + ?history : history -> + ?case_sensitive : bool -> + ?mode : completion_mode -> + ?prompt : prompt -> + values : (Text.t * 'value) list -> unit -> 'value t Lwt.t + + val read_yes_no : + ?history : history -> + ?mode : completion_mode -> + ?prompt : prompt -> unit -> bool t Lwt.t +end diff --git a/thirdparty/lwt-2.3.2/src/text/lwt_term.ml b/thirdparty/lwt-2.3.2/src/text/lwt_term.ml new file mode 100644 index 0000000..0d0e5e6 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/text/lwt_term.ml @@ -0,0 +1,847 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_term + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt +open Lwt_text + +(* +-----------------------------------------------------------------+ + | Terminal mode | + +-----------------------------------------------------------------+ *) + +type state = + | Normal + | Raw of Unix.terminal_io + +let state = ref Normal + +(* Number of function currently using the raw mode: *) +let raw_count = ref 0 + +let get_attr () = + try_lwt + lwt attr = Lwt_unix.tcgetattr Lwt_unix.stdin in + return (Some attr) + with _ -> + return None + +let set_attr mode = + try_lwt + Lwt_unix.tcsetattr Lwt_unix.stdin Unix.TCSAFLUSH mode + with _ -> + return () + +let drawing_mode = ref false + +let enter_drawing_mode () = + drawing_mode := true; + write stdout "\027[?1049h\027[?1h\027=\r" + +let leave_drawing_mode () = + drawing_mode := false; + write stdout "\r\027[K\027[?1l\027>\027[r\027[?1049l" + +let cursor_visible = ref true + +let show_cursor _ = + cursor_visible := true; + write stdout "\x1B[?25h" + +let hide_cursor _ = + cursor_visible := false; + write stdout "\x1B[?25l" + +let clear_screen _ = + write stdout "\027[2J\027[H" + +let clear_line _ = + write stdout "\027[2K" + +(* Go-up by [n] lines then to the beginning of the line. Normally + "\027[nF" does exactly this but for some terminal 1 need to be + added... By the way we can relly on the fact that all terminal + react the same way to "\027[F" which is to go to the beginning of + the previous line: *) +let rec goto_beginning_of_line = function + | 0 -> + write_char stdout "\r" + | 1 -> + write stdout "\027[F" + | n -> + lwt () = write stdout "\027[F" in + goto_beginning_of_line (n - 1) + +(* Restore terminal mode on exit: *) +let cleanup () = + lwt () = + if not !cursor_visible then + show_cursor () + else + return () + in + lwt () = + if !drawing_mode then + leave_drawing_mode () + else + return () + in + match !state with + | Normal -> + return () + | Raw saved_attr -> + set_attr saved_attr + +let () = Lwt_main.at_exit cleanup + +let raw_mode () = match !state with + | Normal -> false + | Raw _ -> true + +let leave_raw_mode () = + decr raw_count; + if !raw_count = 0 then + match !state with + | Normal -> + assert false + | Raw attr -> + state := Normal; + set_attr attr + else + return () + +let with_raw_mode f = + match !state with + | Raw attr -> + incr raw_count; + finalize f leave_raw_mode + | Normal -> + get_attr () >>= function + | Some attr -> + incr raw_count; + state := Raw attr; + lwt () = set_attr { + attr with + (* Inspired from Python-3.0/Lib/tty.py: *) + Unix.c_brkint = false; + Unix.c_inpck = false; + Unix.c_istrip = false; + Unix.c_ixon = false; + Unix.c_csize = 8; + Unix.c_parenb = false; + Unix.c_echo = false; + Unix.c_icanon = false; + Unix.c_isig = false; + Unix.c_vmin = 1; + Unix.c_vtime = 0 + } in + try_lwt f () finally leave_raw_mode () + | None -> + raise_lwt (Failure "Lwt_term.with_raw_mode: input is not a tty") + +(* +-----------------------------------------------------------------+ + | Terminal informations | + +-----------------------------------------------------------------+ *) + +type size = { + lines : int; + columns : int; +} + +external get_size : Unix.file_descr -> size = "lwt_text_term_size" + +#if windows + +let size = + React.S.const + (try + get_size Unix.stdout + with Unix.Unix_error _ -> + { columns = 80; lines = 25 }) + +#else + +external sigwinch : unit -> int = "lwt_text_sigwinch" +let sigwinch = sigwinch () + +let sigwinch_event = + if sigwinch = 0 then + React.E.never + else + try + let event, push = React.E.create () in + let _ = Lwt_unix.on_signal sigwinch push in + event + with Unix.Unix_error _ | Invalid_argument _ | Sys_error _ -> + React.E.never + +let size = + React.S.hold + (try + get_size Unix.stdin + with Unix.Unix_error _ -> + { columns = 80; lines = 25 }) + (React.E.map (fun _ -> get_size Unix.stdin) sigwinch_event) + +#endif + +let columns = React.S.map (fun { columns = c } -> c) size +let lines = React.S.map (fun { lines = l } -> l) size + +(* +-----------------------------------------------------------------+ + | Keys input | + +-----------------------------------------------------------------+ *) + +exception Exit_sequence + +let parse_escape st = + let buf = Buffer.create 10 in + Buffer.add_char buf '\027'; + (* Read one character and add it to [buf]: *) + let get () = + match Lwt.state (Lwt_stream.get st) with + | Sleep -> + (* If the rest is not immediatly available, conclude that + this is not an escape sequence but just the escape key: *) + raise_lwt Exit_sequence + | Fail exn -> + raise_lwt exn + | Return None -> + raise_lwt Exit_sequence + | Return(Some ch) -> + (* Is it an ascii character ? *) + if String.length ch = 1 then begin + Buffer.add_string buf ch; + return ch.[0] + end else + (* If it is not, then this is not an escape sequence: *) + raise_lwt Exit_sequence + in + + (* Sometimes sequences starts with several escape characters: *) + let rec first count = + get () >>= function + | '\027' when count < 3 -> + first (count + 1) + | ch -> + return ch + in + + first 0 >>= function + | '[' | 'O' -> + let rec loop () = + get () >>= function + | '0' .. '9' | ';' -> + loop () + | ch -> + return (Buffer.contents buf) + in + loop () + + | ch -> + return (Buffer.contents buf) + +let parse_key_raw st = + Lwt_stream.next st >>= function + | "\027" -> + begin + try_lwt + Lwt_stream.parse st parse_escape + with + Exit_sequence -> return "\027" + end + | ch -> + return ch + +type key = + | Key of string + | Key_up + | Key_down + | Key_left + | Key_right + | Key_f of int + | Key_next_page + | Key_previous_page + | Key_home + | Key_end + | Key_insert + | Key_delete + | Key_control of char + +let key_enter = Key_control 'j' +let key_escape = Key_control '[' +let key_tab = Key_control 'i' +let key_backspace = Key_control '?' + +let string_of_key = function + | Key ch -> + Printf.sprintf "Key %S" ch + | Key_f n -> + Printf.sprintf "Key_f %d" n + | Key_control c -> + Printf.sprintf "Key_control %C" c + | Key_up -> + "Key_up" + | Key_down -> + "Key_down" + | Key_left -> + "Key_left" + | Key_right -> + "Key_right" + | Key_next_page -> + "Key_next_page" + | Key_previous_page -> + "Key_previous_page" + | Key_home -> + "Key_home" + | Key_end -> + "Key_end" + | Key_insert -> + "Key_insert" + | Key_delete -> + "Key_delete" + +let sequence_mapping = [ + "\027[A", Key_up; + "\027[B", Key_down; + "\027[C", Key_right; + "\027[D", Key_left; + "\027A", Key_up; + "\027B", Key_down; + "\027C", Key_right; + "\027D", Key_left; + "\027OA", Key_up; + "\027OB", Key_down; + "\027OC", Key_right; + "\027OD", Key_left; + "\027[2~", Key_insert; + "\027[3~", Key_delete; + "\027[5~", Key_previous_page; + "\027[6~", Key_next_page; + "\027[7~", Key_home; + "\027[8~", Key_end; + "\027[11~", Key_f 1; + "\027[12~", Key_f 2; + "\027[13~", Key_f 3; + "\027[14~", Key_f 4; + "\027[15~", Key_f 5; + "\027[17~", Key_f 6; + "\027[18~", Key_f 7; + "\027[19~", Key_f 8; + "\027[20~", Key_f 9; + "\027[21~", Key_f 10; + "\027[23~", Key_f 11; + "\027[24~", Key_f 12; + "\027OP", Key_f 1; + "\027OQ", Key_f 2; + "\027OR", Key_f 3; + "\027OS", Key_f 4; + "\027[H", Key_home; + "\027[F", Key_end; + "\027OH", Key_home; + "\027OF", Key_end; + "\027H", Key_home; + "\027F", Key_end; +] + +let control_mapping = [ + 0x00, '@'; + 0x01, 'a'; + 0x02, 'b'; + 0x03, 'c'; + 0x04, 'd'; + 0x05, 'e'; + 0x06, 'f'; + 0x07, 'g'; + 0x08, 'h'; + 0x09, 'i'; + 0x0A, 'j'; + 0x0B, 'k'; + 0x0C, 'l'; + 0x0D, 'm'; + 0x0E, 'n'; + 0x0F, 'o'; + 0x10, 'p'; + 0x11, 'q'; + 0x12, 'r'; + 0x13, 's'; + 0x14, 't'; + 0x15, 'u'; + 0x16, 'v'; + 0x17, 'w'; + 0x18, 'x'; + 0x19, 'y'; + 0x1A, 'z'; + 0x1B, '['; + 0x1C, '\\'; + 0x1D, ']'; + 0x1E, '^'; + 0x1F, '_'; + 0x7F, '?'; +] + +let decode_key ch = + if ch = "" then invalid_arg "Lwt_term.decode_key"; + match ch with + | ch when String.length ch = 1 -> + begin try + Key_control(List.assoc (Char.code ch.[0]) control_mapping) + with + Not_found -> Key ch + end + | ch -> + begin try + List.assoc ch sequence_mapping + with + Not_found -> Key ch + end + +let standard_input = Lwt_text.read_chars Lwt_text.stdin + +let read_key () = + with_raw_mode (fun _ -> parse_key_raw standard_input >|= decode_key) + +(* +-----------------------------------------------------------------+ + | Styles | + +-----------------------------------------------------------------+ *) + +type color = int + +let default = -1 +let black = 0 +let red = 1 +let green = 2 +let yellow = 3 +let blue = 4 +let magenta = 5 +let cyan = 6 +let white = 7 +let lblack = black + 8 +let lred = red + 8 +let lgreen = green + 8 +let lyellow = yellow + 8 +let lblue = blue + 8 +let lmagenta = magenta + 8 +let lcyan = cyan + 8 +let lwhite = white + 8 + +type style = { + bold : bool; + underlined : bool; + blink : bool; + inverse : bool; + hidden : bool; + foreground : color; + background : color; +} + +module Codes = struct + let reset = 0 + let bold = 1 + let underlined = 4 + let blink = 5 + let inverse = 7 + let hidden = 8 + let foreground col = 30 + col + let background col = 40 + col +end + +let set_color num (r, g, b) = + write stdout (Printf.sprintf "\027]4;%d;rgb:%02x/%02x/%02x;\027\\" num r g b) + +(* +-----------------------------------------------------------------+ + | Rendering | + +-----------------------------------------------------------------+ *) + +type point = { + char : string; + style : style; +} + +let blank = { + char = " "; + style = { + bold = false; + underlined = false; + blink = false; + inverse = false; + hidden = false; + foreground = default; + background = default; + }; +} + +let rec add_int buf = function + | 0 -> + () + | n -> + add_int buf (n / 10); + Buffer.add_char buf (Char.unsafe_chr (48 + (n mod 10))) + +let render_char buf oc pt last_style = + lwt () = + if pt.style <> last_style then begin + Buffer.clear buf; + Buffer.add_string buf "\027[0"; + let mode n = function + | true -> + Buffer.add_char buf ';'; + add_int buf n + | false -> + () + and color f col = + if col = default then + () + else if col < 8 then begin + Buffer.add_char buf ';'; + add_int buf (f col) + end else begin + Buffer.add_char buf ';'; + add_int buf (f 8); + Buffer.add_string buf ";5;"; + add_int buf col; + end + in + mode Codes.bold pt.style.bold; + mode Codes.underlined pt.style.underlined; + mode Codes.blink pt.style.blink; + mode Codes.inverse pt.style.inverse; + mode Codes.hidden pt.style.hidden; + color Codes.foreground pt.style.foreground; + color Codes.background pt.style.background; + Buffer.add_char buf 'm'; + write oc (Buffer.contents buf) + end else + return () + in + write_char oc pt.char + +let render_update old m = + let buf = Buffer.create 16 in + Lwt_text.atomic begin fun oc -> + let rec loop_y y last_style = + if y < Array.length m then + let rec loop_x x last_style = + if x < Array.length m.(y) then + let pt = m.(y).(x) in + lwt () = render_char buf oc pt last_style in + loop_x (x + 1) pt.style + else + loop_y (y + 1) last_style + in + if y < Array.length old && old.(y) = m.(y) then begin + if y + 1 < Array.length m then + lwt last_style = + if Array.length m.(y) > 0 then + let pt = m.(y).(0) in + lwt () = render_char buf oc pt last_style in + return pt.style + else + return last_style + in + lwt () = write oc "\r\n" in + loop_y (y + 1) last_style + else + return () + end else + loop_x 0 last_style + else + return () + in + (* Go to the top-left corner and reset attributes: *) + lwt () = write oc "\027[H\027[0m" in + lwt () = loop_y 0 blank.style in + write oc "\027[0m" + end stdout + +let render m = render_update [||] m + +(* +-----------------------------------------------------------------+ + | Styled text | + +-----------------------------------------------------------------+ *) + +open Printf + +type styled_text_instruction = + | Text of Text.t + | Reset + | Bold + | Underlined + | Blink + | Inverse + | Hidden + | Foreground of color + | Background of color + +type styled_text = styled_text_instruction list + +let textf fmt = Printf.ksprintf (fun txt -> Text txt) fmt +let text txt = Text txt +let reset = Reset +let bold = Bold +let underlined = Underlined +let blink = Blink +let inverse = Inverse +let hidden = Hidden +let fg col = Foreground col +let bg col = Background col + +let strip_styles st = + let buf = Buffer.create 42 in + List.iter (function + | Text t -> Buffer.add_string buf t + | _ -> ()) st; + Buffer.contents buf + +let write_styled oc st = + let buf = Buffer.create 16 + + (* Pendings style codes: *) + and codes = Queue.create () in + + (* Output pending codes using only one escape sequence: *) + let output_pendings () = + Buffer.clear buf; + Buffer.add_string buf "\027["; + add_int buf (Queue.take codes); + Queue.iter (fun code -> + Buffer.add_char buf ';'; + add_int buf code) codes; + Queue.clear codes; + Buffer.add_char buf 'm'; + write oc (Buffer.contents buf) + in + + let rec loop = function + | [] -> + if not (Queue.is_empty codes) then + output_pendings () + else + return () + | instr :: rest -> + match instr with + | Text t -> + if not (Queue.is_empty codes) then + lwt () = output_pendings () in + lwt () = write oc t in + loop rest + else + lwt () = write oc t in + loop rest + | Reset -> + Queue.add 0 codes; + loop rest + | Bold -> + Queue.add Codes.bold codes; + loop rest + | Underlined -> + Queue.add Codes.underlined codes; + loop rest + | Blink -> + Queue.add Codes.blink codes; + loop rest + | Inverse -> + Queue.add Codes.inverse codes; + loop rest + | Hidden -> + Queue.add Codes.hidden codes; + loop rest + | Foreground col -> + if col = default then + Queue.add (Codes.foreground 9) codes + else if col < 8 then + Queue.add (Codes.foreground col) codes + else begin + Queue.add (Codes.foreground 8) codes; + Queue.add 5 codes; + Queue.add col codes + end; + loop rest + | Background col -> + if col = default then + Queue.add (Codes.background 9) codes + else if col < 8 then + Queue.add (Codes.background col) codes + else begin + Queue.add (Codes.background 8) codes; + Queue.add 5 codes; + Queue.add col codes + end; + loop rest + in + loop st + +let styled_length st = + let rec loop len = function + | [] -> len + | Text t :: l -> loop (len + Text.length t) l + | _ :: l -> loop len l + in + loop 0 st + +let printc st = + Lwt_unix.isatty Lwt_unix.stdout >>= function + | true -> + atomic (fun oc -> write_styled oc st) stdout + | false -> + write stdout (strip_styles st) + +let eprintc st = + Lwt_unix.isatty Lwt_unix.stderr >>= function + | true -> + atomic (fun oc -> write_styled oc st) stderr + | false -> + write stderr (strip_styles st) + +let fprintlc oc fd st = + Lwt_unix.isatty fd >>= function + | true -> + atomic (fun oc -> + lwt () = write_styled oc st in + lwt () = write oc "\027[m" in + write_char oc "\n") oc + | false -> + write_line oc (strip_styles st) + +let printlc st = fprintlc stdout Lwt_unix.stdout st +let eprintlc st = fprintlc stderr Lwt_unix.stderr st + +(* +-----------------------------------------------------------------+ + | Drawing | + +-----------------------------------------------------------------+ *) + +module Zone = +struct + type t = { + points : point array array; + x : int; + y : int; + width : int; + height : int; + } + + let points zone = zone.points + let x zone = zone.x + let y zone = zone.y + let width zone = zone.width + let height zone = zone.height + + let make ~width ~height = + if width < 0 || height < 0 then invalid_arg "Lwt_term.Zone.make"; + { + points = Array.make_matrix height width blank; + x = 0; + y = 0; + width = width; + height = height; + } + + let sub ~zone ~x ~y ~width ~height = + if (x < 0 || y < 0 || + width < 0 || height < 0 || + x + width > zone.width || + y + height > zone.height) then + invalid_arg "Lwt_term.Zone.sub"; + { + points = zone.points; + x = zone.x + x; + y = zone.y + y; + width = width; + height = height; + } + + let inner zone = { + points = zone.points; + x = if zone.width >= 2 then zone.x + 1 else zone.x; + y = if zone.height >= 2 then zone.y + 1 else zone.y; + width = if zone.width >= 2 then zone.width - 2 else zone.width; + height = if zone.height >= 2 then zone.height - 2 else zone.height; + } +end + +module Draw = +struct + open Zone + + let get ~zone ~x ~y = + if x < 0 || y < 0 || x >= zone.width || y >= zone.height then + invalid_arg "Lwt_term.Draw.get"; + zone.points.(zone.y + y).(zone.x + x) + + let set ~zone ~x ~y ~point = + if x < 0 || y < 0 || x >= zone.width || y >= zone.height then + () + else + zone.points.(zone.y + y).(zone.x + x) <- point + + let map ~zone ~x ~y f = + if x < 0 || y < 0 || x >= zone.width || y >= zone.height then + () + else + let x = zone.x + x and y = zone.y + y in + zone.points.(y).(x) <- f zone.points.(y).(x) + + let text ~zone ~x ~y ~text = + let rec loop x ptr = match Text.next ptr with + | Some(ch, ptr) -> + set zone x y { blank with char = ch }; + loop (x + 1) ptr + | None -> + () + in + loop x (Text.pointer_l text) + + let textf zone x y fmt = + Printf.ksprintf (fun txt -> text zone x y txt) fmt + + let textc ~zone ~x ~y ~text = + let rec loop style x = function + | [] -> + () + | instr :: rest -> + match instr with + | Text text -> + loop_text style x (Text.pointer_l text) rest + | Reset -> + loop blank.style x rest + | Bold -> + loop { style with bold = true } x rest + | Underlined -> + loop { style with underlined = true } x rest + | Blink -> + loop { style with blink = true } x rest + | Inverse -> + loop { style with inverse = true } x rest + | Hidden -> + loop { style with hidden = true } x rest + | Foreground color -> + loop { style with foreground = color } x rest + | Background color -> + loop { style with background = color } x rest + and loop_text style x ptr rest = + match Text.next ptr with + | Some(ch, ptr) -> + set zone x y { char = ch; style = style }; + loop_text style (x + 1) ptr rest + | None -> + loop style x rest + in + loop blank.style x text +end diff --git a/thirdparty/lwt-2.3.2/src/text/lwt_term.mli b/thirdparty/lwt-2.3.2/src/text/lwt_term.mli new file mode 100644 index 0000000..7022a9d --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/text/lwt_term.mli @@ -0,0 +1,393 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_term + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Terminal control *) + +(** This modules allow you to write interactive programs using the + terminal. *) + +val with_raw_mode : (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [with_raw_mode f] executes [f] while the terminal is in ``raw + mode''. Raw mode means that character are returned as the user + type them (otherwise only complete line are returned to the + program). + + If the terminal is already in raw mode, it just calls [f]. *) + +val raw_mode : unit -> bool + (** Returns wether the terminal is currently in raw mode *) + +val enter_drawing_mode : unit -> unit Lwt.t + (** Put the terminal into drawing mode *) + +val leave_drawing_mode : unit -> unit Lwt.t + (** Restore the state of the terminal *) + +val show_cursor : unit -> unit Lwt.t + (** [show_cursor ()] makes the cursor visible *) + +val hide_cursor : unit -> unit Lwt.t + (** [hide_cursor ()] makes the cursor invisible *) + +val clear_screen : unit -> unit Lwt.t + (** [clear_screen ()] clears the entire screen *) + +val clear_line : unit -> unit Lwt.t + (** [clear_line ()] clears the current line *) + +val goto_beginning_of_line : int -> unit Lwt.t + (** [goto_beginning_of_line n] put the cursor at the beginning of + the [n]th previous line. + + - [goto_beginning_of_line 0] goes to the beginning of the current line + - [goto_beginning_of_line 1] goes to the beginning of the previous line + - ... + *) + +(** {6 Terminal informations} *) + +(** Terminal sizes: *) +type size = { + lines : int; + columns : int; +} + +val size : size React.signal + (** Size of the terminal. *) + +val columns : int React.signal + (** Number of columns of the terminal *) + +val lines : int React.signal + (** Number of lines of the terminal *) + +(** {6 Keys} *) + +val parse_key_raw : Text.t Lwt_stream.t -> Text.t Lwt.t + (** [parse_key_raw st] recognize escape sequence in a stream of + unicode character. + + It returns either: + - either single characters, like ["a"], ["é"], ... + - either escape sequences + *) + +(** Type of ``decoded'' keys. + + This list is not exhaustive, but at least it should works on all + terminals: *) +type key = + | Key of Text.t + (** A unicode character or an uninterpreted sequence *) + | Key_up + | Key_down + | Key_left + | Key_right + | Key_f of int + | Key_next_page + | Key_previous_page + | Key_home + | Key_end + | Key_insert + | Key_delete + | Key_control of char + (** A control key *) + +val string_of_key : key -> string + (** [string_of_key key] string representation of a key *) + +val control_mapping : (int * char) list + (** Mapping from control key codes to character codes. + + Here is the list of control keys: + + {[ + +------+-------+------+------+------+-------+------------------------------------------------+ + | Char | Oct | Dec | Name | Hex | Key | Comment | + +------+-------+------+------+------+-------+------------------------------------------------+ + | '@' | 0o00 | 0 | NUL | 0x00 | ^@ \0 | Null byte | + | 'a' | 0o01 | 1 | SOH | 0x01 | ^A | Start of heading | + | 'b' | 0o02 | 2 | STX | 0x02 | ^B | Start of text | + | 'c' | 0o03 | 3 | ETX | 0x03 | ^C | End of text | + | 'd' | 0o04 | 4 | EOT | 0x04 | ^D | End of transmission | + | 'e' | 0o05 | 5 | ENQ | 0x05 | ^E | Enquiry | + | 'f' | 0o06 | 6 | ACK | 0x06 | ^F | Acknowledge | + | 'g' | 0o07 | 7 | BEL | 0x07 | ^G | Ring terminal bell | + | 'h' | 0o10 | 8 | BS | 0x08 | ^H \b | Backspace | + | 'i' | 0o11 | 9 | HT | 0x09 | ^I \t | Horizontal tab | + | 'j' | 0o12 | 10 | LF | 0x0a | ^J \n | Line feed | + | 'k' | 0o13 | 11 | VT | 0x0b | ^K | Vertical tab | + | 'l' | 0o14 | 12 | FF | 0x0c | ^L \f | Form feed | + | 'm' | 0o15 | 13 | CR | 0x0d | ^M \r | Carriage return | + | 'n' | 0o16 | 14 | SO | 0x0e | ^N | Shift out | + | 'o' | 0o17 | 15 | SI | 0x0f | ^O | Shift in | + | 'p' | 0o20 | 16 | DLE | 0x10 | ^P | Data link escape | + | 'q' | 0o21 | 17 | DC1 | 0x11 | ^Q | Device control 1 (XON) | + | 'r' | 0o22 | 18 | DC2 | 0x12 | ^R | Device control 2 | + | 's' | 0o23 | 19 | DC3 | 0x13 | ^S | Device control 3 (XOFF) | + | 't' | 0o24 | 20 | DC4 | 0x14 | ^T | Device control 4 | + | 'u' | 0o25 | 21 | NAK | 0x15 | ^U | Negative acknowledge | + | 'v' | 0o26 | 22 | SYN | 0x16 | ^V | Synchronous idle | + | 'w' | 0o27 | 23 | ETB | 0x17 | ^W | End of transmission block | + | 'x' | 0o30 | 24 | CAN | 0x18 | ^X | Cancel | + | 'y' | 0o31 | 25 | EM | 0x19 | ^Y | End of medium | + | 'z' | 0o32 | 26 | SUB | 0x1a | ^Z | Substitute character | + | '[' | 0o33 | 27 | ESC | 0x1b | ^[ | Escape | + | '\' | 0o34 | 28 | FS | 0x1c | ^\ | File separator, Information separator four | + | ']' | 0o35 | 29 | GS | 0x1d | ^] | Group separator, Information separator three | + | '^' | 0o36 | 30 | RS | 0x1e | ^^ | Record separator, Information separator two | + | '_' | 0o37 | 31 | US | 0x1f | ^_ | Unit separator, Information separator one | + | '?' | 0o177 | 127 | DEL | 0x7f | ^? | Delete | + +------+-------+------+------+------+-------+------------------------------------------------+ + ]} + *) + +val key_enter : key + (** [key_enter = Key_control 'j'] *) + +val key_escape : key + (** [key_escape = Key_control '\['] *) + +val key_tab : key + (** [key_escape = Key_control 'i'] *) + +val key_backspace : key + (** [key_backspace = Key_control '?'] *) + +val sequence_mapping : (Text.t * key) list + (** Mapping from sequence to keys *) + +val decode_key : Text.t -> key + (** Decode a key. *) + +val standard_input : Text.t Lwt_stream.t + (** The input stream used by {!read_key} *) + +val read_key : unit -> key Lwt.t + (** Get and decode a key from {!standard_input} *) + +(** {6 Styles} *) + +type color = int + (** Type of a color. Most modern terminals support either 88 or + 256 colors. *) + +val set_color : color -> int * int * int -> unit Lwt.t + (** [set_color num (red, green, blue)] sets the three components of + the color number [num] *) + +(** {8 Standard colors} *) + +val default : color +val black : color +val red : color +val green : color +val yellow : color +val blue : color +val magenta : color +val cyan : color +val white : color + +(** {8 Light colors} *) + +(** Note: these colors are not supposed to works on all terminals, but + in practice it works with all modern ones. By the way, using + standard colors + bold mode will give the same result as using a + light color. *) + +val lblack : color +val lred : color +val lgreen : color +val lyellow : color +val lblue : color +val lmagenta : color +val lcyan : color +val lwhite : color + +(** {8 Text with styles} *) + +(** Elmement of a styled-text *) +type styled_text_instruction = + | Text of Text.t + (** Some text *) + | Reset + (** Resets all styles to default *) + | Bold + | Underlined + | Blink + | Inverse + | Hidden + | Foreground of color + | Background of color + +type styled_text = styled_text_instruction list + (** A styled text is a list of instructions *) + +val textf : ('a, unit, string, styled_text_instruction) format4 -> 'a + (** [textf fmt] formats a texts with [fmt] and returns [Text txt] *) + +val text : Text.t -> styled_text_instruction +val reset : styled_text_instruction +val bold : styled_text_instruction +val underlined : styled_text_instruction +val blink : styled_text_instruction +val inverse : styled_text_instruction +val hidden : styled_text_instruction + +val fg : color -> styled_text_instruction + (** [fg col = Foreground col] *) + +val bg : color -> styled_text_instruction + (** [bg col = Background col] *) + +val strip_styles : styled_text -> Text.t + (** Drop all styles *) + +val styled_length : styled_text -> int + (** Returns the length (in unicode character) of the given styled + text. The following equality holds for all styled-texts: + + [styled_length st = Text.length (strip_styles st)] + *) + +val write_styled : Lwt_text.output_channel -> styled_text -> unit Lwt.t + (** [write_styled oc st] writes [st] on [oc] using escape + sequences. *) + +val printc : styled_text -> unit Lwt.t + (** [printc st] prints the given styled text on standard output. If + stdout is not a tty, then styles are stripped. + + The text is encoded to the system encoding before being + output. *) + +val eprintc : styled_text -> unit Lwt.t + (** Same as [printc] but prints on stderr. *) + +val printlc : styled_text -> unit Lwt.t + (** [printlc st] prints [st], then reset styles and prints a + newline *) + +val eprintlc : styled_text -> unit Lwt.t + (** Same as [printlc] but prints on stderr *) + +(** {6 Rendering} *) + +(** Character styles *) +type style = { + bold : bool; + underlined : bool; + blink : bool; + inverse : bool; + hidden : bool; + foreground : color; + background : color; +} + +(** A character on the screen: *) +type point = { + char : Text.t; + (** The character. *) + style : style; + (** The character style *) +} + +val blank : point + (** A space with default color and styles *) + +val render : point array array -> unit Lwt.t + (** Render an offscreen array to the terminal. *) + +val render_update : point array array -> point array array -> unit Lwt.t + (** [render_update displayed to_display] does the same as [render + to_display] but assumes that [displayed] contains the current + displayed text. This reduces the amount of text sent to the + terminal. *) + +(** {6 Drawing} *) + +(** Off-screen zones *) +module Zone : sig + type t = { + points : point array array; + (** The off-screen matrix *) + + x : int; + y : int; + (** Absolute coordinates of the top-left corner of the zone *) + + width : int; + height : int; + (** Dimmensions of the zone *) + } + + val points : t -> point array array + val x : t -> int + val y : t -> int + val width : t -> int + val height : t -> int + + val make : width : int -> height : int -> t + (** Make a new zone where all points are initialized to + {!blank} *) + + val sub : zone : t -> x : int -> y : int -> width : int -> height : int -> t + (** [sub ~zone ~x ~y ~width ~height] creates a sub-zone of + [zone]. [x] and [y] are relatives to the zone top left corner. + + @raise Invalid_argument if the sub zone is not included in + [zone]*) + + val inner : t -> t + (** [inner zone] returns the inner part of [zone] *) +end + +(** Drawing helpers *) +module Draw : sig + + (** Note: except for {!get}, all function ignore points that are + outside the zone *) + + val get : zone : Zone.t -> x : int -> y : int -> point + (** [get ~zone ~x ~y] returns the point at relative position [x] + and [y]. + + @raise Invalid_argument if the coordinates are outside the + zone *) + + val set : zone : Zone.t -> x : int -> y : int -> point : point -> unit + (** [set ~zone ~x ~y ~popint] sets point at relative position [x] + and [y]. *) + + val map : zone : Zone.t -> x : int -> y : int -> (point -> point) -> unit + (** [map ~zone ~x ~y f] replace the point at coordinates [(x, y)] + by the result of [f] applied on it. *) + + val text : zone : Zone.t -> x : int -> y : int -> text : Text.t -> unit + (** Draw the given text at the given positon *) + + val textf : Zone.t -> int -> int -> ('a, unit, string, unit) format4 -> 'a + (** Same as {!text} but uses a format string *) + + val textc : zone : Zone.t -> x : int -> y : int -> text : styled_text -> unit + (** Same as {!text} but takes a text with styles *) +end diff --git a/thirdparty/lwt-2.3.2/src/text/lwt_text.ml b/thirdparty/lwt-2.3.2/src/text/lwt_text.ml new file mode 100644 index 0000000..9d808c4 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/text/lwt_text.ml @@ -0,0 +1,337 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_text + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt +open Lwt_io + +(* +-----------------------------------------------------------------+ + | Types and creation | + +-----------------------------------------------------------------+ *) + +type coder = + | Encoder of Encoding.encoder + | Decoder of Encoding.decoder + +type 'a channel = { + channel : 'a Lwt_io.channel; + encoding : Text.t; + coder : coder; + strict : bool; +} + +type input_channel = Lwt_io.input channel +type output_channel = Lwt_io.output channel + +let encoder = function + | Encoder e -> e + | Decoder _ -> assert false + +let decoder = function + | Encoder _ -> assert false + | Decoder d -> d + +#if ocaml_version >= (3, 13) +let make : type m. ?strict : bool -> ?encoding : string -> m Lwt_io.channel -> m channel = fun ?(strict=false) ?(encoding=Encoding.system) ch -> +#else +let make ?(strict=false) ?(encoding=Encoding.system) ch = +#endif + { channel = ch; + encoding = encoding; + strict = strict; + coder = match Lwt_io.mode ch with + | Input -> + Decoder(Encoding.decoder encoding) + | Output -> + Encoder(Encoding.encoder(if strict then encoding else encoding ^ "//TRANSLIT")) } + +let byte_channel ch = ch.channel +let encoding ch = ch.encoding + +let close ch = Lwt_io.close ch.channel +let flush ch = Lwt_io.flush ch.channel + +let atomic f ch = Lwt_io.atomic (fun ch' -> f { ch with channel = ch' }) ch.channel + +let open_file ?buffer_size ?strict ?encoding ?flags ?perm ~mode name = + lwt ch = Lwt_io.open_file ?flags ?perm ~mode name in + return (make ?strict ?encoding ch) + +let with_file ?buffer_size ?strict ?encoding ?flags ?perm ~mode name f = + Lwt_io.with_file ?flags ?perm ~mode name (fun ch -> f (make ?strict ?encoding ch)) + +module Primitives = +struct + (* +---------------------------------------------------------------+ + | Primitives for reading | + +---------------------------------------------------------------+ *) + + let rec read_char da strict decoder = + let ptr = da.da_ptr and max = da.da_max in + if ptr = max then + da.da_perform () >>= function + | 0 -> raise_lwt End_of_file + | _ -> read_char da strict decoder + else + match Encoding_bigarray.decode decoder da.da_buffer ptr (max - ptr) with + | Encoding.Dec_ok(code, count) -> + da.da_ptr <- ptr + count; + return (Text.char code) + | Encoding.Dec_need_more -> + da.da_perform () >>= begin function + | 0 -> + if strict then + raise_lwt (Failure "Lwt_text.read_char: unterminated multibyte sequence") + else begin + da.da_ptr <- ptr + 1; + return (Text.char (Char.code da.da_buffer.{ptr})) + end + | _ -> + read_char da strict decoder + end + | Encoding.Dec_error -> + if strict then + raise_lwt (Failure "Lwt_text.read_char: unterminated multibyte sequence") + else begin + da.da_ptr <- ptr + 1; + return (Text.char (Char.code da.da_buffer.{ptr})) + end + + let read_char_opt da strict decoder = + try_lwt + read_char da strict decoder >|= fun ch -> Some ch + with + | End_of_file -> + return None + | exn -> + raise_lwt exn + + let rec read_all da strict decoder buf = + lwt ch = read_char da strict decoder in + Buffer.add_string buf ch; + read_all da strict decoder buf + + let rec read_count da strict decoder buf = function + | 0 -> + return (Buffer.contents buf) + | n -> + lwt ch = read_char da strict decoder in + Buffer.add_string buf ch; + read_count da strict decoder buf (n - 1) + + let read count da strict decoder = match count with + | None -> + let buf = Buffer.create 512 in + begin + try_lwt + read_all da strict decoder buf + with + | End_of_file -> + return (Buffer.contents buf) + end + | Some 0 -> + return "" + | Some 1 -> + begin + try_lwt + read_char da strict decoder + with + | End_of_file -> + return "" + end + | Some len -> + let buf = Buffer.create len in + begin + try_lwt + read_count da strict decoder buf len + with + | End_of_file -> + return (Buffer.contents buf) + end + + let read_line da strict decoder = + let buf = Buffer.create 128 in + let rec loop cr_read = + try_bind (fun _ -> read_char da strict decoder) + (function + | "\n" -> + return(Buffer.contents buf) + | "\r" -> + if cr_read then Buffer.add_char buf '\r'; + loop true + | ch -> + if cr_read then Buffer.add_char buf '\r'; + Buffer.add_string buf ch; + loop false) + (function + | End_of_file -> + if cr_read then Buffer.add_char buf '\r'; + return(Buffer.contents buf) + | exn -> + raise_lwt exn) + in + read_char da strict decoder >>= function + | "\r" -> loop true + | "\n" -> return "" + | ch -> Buffer.add_string buf ch; loop false + + let read_line_opt da strict decoder = + try_lwt + read_line da strict decoder >|= fun ch -> Some ch + with + | End_of_file -> + return None + | exn -> + raise_lwt exn + + (* +---------------------------------------------------------------+ + | Primitives for writing | + +---------------------------------------------------------------+ *) + + let rec write_code da encoder code = + match Encoding_bigarray.encode encoder da.da_buffer da.da_ptr (da.da_max - da.da_ptr) code with + | Encoding.Enc_ok count -> + da.da_ptr <- da.da_ptr + count; + return () + | Encoding.Enc_need_more -> + lwt _ = da.da_perform () in + write_code da encoder code + | Encoding.Enc_error -> + raise_lwt (Failure "Lwt_text: cannot encode character") + + let byte str pos = Char.code (String.unsafe_get str pos) + + let next_code str i len = + let n = byte str i in + let rec trail j acc = function + | 0 -> + (j, acc) + | count -> + if j = len then + (i + 1, n) + else + let m = byte str j in + if m land 0xc0 = 0x80 then + trail (j + 1) ((acc lsl 6) lor (m land 0x3f)) (count - 1) + else + (i + 1, n) + in + if n land 0x80 = 0 then + (i + 1, n) + else if n land 0xe0 = 0xc0 then + trail (i + 1) (n land 0x1f) 1 + else if n land 0xf0 = 0xe0 then + trail (i + 1) (n land 0x0f) 2 + else if n land 0xf8 = 0xf0 then + trail (i + 1) (n land 0x07) 3 + else + (i + 1, n) + + let write_char da strict encoder = function + | "" -> + raise_lwt (Invalid_argument "Lwt_text.write_char: empty text") + | ch -> + let _, code = next_code ch 0 (String.length ch) in + write_code da encoder code + + let rec write_all da strict encoder str i len = + if i = len then + return () + else + let i, code = next_code str i len in + lwt () = write_code da encoder code in + write_all da strict encoder str i len + + let write da strict encoder txt = + write_all da strict encoder txt 0 (String.length txt) + + let write_line da strict encoder txt = + lwt () = write_all da strict encoder txt 0 (String.length txt) in + write_code da encoder 10 +end + +let read_char ic = direct_access ic.channel (fun da -> Primitives.read_char da ic.strict (decoder ic.coder)) +let read_char_opt ic = direct_access ic.channel (fun da -> Primitives.read_char_opt da ic.strict (decoder ic.coder)) +let read ?count ic = direct_access ic.channel (fun da -> Primitives.read count da ic.strict (decoder ic.coder)) +let read_line ic = direct_access ic.channel (fun da -> Primitives.read_line da ic.strict (decoder ic.coder)) +let read_line_opt ic = direct_access ic.channel (fun da -> Primitives.read_line_opt da ic.strict (decoder ic.coder)) +let read_chars ic = Lwt_stream.from (fun _ -> read_char_opt ic) +let read_lines ic = Lwt_stream.from (fun _ -> read_line_opt ic) + +let write_char oc x = direct_access oc.channel (fun da -> Primitives.write_char da oc.strict (encoder oc.coder) x) +let write_line oc x = direct_access oc.channel (fun da -> Primitives.write_line da oc.strict (encoder oc.coder) x) +let write oc x = direct_access oc.channel (fun da -> Primitives.write da oc.strict (encoder oc.coder) x) +let write_chars oc st = Lwt_stream.iter_s (write_char oc) st +let write_lines oc st = Lwt_stream.iter_s (write_line oc) st + +let stdin = make Lwt_io.stdin +let stdout = make Lwt_io.stdout +let stderr = make Lwt_io.stderr +let null = make Lwt_io.null +let zero = make Lwt_io.zero + +let fprint oc txt = write oc txt +let fprintl oc txt = write_line oc txt +let fprintf oc fmt = Printf.ksprintf (fun txt -> write oc txt) fmt +let fprintlf oc fmt = Printf.ksprintf (fun txt -> write_line oc txt) fmt + +let print txt = write stdout txt +let printl txt = write_line stdout txt +let printf fmt = Printf.ksprintf print fmt +let printlf fmt = Printf.ksprintf printl fmt + +let eprint txt = write stderr txt +let eprintl txt = write_line stderr txt +let eprintf fmt = Printf.ksprintf eprint fmt +let eprintlf fmt = Printf.ksprintf eprintl fmt + +let ignore_close ch = + ignore (close ch) + +let make_stream f lazy_ic = + let lazy_ic = + lazy(lwt ic = Lazy.force lazy_ic in + Gc.finalise ignore_close ic; + return ic) + in + Lwt_stream.from (fun _ -> + lwt ic = Lazy.force lazy_ic in + try_lwt + f ic >|= fun x -> Some x + with + | End_of_file -> + lwt () = close ic in + return None) + +let lines_of_file filename = + make_stream read_line (lazy(open_file ~mode:input filename)) + +let lines_to_file filename lines = + with_file ~mode:output filename (fun oc -> write_lines oc lines) + +let chars_of_file filename = + make_stream read_char (lazy(open_file ~mode:input filename)) + +let chars_to_file filename chars = + with_file ~mode:output filename (fun oc -> write_chars oc chars) + +let hexdump_stream oc stream = write_lines oc (Lwt_stream.hexdump stream) +let hexdump oc buf = hexdump_stream oc (Lwt_stream.of_string buf) diff --git a/thirdparty/lwt-2.3.2/src/text/lwt_text.mli b/thirdparty/lwt-2.3.2/src/text/lwt_text.mli new file mode 100644 index 0000000..5b0e183 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/text/lwt_text.mli @@ -0,0 +1,128 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_text + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Text channels *) + +(** This modules implements {b text channel}s. A {b text channel} is + basically a {b byte channel} (as in {!Lwt_io}) plus a {b character + encoding}. + + It has almost the same interface as {!Lwt_io} except that it + uses [Text.t] in place of [string] and [char] +*) + +open Lwt_io + +(** {6 Types} *) + +type 'mode channel + (** Type of a text channel *) + +type input_channel = input channel + (** Type of a text input channel *) + +type output_channel = output channel + (** Type of a text output channel *) + +(** {6 Creation/manipulation} *) + +val make : ?strict : bool -> ?encoding : Encoding.t -> 'a Lwt_io.channel -> 'a channel + (** [make ?strict ?encoding ch] creates a text channel from a byte + channel. + + @param strict tell whether encoding/decoding must be ``strict'', + which whether the encoder/decoder should fail on invalid + sequence. In non-strict mode, it transparently fallback to + ISO-8859-15. By the way it is ensured that [read*] functions + always returns valid UTF-8 encoded text. [strict] defaults to + [false]. + + @param encoding is the character encoding used for the + channel. It defaults to [Encoding.system]. *) + +val byte_channel : 'a channel -> 'a Lwt_io.channel + (** [byte_channel ch] returns the underlying byte channel of a text + channel *) + +val encoding : 'a channel -> Encoding.t + (** [encoding ch] returns the character encoding of a channel. *) + +val flush : output_channel -> unit Lwt.t + (** Flush the underlying byte channel *) + +val close : 'a channel -> unit Lwt.t + (** Close the underlying byte channel *) + +(** {6 Lwt_io like values} *) + +val atomic : ('a channel -> 'b Lwt.t) -> ('a channel -> 'b Lwt.t) +val stdin : input_channel +val stdout : output_channel +val stderr : output_channel +val zero : input_channel +val null : output_channel +val read_char : input_channel -> Text.t Lwt.t +val read_char_opt : input_channel -> Text.t option Lwt.t +val read_chars : input_channel -> Text.t Lwt_stream.t +val read_line : input_channel -> Text.t Lwt.t +val read_line_opt : input_channel -> Text.t option Lwt.t +val read_lines : input_channel -> Text.t Lwt_stream.t +val read : ?count : int -> input_channel -> Text.t Lwt.t +val write_char : output_channel -> Text.t -> unit Lwt.t +val write_chars : output_channel -> Text.t Lwt_stream.t -> unit Lwt.t +val write : output_channel -> Text.t -> unit Lwt.t +val write_line : output_channel -> Text.t -> unit Lwt.t +val write_lines : output_channel -> Text.t Lwt_stream.t -> unit Lwt.t +val open_file : + ?buffer_size : int -> + ?strict : bool -> + ?encoding : Encoding.t -> + ?flags : Unix.open_flag list -> + ?perm : Unix.file_perm -> + mode : 'a mode -> + file_name -> 'a channel Lwt.t +val with_file : + ?buffer_size : int -> + ?strict : bool -> + ?encoding : Encoding.t -> + ?flags : Unix.open_flag list -> + ?perm : Unix.file_perm -> + mode : 'a mode -> + file_name -> ('a channel -> 'b Lwt.t) -> 'b Lwt.t +val lines_of_file : file_name -> Text.t Lwt_stream.t +val lines_to_file : file_name -> Text.t Lwt_stream.t -> unit Lwt.t +val chars_of_file : file_name -> Text.t Lwt_stream.t +val chars_to_file : file_name -> Text.t Lwt_stream.t -> unit Lwt.t +val fprint : output_channel -> Text.t -> unit Lwt.t +val fprintl : output_channel -> Text.t -> unit Lwt.t +val fprintf : output_channel -> ('a, unit, Text.t, unit Lwt.t) format4 -> 'a +val fprintlf : output_channel -> ('a, unit, Text.t, unit Lwt.t) format4 -> 'a +val print : Text.t -> unit Lwt.t +val printl : Text.t -> unit Lwt.t +val printf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a +val printlf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a +val eprint : Text.t -> unit Lwt.t +val eprintl : Text.t -> unit Lwt.t +val eprintf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a +val eprintlf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a +val hexdump_stream : output_channel -> char Lwt_stream.t -> unit Lwt.t +val hexdump : output_channel -> string -> unit Lwt.t diff --git a/thirdparty/lwt-2.3.2/src/text/lwt_text_stubs.c b/thirdparty/lwt-2.3.2/src/text/lwt_text_stubs.c new file mode 100644 index 0000000..3e2a929 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/text/lwt_text_stubs.c @@ -0,0 +1,84 @@ +/* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_text_stubs + * Copyright (C) 2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + */ + +#if defined(_WIN32) || defined(_WIN64) +# include +# include +#else +# include +# include +# include +# include +#endif + +#include "../unix/lwt_unix.h" + +#include +#include + +/* +-----------------------------------------------------------------+ + | Terminal sizes | + +-----------------------------------------------------------------+ */ + +#if defined(LWT_ON_WINDOWS) + +CAMLprim value lwt_text_term_size(value fd) +{ + HANDLE handle; + CONSOLE_SCREEN_BUFFER_INFO info; + + if (!GetConsoleScreenBufferInfo(Handle_val(fd), &info)) { + win32_maperr(GetLastError()); + uerror("GetConsoleScreenBufferInfo", Nothing); + } + + value result = caml_alloc_tuple(2); + Field(result, 0) = Val_int(info.dwSize.X); + Field(result, 1) = Val_int(info.dwSize.Y); + return result; +} + +#else + +CAMLprim value lwt_text_term_size(value fd) +{ + struct winsize size; + + if (ioctl(Int_val(fd), TIOCGWINSZ, &size) < 0) + uerror("ioctl", Nothing); + + value result = caml_alloc_tuple(2); + Field(result, 0) = Val_int(size.ws_row); + Field(result, 1) = Val_int(size.ws_col); + return result; +} + +CAMLprim value lwt_text_sigwinch() +{ +#ifdef SIGWINCH + return Val_int(SIGWINCH); +#else + return Val_int(0); +#endif +} + +#endif diff --git a/thirdparty/lwt-2.3.2/src/top/lwt-top.mllib b/thirdparty/lwt-2.3.2/src/top/lwt-top.mllib new file mode 100644 index 0000000..c8314f9 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/top/lwt-top.mllib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 6aba40695d6f4091d2063c4b620ae589) +Lwt_top +Lwt_ocaml_completion +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/top/lwt_ocaml_completion.mll b/thirdparty/lwt-2.3.2/src/top/lwt_ocaml_completion.mll new file mode 100644 index 0000000..e50a3ac --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/top/lwt_ocaml_completion.mll @@ -0,0 +1,194 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_ocaml_completion + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +{ + open Toploop + open Lwt + open Lwt_read_line + + module TextSet = Set.Make(Text) + + let set_of_list = List.fold_left (fun set x -> TextSet.add x set) TextSet.empty + + let keywords = set_of_list [ + "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; + "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; + "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; + "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; + "mutable"; "new"; "object"; "of"; "open"; "private"; "rec"; "sig"; + "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; + "when"; "while"; "with"; "try_lwt"; "finally"; "for_lwt"; "lwt"; + ] + + let get_directives () = + Hashtbl.fold (fun k v set -> TextSet.add k set) Toploop.directive_table TextSet.empty + + let complete_ident = ref (fun before ident after -> complete ~suffix:"" before ident after keywords) + let restart = ref (fun () -> ()) + + let list_files filter fname = + let dir = Filename.dirname fname in + Array.fold_left (fun set name -> + let absolute_name = Filename.concat dir name in + if try Sys.is_directory absolute_name with _ -> false then + TextSet.add (Filename.concat name "") set + else if filter name then + TextSet.add name set + else + set) + TextSet.empty + (Sys.readdir (if dir = "" then Filename.current_dir_name else dir)) + + let list_directories fname = + let dir = Filename.dirname fname in + Array.fold_left (fun set name -> + let name = Filename.concat dir name in + if try Sys.is_directory name with _ -> false then + TextSet.add name set + else + set) + TextSet.empty + (Sys.readdir (if dir = "" then Filename.current_dir_name else dir)) +} + +let lower = ['a'-'z'] +let upper = ['A'-'Z'] +let alpha = lower | upper +let digit = ['0'-'9'] +let alnum = alpha | digit +let punct = ['!' '"' '#' '$' '%' '&' '\'' '(' ')' '*' '+' ',' '-' '.' '/' ':' ';' '<' '=' '>' '?' '@' '[' '\\' ']' '^' '_' '`' '{' '|' '}' '~'] +let graph = alnum | punct +let print = graph | ' ' +let blank = ' ' | '\t' +let cntrl = ['\x00'-'\x1F' '\x7F'] +let xdigit = digit | ['a'-'f' 'A'-'F'] +let space = blank | ['\n' '\x0b' '\x0c' '\r'] + +let uchar = ['\x00' - '\x7f'] | _ [ '\x80' - '\xbf' ]* + +let identstart = [ 'A'-'Z' 'a'-'z' '_' ] +let identbody = [ 'A'-'Z' 'a'-'z' '_' '\'' '0' - '9' ] +let ident = identstart identbody* +let maybe_ident = "" | ident + +(* Parse a line of input. [before] correspond to the input before the + cursor and [after] to the input after the cursor. The lexing buffer + is created from [before]. *) + +rule complete_input before after = parse + + (* Completion over directives *) + | (blank* '#' blank* as before') (maybe_ident as dir) (blank* as bl) eof { + if Hashtbl.mem Toploop.directive_table dir then + return (match Hashtbl.find Toploop.directive_table dir with + | Directive_none _ -> + { comp_state = (before ^ ";;", after); + comp_words = TextSet.empty } + | Directive_string _ -> + { comp_state = (before ^ (if bl = "" then " \"" else "\""), after); + comp_words = TextSet.empty } + | Directive_bool _ -> + { comp_state = ((if bl = "" then before ^ " " else ""), after); + comp_words = set_of_list ["false"; "true"] } + | Directive_int _ | Directive_ident _ -> + { comp_state = ((if bl = "" then before ^ " " else ""), after); + comp_words = TextSet.empty }) + else + return (match lookup dir (get_directives ()) with + | (_, words) when TextSet.is_empty words -> + { comp_state = (before, after); + comp_words = TextSet.empty } + | (prefix, words) -> + if bl = "" then + { comp_state = (before' ^ prefix, after); + comp_words = words } + else + { comp_state = (before, after); + comp_words = TextSet.empty }) + } + + (* Completion on directive argument *) + | (blank* '#' blank* (ident as dir) blank* as before') (ident as arg) eof { + return (match try Some(Hashtbl.find directive_table dir) with Not_found -> None with + | Some (Directive_bool _) -> + complete ~suffix:";;" before' arg after (set_of_list ["false"; "true"]) + | _ -> + { comp_state = (before, after); + comp_words = TextSet.empty }) + } + + (* Completion on packages *) + | (blank* '#' blank* "require" blank* '"' as before) ([^'"']* as package) eof { + return (complete ~suffix:"\";;" before package after (set_of_list (Fl_package_base.list_packages ()))) + } + + (* Completion on files *) + | (blank* '#' blank* "load" blank* '"' as before) ([^'"']* as fname) eof { + let list = list_files (fun name -> + Filename.check_suffix name ".cma" || Filename.check_suffix name ".cmo") fname in + return (complete ~suffix:"" before fname after list) + } + + | (blank* '#' blank* "use" blank* '"' as before) ([^'"']* as fname) eof { + let list = list_files (fun _ -> true) fname in + return (complete ~suffix:"" before fname after list) + } + + (* Completion on directories *) + | (blank* '#' blank* "directory" blank* '"' as before) ([^'"']* as fname) eof { + let list = list_directories fname in + return (complete ~suffix:"" before fname after list) + } + + (* Completion on packages *) + | blank* '#' blank* ident blank* '"' [^'"']* '"' blank* eof { + return { comp_state = (before ^ ";;", after); + comp_words = TextSet.empty } + } + + (* A line that do not need to be completed: *) + | blank* '#' blank* ident blank* '"' [^'"']* '"' blank* ";;" eof { + return { comp_state = (before, after); + comp_words = TextSet.empty } + } + + | "" { + complete_end (Buffer.create (String.length before)) after lexbuf + } + +and complete_end before after = parse + + (* Completion on keywords *) + | ((ident '.')* maybe_ident as id) eof { + let before = Buffer.contents before in + return (!complete_ident before id after) + } + + | uchar as ch { + Buffer.add_string before ch; + complete_end before after lexbuf + } + + | "" { + return { comp_state = (Buffer.contents before, after); + comp_words = TextSet.empty } + } diff --git a/thirdparty/lwt-2.3.2/src/top/lwt_top.ml b/thirdparty/lwt-2.3.2/src/top/lwt_top.ml new file mode 100644 index 0000000..851bb2c --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/top/lwt_top.ml @@ -0,0 +1,141 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_top + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* Integration with the toplevel: + + readline + let threads runs while reading user input. *) + +open Lwt_unix +open Lwt +open Lwt_text +open Lwt_term + +(* +-----------------------------------------------------------------+ + | Completion | + +-----------------------------------------------------------------+ *) + +module TextSet = Set.Make(Text) + +let complete (before, after) = + Lwt_ocaml_completion.complete_input before after (Lexing.from_string before) + +(* +-----------------------------------------------------------------+ + | Read-line wrapper | + +-----------------------------------------------------------------+ *) + +let mode = ref `real_time +let completion_mode () = !mode +let set_completion_mode m = mode := m + +let history = ref [] + +let _ = + let hist_name = Filename.concat (try Unix.getenv "HOME" with _ -> "") ".lwt-top-history" in + Lwt_main.at_exit (fun () -> Lwt_read_line.save_history hist_name !history); + history := Lwt_main.run (Lwt_read_line.load_history hist_name) + +let input = ref "" +let pos = ref 0 + +let rec read_input prompt buffer len = + try + if !pos = String.length !input then begin + let prompt' = if prompt = " " then [fg blue; text "> "] else [fg yellow; text prompt] in + !Lwt_ocaml_completion.restart (); + let txt = Lwt_main.run begin + lwt l = Lwt_read_line.Control.result + (Lwt_read_line.Control.make + ~complete + ~mode:!mode + ~history:(!history) + ~prompt:(fun _ -> React.S.const prompt') + ~filter:(fun state command -> + match command with + | Lwt_read_line.Command.Accept_line -> + (* Do not accept the line if it does not terminates with ";;" *) + let text = Lwt_read_line.Engine.all_input (Lwt_read_line.Control.engine_state state) in + if Text.ends_with (Text.rstrip text) ";;" then + return Lwt_read_line.Command.Accept_line + else + return (Lwt_read_line.Command.Char "\n") + | command -> + return command) + ~map_result:return + ()) + in + lwt () = Lwt_text.flush Lwt_text.stdout in + return l + end in + history := Lwt_read_line.add_entry txt !history; + input := txt ^ "\n"; + pos := 0; + read_input prompt buffer len + end else begin + let i = ref 0 in + while !i < len && !pos < String.length !input do + buffer.[!i] <- (!input).[!pos]; + incr i; + incr pos + done; + (!i, false) + end + with + | Lwt_read_line.Interrupt -> + (0, true) + +let read_input_non_interactive prompt buffer len = + let rec loop i = + if i = len then + return (i, false) + else + Lwt_io.read_char_opt Lwt_io.stdin >>= function + | Some c -> + buffer.[i] <- c; + if c = '\n' then + return (i + 1, false) + else + loop (i + 1) + | None -> + return (i, true) + in + Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >> loop 0) + +let _ = + (* If input is a tty, use interactive read-line and display and + welcome message: *) + if Unix.isatty Unix.stdin then begin + Toploop.read_interactive_input := read_input; + + let txt = "Welcome to the Lwt powered OCaml toplevel!" in + let col_border = cyan and col_txt = yellow in + let len = Text.length txt in + let col = React.S.value Lwt_term.columns in + let space = (col - 4 - len) / 2 in + let rep n txt = text (Text.repeat n txt) in + Lwt_main.run + (lwt () = printlc [fg col_border; rep space "─"; text "┬─"; rep len "─"; text "─┬"; rep (col - 4 - len - space) "─"] in + lwt () = printlc [rep space " "; fg col_border; text "│ "; fg col_txt; text txt; fg col_border; text " │"] in + lwt () = printlc [rep space " "; fg col_border; text "└─"; rep len "─"; text "─┘"] in + Lwt_io.flush Lwt_io.stdout) + end else + (* Otherwise fallback to classic non-interactive mode: *) + Toploop.read_interactive_input := read_input_non_interactive; diff --git a/thirdparty/lwt-2.3.2/src/top/lwt_top.mli b/thirdparty/lwt-2.3.2/src/top/lwt_top.mli new file mode 100644 index 0000000..8fad322 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/top/lwt_top.mli @@ -0,0 +1,29 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_top + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Toplevel configuration *) + +val completion_mode : unit -> [ `classic | `real_time | `none ] + (** Return the current completion mode. *) + +val set_completion_mode : [ `classic | `real_time | `none ] -> unit + (** Change the completion mode *) diff --git a/thirdparty/lwt-2.3.2/src/top/toplevel.ml b/thirdparty/lwt-2.3.2/src/top/toplevel.ml new file mode 100644 index 0000000..47f0cc5 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/top/toplevel.ml @@ -0,0 +1,131 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Toplevel + * Copyright (C) 2009 Jérémie Dimino + * Pierre Chambart + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Types +open Lwt_read_line + +module TextSet = Set.Make(Text) + +type path = + | Path of Path.t + | Longident of Longident.t + +module PathMap = Map.Make(struct type t = path let compare = compare end) + +let keywords = Lwt_ocaml_completion.keywords + +let global_env = ref(lazy(raise Exit)) +let local_envs = ref(PathMap.empty) + +(* Returns [acc] plus all modules of [dir] *) +let add_modules_from_directory acc dir = + let dir = if dir = "" then "./" else dir in + let acc = ref acc in + Array.iter (fun fname -> + if Filename.check_suffix fname ".cmi" then + acc := TextSet.add (Text.capitalize (Filename.chop_suffix fname ".cmi")) !acc) + (Sys.readdir (if dir = "" then Filename.current_dir_name else dir)); + !acc + +(* List all names of the module with path [path] *) +let get_names_of_module path = + try + match + match path with + | Path path -> + Env.find_module path !Toploop.toplevel_env + | Longident ident -> + snd (Env.lookup_module ident !Toploop.toplevel_env) + with + | Tmty_signature decls -> + List.fold_left + (fun acc decl -> match decl with + | Tsig_value(id, _) + | Tsig_type(id, _, _) + | Tsig_exception(id, _) + | Tsig_module(id, _, _) + | Tsig_modtype(id, _) + | Tsig_class(id, _, _) + | Tsig_cltype(id, _, _) -> + TextSet.add (Ident.name id) acc) + TextSet.empty decls + | _ -> + TextSet.empty + with Not_found -> + TextSet.empty + +let names_of_module path = + try + PathMap.find path !local_envs + with Not_found -> + let names = get_names_of_module path in + local_envs := PathMap.add path names !local_envs; + names + +(* List all names accessible without a path *) +let env_names () = + let rec loop acc = function + | Env.Env_empty -> acc + | Env.Env_value(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary + | Env.Env_type(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary + | Env.Env_exception(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary + | Env.Env_module(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary + | Env.Env_modtype(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary + | Env.Env_class(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary + | Env.Env_cltype(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary + | Env.Env_open(summary, path) -> loop (TextSet.union acc (names_of_module (Path path))) summary + in + (* Add names of the environment: *) + let acc = loop TextSet.empty (Env.summary !Toploop.toplevel_env) in + (* Add accessible modules: *) + List.fold_left add_modules_from_directory acc !Config.load_path + +let path_of_string text = + match Text.split ~sep:"." text with + | [] -> + invalid_arg "Toplevel.make_path" + | ident :: rest -> + let rec loop path = function + | [] -> Longident path + | component :: rest -> loop (Longident.Ldot(path, component)) rest + in + loop (Longident.Lident ident) rest + +let complete_ident before ident after = + match Text.rev_split ~sep:"." ~max:2 ident with + | [ident]-> + complete ~suffix:"" before ident after (TextSet.union keywords (Lazy.force !global_env)) + | [path; ident] -> + let before = before ^ path ^ "." in + complete ~suffix:"" before ident after (names_of_module (path_of_string path)) + | _ -> + assert false + +let restart () = + global_env := lazy(env_names ()); + local_envs := PathMap.empty + +let () = + Topfind.don't_load_deeply ["lwt"; "lwt.react"; "lwt.unix"; "lwt.text"; "lwt.top"]; + Lwt_ocaml_completion.complete_ident := complete_ident; + Lwt_ocaml_completion.restart := restart diff --git a/thirdparty/lwt-2.3.2/src/top/toplevel_temp.mltop b/thirdparty/lwt-2.3.2/src/top/toplevel_temp.mltop new file mode 100644 index 0000000..83c26cf --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/top/toplevel_temp.mltop @@ -0,0 +1,3 @@ +# This file is used to generate "toplevel_temp.top", which is then +# expunged into "lwt-toplevel" +Toplevel diff --git a/thirdparty/lwt-2.3.2/src/unix/liblwt-unix.clib b/thirdparty/lwt-2.3.2/src/unix/liblwt-unix.clib new file mode 100644 index 0000000..0143cb3 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/liblwt-unix.clib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 0d2c17c0648a3a3dd282ce99960c7277) +lwt_unix_stubs.o +lwt_libev_stubs.o +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt-unix.mllib b/thirdparty/lwt-2.3.2/src/unix/lwt-unix.mllib new file mode 100644 index 0000000..66adca7 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt-unix.mllib @@ -0,0 +1,17 @@ +# OASIS_START +# DO NOT EDIT (digest: 2e742a984520810653596dcf9f7563fa) +Lwt_chan +Lwt_daemon +Lwt_gc +Lwt_io +Lwt_log +Lwt_main +Lwt_process +Lwt_throttle +Lwt_timeout +Lwt_unix +Lwt_sys +Lwt_engine +Lwt_bytes +Lwt_log_rules +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.ml new file mode 100644 index 0000000..fc9547b --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.ml @@ -0,0 +1,344 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_unix + * Copyright (C) 2010 Jérémie Dimino + * 2010 Pierre Chambart + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +#include "src/unix/lwt_config.ml" + +open Bigarray +open Lwt + +type t = (char, int8_unsigned_elt, c_layout) Array1.t + +let create size = Array1.create char c_layout size +let length bytes = Array1.dim bytes + +external get : t -> int -> char = "%caml_ba_ref_1" +external set : t -> int -> char -> unit = "%caml_ba_set_1" + +external unsafe_get : t -> int -> char = "%caml_ba_unsafe_ref_1" +external unsafe_set : t -> int -> char -> unit = "%caml_ba_unsafe_set_1" + +external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc" + +let fill bytes ofs len ch = + if ofs < 0 || len < 0 || ofs > length bytes - len then + invalid_arg "Lwt_bytes.fill" + else + unsafe_fill bytes ofs len ch + +(* +-----------------------------------------------------------------+ + | Blitting | + +-----------------------------------------------------------------+ *) + +external unsafe_blit_string_bytes : string -> int -> t -> int -> int -> unit = "lwt_unix_blit_string_bytes" "noalloc" +external unsafe_blit_bytes_string : t -> int -> string -> int -> int -> unit = "lwt_unix_blit_bytes_string" "noalloc" +external unsafe_blit : t -> int -> t -> int -> int -> unit = "lwt_unix_blit_bytes_bytes" "noalloc" + +let blit_string_bytes src_buf src_ofs dst_buf dst_ofs len = + if (len < 0 + || src_ofs < 0 || src_ofs > String.length src_buf - len + || dst_ofs < 0 || dst_ofs > length dst_buf - len) then + invalid_arg "String.blit" + else + unsafe_blit_string_bytes src_buf src_ofs dst_buf dst_ofs len + +let blit_bytes_string src_buf src_ofs dst_buf dst_ofs len = + if (len < 0 + || src_ofs < 0 || src_ofs > length src_buf - len + || dst_ofs < 0 || dst_ofs > String.length dst_buf - len) then + invalid_arg "String.blit" + else + unsafe_blit_bytes_string src_buf src_ofs dst_buf dst_ofs len + +let blit src_buf src_ofs dst_buf dst_ofs len = + if (len < 0 + || src_ofs < 0 || src_ofs > length src_buf - len + || dst_ofs < 0 || dst_ofs > length dst_buf - len) then + invalid_arg "String.blit" + else + unsafe_blit src_buf src_ofs dst_buf dst_ofs len + +let of_string str = + let len = String.length str in + let bytes = create len in + unsafe_blit_string_bytes str 0 bytes 0 len; + bytes + +let to_string bytes = + let len = length bytes in + let str = String.create len in + unsafe_blit_bytes_string bytes 0 str 0 len; + str + +let proxy = Array1.sub + +let extract buf ofs len = + if ofs < 0 || len < 0 || ofs > length buf - len then + invalid_arg "Lwt_bytes.extract" + else begin + let buf' = create len in + blit buf ofs buf' 0 len; + buf' + end + +let copy buf = + let len = length buf in + let buf' = create len in + blit buf 0 buf' 0 len; + buf' + +(* +-----------------------------------------------------------------+ + | IOs | + +-----------------------------------------------------------------+ *) + +open Lwt_unix + +external stub_read : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_read" +external read_job : Unix.file_descr -> t -> int -> int -> [ `unix_bytes_read ] job = "lwt_unix_bytes_read_job" +external read_result : [ `unix_bytes_read ] job -> int = "lwt_unix_bytes_read_result" +external read_free : [ `unix_bytes_read ] job -> unit = "lwt_unix_bytes_read_free" "noalloc" + +let read fd buf pos len = + if pos < 0 || len < 0 || pos > length buf - len then + invalid_arg "Lwt_bytes.read" + else + blocking fd >>= function + | true -> + lwt () = wait_read fd in + execute_job (read_job (unix_file_descr fd) buf pos len) read_result read_free + | false -> + wrap_syscall Read fd (fun () -> stub_read (unix_file_descr fd) buf pos len) + +external stub_write : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_write" +external write_job : Unix.file_descr -> t -> int -> int -> [ `unix_bytes_write ] job = "lwt_unix_bytes_write_job" +external write_result : [ `unix_bytes_write ] job -> int = "lwt_unix_bytes_write_result" +external write_free : [ `unix_bytes_write ] job -> unit = "lwt_unix_bytes_write_free" "noalloc" + +let write fd buf pos len = + if pos < 0 || len < 0 || pos > length buf - len then + invalid_arg "Lwt_bytes.write" + else + blocking fd >>= function + | true -> + lwt () = wait_write fd in + execute_job (write_job (unix_file_descr fd) buf pos len) write_result write_free + | false -> + wrap_syscall Write fd (fun () -> stub_write (unix_file_descr fd) buf pos len) + +#if windows + +let recv fd buf pos len flags = + raise (Lwt_sys.Not_available "Lwt_bytes.recv") + +#else + +external stub_recv : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_recv" + +let recv fd buf pos len flags = + if pos < 0 || len < 0 || pos > length buf - len then + invalid_arg "recv" + else + wrap_syscall Read fd (fun () -> stub_recv (unix_file_descr fd) buf pos len flags) + +#endif + +#if windows + +let send fd buf pos len flags = + raise (Lwt_sys.Not_available "Lwt_bytes.send") + +#else + +external stub_send : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_send" + +let send fd buf pos len flags = + if pos < 0 || len < 0 || pos > length buf - len then + invalid_arg "send" + else + wrap_syscall Write fd (fun () -> stub_send (unix_file_descr fd) buf pos len flags) + +#endif + +type io_vector = { + iov_buffer : t; + iov_offset : int; + iov_length : int; +} + +let io_vector ~buffer ~offset ~length = { + iov_buffer = buffer; + iov_offset = offset; + iov_length = length; +} + +let check_io_vectors func_name iovs = + List.iter + (fun iov -> + if iov.iov_offset < 0 + || iov.iov_length < 0 + || iov.iov_offset > length iov.iov_buffer - iov.iov_length then + invalid_arg func_name) + iovs + +#if windows + +let recv_msg ~socket ~io_vectors = + raise (Lwt_sys.Not_available "recv_msg") + +#else + +external stub_recv_msg : Unix.file_descr -> int -> io_vector list -> int * Unix.file_descr list = "lwt_unix_bytes_recv_msg" + +let recv_msg ~socket ~io_vectors = + check_io_vectors "recv_msg" io_vectors; + let n_iovs = List.length io_vectors in + wrap_syscall Read socket + (fun () -> + stub_recv_msg (unix_file_descr socket) n_iovs io_vectors) + +#endif + +#if windows + +let send_msg ~socket ~io_vectors ~fds = + raise (Lwt_sys.Not_available "send_msg") + +#else + +external stub_send_msg : Unix.file_descr -> int -> io_vector list -> int -> Unix.file_descr list -> int = "lwt_unix_bytes_send_msg" + +let send_msg ~socket ~io_vectors ~fds = + check_io_vectors "send_msg" io_vectors; + let n_iovs = List.length io_vectors and n_fds = List.length fds in + wrap_syscall Write socket + (fun () -> + stub_send_msg (unix_file_descr socket) n_iovs io_vectors n_fds fds) + +#endif + +#if windows + +let recvfrom fd buf pos len flags = + raise (Lwt_sys.Not_available "Lwt_bytes.recvfrom") + +#else + +external stub_recvfrom : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr = "lwt_unix_bytes_recvfrom" + +let recvfrom fd buf pos len flags = + if pos < 0 || len < 0 || pos > length buf - len then + invalid_arg "Lwt_bytes.recvfrom" + else + wrap_syscall Read fd (fun () -> stub_recvfrom (unix_file_descr fd) buf pos len flags) + +#endif + +#if windows + +let sendto fd buf pos len flags addr = + raise (Lwt_sys.Not_available "Lwt_bytes.sendto") + +#else + +external stub_sendto : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int = "lwt_unix_bytes_sendto_byte" "lwt_unix_bytes_sendto" + +let sendto fd buf pos len flags addr = + if pos < 0 || len < 0 || pos > length buf - len then + invalid_arg "Lwt_bytes.sendto" + else + wrap_syscall Write fd (fun () -> stub_sendto (unix_file_descr fd) buf pos len flags addr) + +#endif + +(* +-----------------------------------------------------------------+ + | Memory mapped files | + +-----------------------------------------------------------------+ *) + +let map_file ~fd ?pos ~shared ?(size=(-1)) () = + Array1.map_file fd ?pos char c_layout shared size + +external mapped : t -> bool = "lwt_unix_mapped" "noalloc" + +type advice = + | MADV_NORMAL + | MADV_RANDOM + | MADV_SEQUENTIAL + | MADV_WILLNEED + | MADV_DONTNEED + +#if windows + +let madvise buf pos len advice = + raise (Lwt_sys.Not_available "madvise") + +#else + +external stub_madvise : t -> int -> int -> advice -> unit = "lwt_unix_madvise" + +let madvise buf pos len advice = + if pos < 0 || len < 0 || pos > length buf - len then + invalid_arg "Lwt_bytes.madvise" + else + stub_madvise buf pos len advice + +#endif + +external get_page_size : unit -> int = "lwt_unix_get_page_size" + +let page_size = get_page_size () + +#if windows + +let mincore buffer offset states = + raise (Lwt_sys.Not_available "mincore") + +let wait_mincore buffer offset = + raise (Lwt_sys.Not_available "mincore") + +#else + +external stub_mincore : t -> int -> int -> bool array -> unit = "lwt_unix_mincore" + +let mincore buffer offset states = + if (offset mod page_size <> 0 + || offset < 0 + || offset > length buffer - (Array.length states * page_size)) then + invalid_arg "Lwt_bytes.mincore" + else + stub_mincore buffer offset (Array.length states * page_size) states + +external wait_mincore_job : t -> int -> [ `unix_wait_mincore ] job = "lwt_unix_wait_mincore_job" +external wait_mincore_free : [ `unix_wait_mincore ] job -> unit = "lwt_unix_wait_mincore_free" "noalloc" + +let wait_mincore buffer offset = + if offset < 0 || offset >= length buffer then + invalid_arg "Lwt_bytes.wait_mincore" + else begin + let state = [|false|] in + mincore buffer (offset - (offset mod page_size)) state; + if state.(0) then + return () + else + execute_job (wait_mincore_job buffer offset) ignore wait_mincore_free + end + +#endif diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.mli new file mode 100644 index 0000000..d76674b --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.mli @@ -0,0 +1,176 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_unix + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Byte arrays *) + +type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + (** Type of array of bytes. *) + +val create : int -> t + (** Creates a new byte array of the given size. *) + +val length : t -> int + (** Returns the length of the given byte array. *) + +(** {6 Access} *) + +external get : t -> int -> char = "%caml_ba_ref_1" + (** [get buffer offset] returns the byte at offset [offset] in + [buffer]. *) + +external set : t -> int -> char -> unit = "%caml_ba_set_1" + (** [get buffer offset value] changes the value of the byte at + offset [offset] in [buffer] to [value]. *) + +external unsafe_get : t -> int -> char = "%caml_ba_unsafe_ref_1" + (** Same as {!get} but without bound checking. *) + +external unsafe_set : t -> int -> char -> unit = "%caml_ba_unsafe_set_1" + (** Same as {!set} but without bound checking. *) + +(** {6 Conversions} *) + +val of_string : string -> t + (** [of_string str] returns a newly allocated byte array with the + same contents as [str]. *) + +val to_string : t -> string + (** [to_string buf] returns a newly allocated string with the same + contents as [buf]. *) + +(** {6 Copying} *) + +val blit : t -> int -> t -> int -> int -> unit + (** [blit buf1 ofs1 buf2 ofs2 len] copy [len] bytes from [buf1] + starting at offset [ofs1] to [buf2] starting at offset [ofs2]. *) + +val blit_string_bytes : string -> int -> t -> int -> int -> unit + (** Same as blit but the first buffer is a string instead of a byte + array. *) + +val blit_bytes_string : t -> int -> string -> int -> int -> unit + (** Same as blit but the second buffer is a string instead of a byte + array. *) + +external unsafe_blit : t -> int -> t -> int -> int -> unit = "lwt_unix_blit_bytes_bytes" "noalloc" + (** Same as {!blit} but without bound checking. *) + +external unsafe_blit_string_bytes : string -> int -> t -> int -> int -> unit = "lwt_unix_blit_string_bytes" "noalloc" + (** Same as {!blit_string_bytes} but without bound checking. *) + +external unsafe_blit_bytes_string : t -> int -> string -> int -> int -> unit = "lwt_unix_blit_bytes_string" "noalloc" + (** Same as {!blit_bytes_string} but without bound checking. *) + +val proxy : t -> int -> int -> t + (** [proxy buffer offset length] creates a ``proxy''. The returned + byte array share the data of [buffer] but with different + bounds. *) + +val extract : t -> int -> int -> t + (** [extract buffer offset length] creates a new byte array of + length [length] and copy the [length] bytes of [buffer] at + [offset] into it. *) + +val copy : t -> t + (** [copy buffer] creates a copy of the given byte array. *) + +(** {6 Filling} *) + +val fill : t -> int -> int -> char -> unit + (** [fill buffer offset length value] puts [value] in all [length] + bytes of [buffer] starting at offset [offset]. *) + +external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc" + (** Same as {!fill} but without bound checking. *) + +(** {6 IOs} *) + +(** The following functions does the same as the functions in + {!Lwt_unix} except that they use byte arrays instead of + strings. *) + +val read : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t +val write : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t + +val recv : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t +val send : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t + +val recvfrom : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> (int * Unix.sockaddr) Lwt.t +val sendto : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int Lwt.t + +type io_vector = { + iov_buffer : t; + iov_offset : int; + iov_length : int; +} + +val io_vector : buffer : t -> offset : int -> length : int -> io_vector + +val recv_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> (int * Unix.file_descr list) Lwt.t + (** This call is not available on windows. *) + +val send_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> fds : Unix.file_descr list -> int Lwt.t + (** This call is not available on windows. *) + +(** {6 Memory mapped files} *) + +val map_file : fd : Unix.file_descr -> ?pos : int64 -> shared : bool -> ?size : int -> unit -> t + (** [map_file ~fd ?pos ~shared ?size ()] maps the file descriptor + [fd] to an array of bytes. *) + +external mapped : t -> bool = "lwt_unix_mapped" "noalloc" + (** [mapped buffer] returns [true] iff [buffer] is a memory mapped + file. *) + +(** Type of advise that can be sent to the kernel by the program. See + the manual madvise(2) for a description of each advices. *) +type advice = + | MADV_NORMAL + | MADV_RANDOM + | MADV_SEQUENTIAL + | MADV_WILLNEED + | MADV_DONTNEED + +val madvise : t -> int -> int -> advice -> unit + (** [madvise buffer pos len advice] advise the kernel about how the + program is going to use the part of the memory mapped file + between [pos] and [pos + len]. + + This call is not available on windows. *) + +val page_size : int + (** Size of pages. *) + +val mincore : t -> int -> bool array -> unit + (** [mincore buffer offset states] tests whether the given pages are + in the system memory (the RAM). The [offset] argument must be a + multiple of {!page_size}. [states] is used to store the result; + each cases is [true] if the corresponding page in the RAM and + [false] otherwise. + + This call is not available on windows. *) + +val wait_mincore : t -> int -> unit Lwt.t + (** [wait_mincore buffer offset] waits until the page containing the + byte at offset [offset] in the the RAM. + + This functions is not available on windows. *) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_chan.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_chan.ml new file mode 100644 index 0000000..3fbf613 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_chan.ml @@ -0,0 +1,86 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_chan + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * 2009 Jrmie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt +open Lwt_io + +type in_channel = Lwt_io.input_channel +type out_channel = Lwt_io.output_channel + +let in_channel_of_descr fd = of_fd ~mode:Lwt_io.input fd + +let make_in_channel ?close read = + make ~mode:Lwt_io.input ?close + (fun buf ofs len -> + let str = String.create len in + lwt n = read str 0 len in + if (n > 0) then Lwt_bytes.blit_string_bytes str 0 buf ofs len; + return n) + +let input_line ic = + let rec loop buf = + read_char_opt ic >>= function + | None | Some '\n' -> + return (Buffer.contents buf) + | Some char -> + Buffer.add_char buf char; + loop buf + in + read_char_opt ic >>= function + | Some '\n' -> + return "" + | Some char -> + let buf = Buffer.create 128 in + Buffer.add_char buf char; + loop buf + | None -> + raise_lwt End_of_file + +let input_value = read_value +let input = read_into +let really_input = read_into_exactly +let input_char = read_char +let input_binary_int = BE.read_int +let open_in_gen flags perm fname = open_file ~flags ~perm ~mode:Lwt_io.input fname +let open_in fname = open_file ~mode:Lwt_io.input fname +let close_in = close +let out_channel_of_descr fd = of_fd ~mode:Lwt_io.output fd + +let make_out_channel ?close write = + make ~mode:Lwt_io.output ?close + (fun buf ofs len -> + let str = String.create len in + Lwt_bytes.blit_bytes_string buf ofs str 0 len; + write str 0 len) + +let output = write_from_exactly +let flush = flush +let output_string = write +let output_value oc v = write_value oc v +let output_char = write_char +let output_binary_int = BE.write_int +let open_out_gen flags perm fname = open_file ~flags ~perm ~mode:Lwt_io.output fname +let open_out fname = open_file ~mode:Lwt_io.output fname +let close_out = close +let open_connection sockaddr = open_connection sockaddr diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_chan.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_chan.mli new file mode 100644 index 0000000..175d31e --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_chan.mli @@ -0,0 +1,75 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_chan + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Module [Lwt_chan]: cooperative, [Pervasives]-like, I/O functions *) + +(** Note: the {!Lwt_io} module deprecates this module. *) + +(** {2 Cooperative input channels} *) +type in_channel = Lwt_io.input_channel + +val in_channel_of_descr : Lwt_unix.file_descr -> in_channel + +val make_in_channel : ?close:(unit -> unit Lwt.t) -> (string -> int -> int -> int Lwt.t) -> in_channel +(** [make_in_channel read] creates an input channel from the [read] + function. [read s ofs len] should (cooperatively) read [len] bytes from + the source, and put them in [s], at offset [ofs], and return the number + of bytes effectively read. If provided, [close] will be called by + [close_in]. By default, [close_in] does not do anything. *) + +val input_line : in_channel -> string Lwt.t +val input_value : in_channel -> 'a Lwt.t +val input : in_channel -> string -> int -> int -> int Lwt.t +val really_input : in_channel -> string -> int -> int -> unit Lwt.t +val input_char : in_channel -> char Lwt.t +val input_binary_int : in_channel -> int Lwt.t + +val open_in_gen : Unix.open_flag list -> int -> string -> in_channel Lwt.t +val open_in : string -> in_channel Lwt.t +val close_in : in_channel -> unit Lwt.t + +(** {2 Cooperative output channels} *) + +type out_channel = Lwt_io.output_channel + +val out_channel_of_descr : Lwt_unix.file_descr -> out_channel + +val make_out_channel : ?close:(unit -> unit Lwt.t) -> (string -> int -> int -> int Lwt.t) -> out_channel +(** [make_out_channel write] creates an output channel from the [write] + function. [write s ofs len] should (cooperatively) write [len] bytes from + [s], starting at offset [ofs], to the backend, and return the number of + bytes effectively written. If provided, [close] will be called by + [close_out]. By default, [close_out] does not do anything. *) + +val output : out_channel -> string -> int -> int -> unit Lwt.t +val flush : out_channel -> unit Lwt.t +val output_string : out_channel -> string -> unit Lwt.t +val output_value : out_channel -> 'a -> unit Lwt.t +val output_char : out_channel -> char -> unit Lwt.t +val output_binary_int : out_channel -> int -> unit Lwt.t + +val open_out_gen : Unix.open_flag list -> int -> string -> out_channel Lwt.t +val open_out : string -> out_channel Lwt.t +val close_out : out_channel -> unit Lwt.t + +val open_connection : Unix.sockaddr -> (in_channel * out_channel) Lwt.t diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.ml new file mode 100644 index 0000000..a5a7333 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.ml @@ -0,0 +1,89 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_io + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt + +let rec copy ic logger = + lwt line = Lwt_io.read_line ic in + lwt () = Lwt_log.log ?logger ~level:Lwt_log.Notice line in + copy ic logger + +let redirect fd logger = + let fd_r, fd_w = Unix.pipe () in + Unix.set_close_on_exec fd_r; + Unix.dup2 fd_w fd; + Unix.close fd_w; + let ic = Lwt_io.of_unix_fd ~mode:Lwt_io.input fd in + ignore (copy ic logger) + +let redirect_output dev_null fd mode = match mode with + | `Dev_null -> + Unix.dup2 dev_null fd + | `Close -> + Unix.close fd + | `Keep -> + () + | `Log_default -> + redirect fd None + | `Log logger -> + redirect fd (Some logger) + +let daemonize ?(syslog=true) ?(stdin=`Dev_null) ?(stdout=`Log_default) ?(stderr=`Log_default) ?(directory="/") ?(umask=`Set 0o022) () = + if Unix.getppid () = 1 then + (* If our parent is [init], then we already are a demon *) + () + else begin + Unix.chdir directory; + + (* Exit the parent, and continue in the child: *) + if Lwt_unix.fork () > 0 then begin + (* Do not run exit hooks in the parent. *) + Lwt_sequence.iter_node_l Lwt_sequence.remove Lwt_main.exit_hooks; + exit 0 + end; + + if syslog then Lwt_log.default := Lwt_log.syslog ~facility:`Daemon (); + + (* Redirection of standard IOs *) + let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR] 0o666 in + begin match stdin with + | `Dev_null -> + Unix.dup2 dev_null Unix.stdin + | `Close -> + Unix.close Unix.stdin + | `Keep -> + () + end; + redirect_output dev_null Unix.stdout stdout; + redirect_output dev_null Unix.stderr stderr; + Unix.close dev_null; + + begin match umask with + | `Keep -> + () + | `Set n -> + ignore (Unix.umask 0o022); + end; + + ignore (Unix.setsid ()) + end + diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.mli new file mode 100644 index 0000000..7e7f23b --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.mli @@ -0,0 +1,81 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_io + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Daemon helpers *) + +val daemonize : + ?syslog : bool -> + ?stdin : [ `Dev_null | `Close | `Keep ] -> + ?stdout : [ `Dev_null | `Close | `Keep | `Log_default | `Log of Lwt_log.logger ] -> + ?stderr : [ `Dev_null | `Close | `Keep | `Log_default | `Log of Lwt_log.logger ] -> + ?directory : string -> + ?umask : [ `Keep | `Set of int ] -> + unit -> unit + (** Put the current running process into daemon mode. I.e. it forks + and exit the parent, detach it from its controlling terminal, + and redict standard intputs/outputs.. + + Notes: + - if the process is already a daemon, it does nothing. + - you must be sure that there is no pending threads when + calling this function, otherwise they may be canceled. + + If [syslog] is [true] (the default), then {!Lwt_log.default} is + set to [Lwt_log.syslog ~facility:`Daemon ()], otherwise it is + kept unchanged. + + [stdin] is one of: + - [`Dev_null] which means that [Unix.stdin] is reopened as + [/dev/null], this is the default behavior + - [`Close] means that [Unix.stdin] is simply closed + - [`Keep] means that [Unix.stdin] is left unchanged + + [stdout] and [stderr] control how the two associated file + descriptors are redirected: + - [`Dev_null] means that the output is redirected to [/dev/null] + - [`Close] means that the file descriptor is closed + - [`Keep] means that it is left unchanged + - [`Log logger] means that the output is redirected to this + logger + - [`Log_default] means that the output is redirected to the + default logger + + Both [stdout] and [stderr] defaults to [`Log_default]. + + Warning: do not redirect an output to a logger logging into this + outpout, for example this code will create an infinite loop: + + {[ + let logger = Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr () in + Lwt_daemon.daemonize ~syslog:false ~stderr:(`Log logger) (); + prerr_endline "foo" + ]} + + The current working directory is set to [directory], which + defaults to ["/"]. + + [umask] may be one of: + - [`Keep] which means that the umask is left unchanged + - [`Set n] which means that the umash is set to [n] + + It defaults to [`Set 0o022]. + *) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_engine.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_engine.ml new file mode 100644 index 0000000..0594376 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_engine.ml @@ -0,0 +1,421 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_engine + * Copyright (C) 2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +#include "src/unix/lwt_config.ml" + +(* +-----------------------------------------------------------------+ + | Events | + +-----------------------------------------------------------------+ *) + +type _event = { + stop : unit Lazy.t; + (* The stop method of the event. *) + node : Obj.t Lwt_sequence.node; + (* The node in the sequence of registered events. *) +} + +type event = _event ref + +external cast_node : 'a Lwt_sequence.node -> Obj.t Lwt_sequence.node = "%identity" + +let stop_event ev = + let ev = !ev in + Lwt_sequence.remove ev.node; + Lazy.force ev.stop + +let _fake_event = { + stop = lazy (); + node = Lwt_sequence.add_l (Obj.repr ()) (Lwt_sequence.create ()); +} + +let fake_event = ref _fake_event + +(* +-----------------------------------------------------------------+ + | Engines | + +-----------------------------------------------------------------+ *) + +class virtual abstract = object(self) + method virtual iter : bool -> unit + method virtual private cleanup : unit + method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t + method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t + method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t + + val readables = Lwt_sequence.create () + (* Sequence of callbacks waiting for a file descriptor to become + readable. *) + + val writables = Lwt_sequence.create () + (* Sequence of callbacks waiting for a file descriptor to become + writable. *) + + val timers = Lwt_sequence.create () + (* Sequence of timers. *) + + method destroy = + Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev) readables; + Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev) writables; + Lwt_sequence.iter_l (fun (delay, repeat, f, g, ev) -> stop_event ev) timers; + self#cleanup + + method transfer (engine : abstract) = + Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev; ev := !(engine#on_readable fd f)) readables; + Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev; ev := !(engine#on_writable fd f)) writables; + Lwt_sequence.iter_l (fun (delay, repeat, f, g, ev) -> stop_event ev; ev := !(engine#on_timer delay repeat f)) timers + + method fake_io fd = + Lwt_sequence.iter_l (fun (fd', f, g, stop) -> if fd = fd' then g ()) readables; + Lwt_sequence.iter_l (fun (fd', f, g, stop) -> if fd = fd' then g ()) writables + + method on_readable fd f = + let ev = ref _fake_event in + let g () = f ev in + let stop = self#register_readable fd g in + ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) readables) }; + ev + + method on_writable fd f = + let ev = ref _fake_event in + let g () = f ev in + let stop = self#register_writable fd g in + ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) writables) } ; + ev + + method on_timer delay repeat f = + let ev = ref _fake_event in + let g () = f ev in + let stop = self#register_timer delay repeat g in + ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (delay, repeat, f, g, ev) timers) }; + ev + + method readable_count = Lwt_sequence.length readables + method writable_count = Lwt_sequence.length writables + method timer_count = Lwt_sequence.length timers +end + +class type t = object + inherit abstract + + method iter : bool -> unit + method private cleanup : unit + method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t + method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t + method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t +end + +(* +-----------------------------------------------------------------+ + | The libev engine | + +-----------------------------------------------------------------+ *) + +#if HAVE_LIBEV + +type ev_loop +type ev_io +type ev_timer + +external ev_init : unit -> ev_loop = "lwt_libev_init" +external ev_stop : ev_loop -> unit = "lwt_libev_stop" +external ev_loop : ev_loop -> bool -> unit = "lwt_libev_loop" +external ev_unloop : ev_loop -> unit = "lwt_libev_unloop" +external ev_readable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_readable_init" +external ev_writable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_writable_init" +external ev_io_stop : ev_loop -> ev_io -> unit = "lwt_libev_io_stop" +external ev_timer_init : ev_loop -> float -> bool -> (unit -> unit) -> ev_timer = "lwt_libev_timer_init" +external ev_timer_stop : ev_loop -> ev_timer -> unit = "lwt_libev_timer_stop" + +class libev = object + inherit abstract + + val loop = ev_init () + method loop = loop + + method private cleanup = ev_stop loop + + method iter block = + try + ev_loop loop block + with exn -> + ev_unloop loop; + raise exn + + method private register_readable fd f = + let ev = ev_readable_init loop fd f in + lazy(ev_io_stop loop ev) + + method private register_writable fd f = + let ev = ev_writable_init loop fd f in + lazy(ev_io_stop loop ev) + + method private register_timer delay repeat f = + let ev = ev_timer_init loop delay repeat f in + lazy(ev_timer_stop loop ev) +end + +#else + +type ev_loop + +class libev = object(self) + inherit abstract + + val loop : ev_loop = raise (Lwt_sys.Not_available "libev") + method loop : ev_loop = assert false + method iter = assert false + method private cleanup = assert false + method private register_readable = assert false + method private register_writable = assert false + method private register_timer = assert false +end + +#endif + +(* +-----------------------------------------------------------------+ + | Select/poll based engines | + +-----------------------------------------------------------------+ *) + +(* Type of a sleeper for the select engine. *) +type sleeper = { + mutable time : float; + (* The time at which the sleeper should be wakeup. *) + + mutable stopped : bool; + (* [true] iff the event has been stopped. *) + + action : unit -> unit; + (* The action for the sleeper. *) +} + +module Sleep_queue = + Lwt_pqueue.Make(struct + type t = sleeper + let compare { time = t1 } { time = t2 } = compare t1 t2 + end) + +module Fd_map = Map.Make(struct type t = Unix.file_descr let compare = compare end) + +let rec restart_actions sleep_queue now = + match Sleep_queue.lookup_min sleep_queue with + | Some{ stopped = true } -> + restart_actions (Sleep_queue.remove_min sleep_queue) now + | Some{ time = time; action = action } when time <= now -> + action (); + restart_actions (Sleep_queue.remove_min sleep_queue) now + | _ -> + sleep_queue + +let rec get_next_timeout sleep_queue = + match Sleep_queue.lookup_min sleep_queue with + | Some{ stopped = true } -> + get_next_timeout (Sleep_queue.remove_min sleep_queue) + | Some{ time = time } -> + max 0. (time -. Unix.gettimeofday ()) + | None -> + -1. + +let bad_fd fd = + try + let _ = Unix.fstat fd in + false + with Unix.Unix_error (_, _, _) -> + true + +let invoke_actions fd map = + match try Some(Fd_map.find fd map) with Not_found -> None with + | Some actions -> Lwt_sequence.iter_l (fun f -> f ()) actions + | None -> () + +class virtual select_or_poll_based = object(self) + inherit abstract + + val mutable sleep_queue = Sleep_queue.empty + (* Threads waiting for a timeout to expire. *) + + val mutable new_sleeps = [] + (* Sleepers added since the last iteration of the main loop: + + They are not added immediatly to the main sleep queue in order + to prevent them from being wakeup immediatly. *) + + val mutable wait_readable = Fd_map.empty + (* Sequences of actions waiting for file descriptors to become + readable. *) + + val mutable wait_writable = Fd_map.empty + (* Sequences of actions waiting for file descriptors to become + writable. *) + + method private cleanup = () + + method private register_timer delay repeat f = + if repeat then begin + let rec sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = g } + and g () = + sleeper.time <- Unix.gettimeofday () +. delay; + new_sleeps <- sleeper :: new_sleeps; + f () + in + new_sleeps <- sleeper :: new_sleeps; + lazy(sleeper.stopped <- true) + end else begin + let sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = f } in + new_sleeps <- sleeper :: new_sleeps; + lazy(sleeper.stopped <- true) + end + + method private register_readable fd f = + let actions = + try + Fd_map.find fd wait_readable + with Not_found -> + let actions = Lwt_sequence.create () in + wait_readable <- Fd_map.add fd actions wait_readable; + actions + in + let node = Lwt_sequence.add_l f actions in + lazy(Lwt_sequence.remove node; + if Lwt_sequence.is_empty actions then wait_readable <- Fd_map.remove fd wait_readable) + + method private register_writable fd f = + let actions = + try + Fd_map.find fd wait_writable + with Not_found -> + let actions = Lwt_sequence.create () in + wait_writable <- Fd_map.add fd actions wait_writable; + actions + in + let node = Lwt_sequence.add_l f actions in + lazy(Lwt_sequence.remove node; + if Lwt_sequence.is_empty actions then wait_writable <- Fd_map.remove fd wait_writable) +end + +class virtual select_based = object(self) + inherit select_or_poll_based + + method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list + + method iter block = + (* Transfer all sleepers added since the last iteration to the + main sleep queue: *) + sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps; + new_sleeps <- []; + (* Collect file descriptors. *) + let fds_r = Fd_map.fold (fun fd _ l -> fd :: l) wait_readable [] in + let fds_w = Fd_map.fold (fun fd _ l -> fd :: l) wait_writable [] in + (* Compute the timeout. *) + let timeout = if block then get_next_timeout sleep_queue else 0. in + (* Do the blocking call *) + let fds_r, fds_w = + try + self#select fds_r fds_w timeout + with + | Unix.Unix_error (Unix.EINTR, _, _) -> + ([], []) + | Unix.Unix_error (Unix.EBADF, _, _) -> + (* Keeps only bad file descriptors. Actions registered on + them have to handle the error: *) + (List.filter bad_fd fds_r, + List.filter bad_fd fds_w) + in + (* Restart threads waiting for a timeout: *) + sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); + (* Restart threads waiting on a file descriptors: *) + List.iter (fun fd -> invoke_actions fd wait_readable) fds_r; + List.iter (fun fd -> invoke_actions fd wait_writable) fds_w +end + +class virtual poll_based = object(self) + inherit select_or_poll_based + + method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list + + method iter block = + (* Transfer all sleepers added since the last iteration to the + main sleep queue: *) + sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps; + new_sleeps <- []; + (* Collect file descriptors. *) + let fds = [] in + let fds = Fd_map.fold (fun fd _ l -> (fd, true, false) :: l) wait_readable fds in + let fds = Fd_map.fold (fun fd _ l -> (fd, false, true) :: l) wait_writable fds in + (* Compute the timeout. *) + let timeout = if block then get_next_timeout sleep_queue else 0. in + (* Do the blocking call *) + let fds = + try + self#poll fds timeout + with + | Unix.Unix_error (Unix.EINTR, _, _) -> + [] + | Unix.Unix_error (Unix.EBADF, _, _) -> + (* Keeps only bad file descriptors. Actions registered on + them have to handle the error: *) + List.filter (fun (fd, _, _) -> bad_fd fd) fds + in + (* Restart threads waiting for a timeout: *) + sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); + (* Restart threads waiting on a file descriptors: *) + List.iter + (fun (fd, readable, writable) -> + if readable then invoke_actions fd wait_readable; + if writable then invoke_actions fd wait_writable) + fds +end + +class select = object + inherit select_based + + method private select fds_r fds_w timeout = + let fds_r, fds_w, _ = Unix.select fds_r fds_w [] timeout in + (fds_r, fds_w) +end + +(* +-----------------------------------------------------------------+ + | The current engine | + +-----------------------------------------------------------------+ *) + +#if HAVE_LIBEV && not windows + +let current = ref (new libev :> t) + +#else + +let current = ref (new select :> t) + +#endif + +let get () = + !current + +let set ?(transfer=true) ?(destroy=true) engine = + if transfer then !current#transfer (engine : #t :> abstract); + if destroy then !current#destroy; + current := (engine : #t :> t) + +let iter block = !current#iter block +let on_readable fd f = !current#on_readable fd f +let on_writable fd f = !current#on_writable fd f +let on_timer delay repeat f = !current#on_timer delay repeat f +let fake_io fd = !current#fake_io fd +let readable_count () = !current#readable_count +let writable_count () = !current#writable_count +let timer_count () = !current#timer_count diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_engine.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_engine.mli new file mode 100644 index 0000000..d9ca9dd --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_engine.mli @@ -0,0 +1,194 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_engine + * Copyright (C) 2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Lwt unix main loop engine *) + +(** {6 Events} *) + +type event + (** Type of events. An event represent a callback registered to be + called when some event occurs. *) + +val stop_event : event -> unit + (** [stop_event event] stops the given event. *) + +val fake_event : event + (** Event which does nothing when stopped. *) + +(** {6 Event loop functions} *) + +val iter : bool -> unit + (** [iter block] performs one iteration of the main loop. If [block] + is [true] the function must blocks until one event become + available, otherwise it should just check for available events + and return immediatly. *) + +val on_readable : Unix.file_descr -> (event -> unit) -> event + (** [on_readable fd f] calls [f] each time [fd] becomes readable. *) + +val on_writable : Unix.file_descr -> (event -> unit) -> event + (** [on_readable fd f] calls [f] each time [fd] becomes writable. *) + +val on_timer : float -> bool -> (event -> unit) -> event + (** [on_timer delay repeat f] calls [f] one time after [delay] + seconds. If [repeat] is [true] then [f] is called each [delay] + seconds, otherwise it is called only one time. *) + +val readable_count : unit -> int + (** Returns the number of events waiting for a file descriptor to + become readable. *) + +val writable_count : unit -> int + (** Returns the number of events waiting for a file descriptor to + become writable. *) + +val timer_count : unit -> int + (** Returns the number of registered timers. *) + +val fake_io : Unix.file_descr -> unit + (** Simulates activity on the given file descriptor. *) + +(** {6 Engines} *) + +(** An engine represent a set of functions used to register different + kind of callbacks for different kind of events. *) + +(** Abstract class for engines. *) +class virtual abstract : object + method destroy : unit + (** Destroy the engine, remove all its events and free its + associated resources. *) + + method transfer : abstract -> unit + (** [transfer engine] moves all events from the current engine to + [engine]. Note that timers are reset in the destination + engine, i.e. if a timer with a delay of 2 seconds was + registered 1 second ago it will occurs in 2 seconds in the + destination engine. *) + + (** {6 Event loop methods} *) + + method virtual iter : bool -> unit + method on_readable : Unix.file_descr -> (event -> unit) -> event + method on_writable : Unix.file_descr -> (event -> unit) -> event + method on_timer : float -> bool -> (event -> unit) -> event + method fake_io : Unix.file_descr -> unit + method readable_count : int + method writable_count : int + method timer_count : int + + (** {6 Backend methods} *) + + (** Notes: + + - the callback passed to register methods is of type [unit -> + unit] and not [event -> unit] + - register methods returns a lazy value which unregister the + event when forced + *) + + method virtual private cleanup : unit + (** Cleanup resources associated to the engine. *) + + method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t + method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t + method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t +end + +(** Type of engines. *) +class type t = object + inherit abstract + + method iter : bool -> unit + method private cleanup : unit + method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t + method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t + method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t +end + +(** {6 Predefined engines} *) + +type ev_loop + (** Type of libev loops. *) + +(** Engine based on libev. If not compiled with libev support, the + creation of the class will raise {!Lwt_sys.Not_available}. *) +class libev : object + inherit t + + val loop : ev_loop + (** The libev loop used for this engine. *) + + method loop : ev_loop + (** Returns [loop]. *) +end + +(** Engine based on [Unix.select]. *) +class select : t + +(** Abstract class for engines based on a select-like function. *) +class virtual select_based : object + inherit t + + method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list + (** [select fds_r fds_w timeout] waits for either: + + - one of the file descriptor of [fds_r] to become readable + - one of the file descriptor of [fds_w] to become writable + - timeout to expire + + and returns the list of readable file descriptor and the list + of writable file descriptors. *) +end + +(** Abstract class for engines based on a poll-like function. *) +class virtual poll_based : object + inherit t + + method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list + (** [poll fds tiomeout], where [fds] is a list of tuples of the + form [(fd, check_readable, check_writable)], waits for either: + + - one of the file descriptor with [check_readable] set to + [true] to become readable + - one of the file descriptor with [check_writable] set to + [true] to become writable + - timeout to expire + + and returns the list of file descriptors with their readable + and writable status. *) +end + +(** {6 The current engine} *) + +val get : unit -> t + (** [get ()] returns the engine currently in use. *) + +val set : ?transfer : bool -> ?destroy : bool -> #t -> unit + (** [set ?transfer ?destroy engine] replaces the current engine by + the given one. + + If [transfer] is [true] (the default) all events from the + current engine are transferred to the new one. + + If [destroy] is [true] (the default) then the current engine is + destroyed before being replaced. *) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_gc.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_gc.ml new file mode 100644 index 0000000..ff48236 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_gc.ml @@ -0,0 +1,62 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_gc + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +let ensure_termination t = + if Lwt.state t = Lwt.Sleep then begin + let hook = Lwt_sequence.add_l (fun _ -> t) Lwt_main.exit_hooks in + (* Remove the hook when t has terminated *) + ignore (try_lwt t finally Lwt_sequence.remove hook; Lwt.return ()) + end + +let finaliser f x = + ensure_termination (f x) + +let finalise f = Gc.finalise (finaliser f) + +(* Exit hook for a finalise_or_exit *) +let foe_exit f weak _ = + match Weak.get weak 0 with + | None -> + (* The value has been garbage collected, normally this point + is never reached *) + Lwt.return () + | Some x -> + (* Just to avoid double finalisation *) + Weak.set weak 0 None; + f x + +(* Finaliser for a finalise_or_exit *) +let foe_finalise f hook weak x = + (* Remove the exit hook, it is not needed anymore *) + Lwt_sequence.remove hook; + (* This should not be necessary, i am just paranoid: *) + Weak.set weak 0 None; + (* Finally call the real finaliser: *) + finaliser f x + +let finalise_or_exit f x = + (* Create a weak pointer, so the exit-hook will prevent [x] from + being garbage collected: *) + let weak = Weak.create 1 in + Weak.set weak 0 (Some x); + let hook = Lwt_sequence.add_l (foe_exit f weak) Lwt_main.exit_hooks in + Gc.finalise (foe_finalise f hook weak) x diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_gc.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_gc.mli new file mode 100644 index 0000000..3adaa6f --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_gc.mli @@ -0,0 +1,36 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_gc + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Interaction with the garbage collector *) + +(** This module offer a convenient way to add a finaliser launching a + thread to a value, without having to use [Lwt_unix.run] in the + finaliser. *) + +val finalise : ('a -> unit Lwt.t) -> 'a -> unit + (** [finalise f x] calls [f x] when [x] is garbage collected. If [f + x] yields, then Lwt will waits for its termination at the end of + the program. *) + +val finalise_or_exit : ('a -> unit Lwt.t) -> 'a -> unit + (** [finalise_or_exit f x] call [f x] when [x] is garbage collected + or (exclusively) when the program exit. *) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_io.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_io.ml new file mode 100644 index 0000000..201f476 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_io.ml @@ -0,0 +1,1501 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_io + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt + +exception Channel_closed of string + +(* Minimum size for buffers: *) +let min_buffer_size = 16 + +let check_buffer_size fun_name buffer_size = + if buffer_size < min_buffer_size then + Printf.ksprintf invalid_arg "Lwt_io.%s: too small buffer size (%d)" fun_name buffer_size + else if buffer_size > Sys.max_string_length then + Printf.ksprintf invalid_arg "Lwt_io.%s: too big buffer size (%d)" fun_name buffer_size + else + () + +let default_buffer_size = ref 4096 + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +type input +type output + +#if ocaml_version >= (3, 13) +type 'a mode = + | Input : input mode + | Output : output mode +#else +type 'a mode = + | Input + | Output +#endif + +let input : input mode = Input +let output : output mode = Output + +(* A channel state *) +type 'mode state = + | Busy_primitive + (* A primitive is running on the channel *) + + | Busy_atomic of 'mode channel + (* An atomic operations is being performed on the channel. The + argument is the temporary atomic wrapper. *) + + | Waiting_for_busy + (* A queued operation has not yet started. *) + + | Idle + (* The channel is unused *) + + | Closed + (* The channel has been closed *) + + | Invalid + (* The channel is a temporary channel created for an atomic + operation which has terminated. *) + +(* A wrapper, which ensures that io operations are atomic: *) +and 'mode channel = { + mutable state : 'mode state; + + channel : 'mode _channel; + (* The real channel *) + + mutable queued : unit Lwt.u Lwt_sequence.t; + (* Queued operations *) +} + +and 'mode _channel = { + mutable buffer : Lwt_bytes.t; + mutable length : int; + + mutable ptr : int; + (* Current position *) + + mutable max : int; + (* Position of the end of data int the buffer. It is equal to + [length] for output channels. *) + + abort_waiter : int Lwt.t; + (* Thread which is wakeup with an exception when the channel is + closed. *) + abort_wakener : int Lwt.u; + + mutable auto_flushing : bool; + (* Wether the auto-flusher is currently running or not *) + + main : 'mode channel; + (* The main wrapper *) + + close : unit Lwt.t Lazy.t; + (* Close function *) + + mode : 'mode mode; + (* The channel mode *) + + mutable offset : int64; + (* Number of bytes really read/written *) + + typ : typ; + (* Type of the channel. *) +} + +and typ = + | Type_normal of (Lwt_bytes.t -> int -> int -> int Lwt.t) * (int64 -> Unix.seek_command -> int64 Lwt.t) + (* The channel has been created with [make]. The first argument + is the refill/flush function and the second is the seek + function. *) + | Type_bytes + (* The channel has been created with [of_bytes]. *) + +type input_channel = input channel +type output_channel = output channel + +type direct_access = { + da_buffer : Lwt_bytes.t; + mutable da_ptr : int; + mutable da_max : int; + da_perform : unit -> int Lwt.t; +} + +let mode wrapper = wrapper.channel.mode + +(* +-----------------------------------------------------------------+ + | Creations, closing, locking, ... | + +-----------------------------------------------------------------+ *) + +module Outputs = Weak.Make(struct + type t = output_channel + let hash = Hashtbl.hash + let equal = ( == ) + end) + +(* Table of all opened output channels. On exit they are all + flushed: *) +let outputs = Outputs.create 32 + +#if ocaml_version >= (3, 13) +let position : type mode. mode channel -> int64 = fun wrapper -> +#else +let position wrapper = +#endif + let ch = wrapper.channel in + match ch.mode with + | Input -> + Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) + | Output -> + Int64.add ch.offset (Int64.of_int ch.ptr) + +#if ocaml_version >= (3, 13) +let name : type mode. mode _channel -> string = fun ch -> +#else +let name ch = +#endif + match ch.mode with + | Input -> "input" + | Output -> "output" + +let closed_channel ch = Channel_closed(name ch) +let invalid_channel ch = Failure(Printf.sprintf "temporary atomic %s channel no more valid" (name ch)) + +let is_busy ch = + match ch.state with + | Invalid -> + raise (invalid_channel ch.channel) + | Idle | Closed -> + false + | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> + true + +(* Flush/refill the buffer. No race condition could happen because + this function is always called atomically: *) +#if ocaml_version >= (3, 13) +let perform_io : type mode. mode _channel -> int Lwt.t = fun ch -> match ch.main.state with +#else +let perform_io ch = match ch.main.state with +#endif + | Busy_primitive | Busy_atomic _ -> begin + match ch.typ with + | Type_normal(perform_io, seek) -> + let ptr, len = match ch.mode with + | Input -> + (* Size of data in the buffer *) + let size = ch.max - ch.ptr in + (* If there are still data in the buffer, keep them: *) + if size > 0 then Lwt_bytes.unsafe_blit ch.buffer ch.ptr ch.buffer 0 size; + (* Update positions: *) + ch.ptr <- 0; + ch.max <- size; + (size, ch.length - size) + | Output -> + (0, ch.ptr) in + lwt n = pick [ch.abort_waiter; perform_io ch.buffer ptr len] in + (* Never trust user functions... *) + if n < 0 || n > len then + raise_lwt (Failure (Printf.sprintf "Lwt_io: invalid result of the [%s] function(request=%d,result=%d)" + (match ch.mode with Input -> "read" | Output -> "write") len n)) + else begin + (* Update the global offset: *) + ch.offset <- Int64.add ch.offset (Int64.of_int n); + (* Update buffer positions: *) + begin match ch.mode with + | Input -> + ch.max <- ch.max + n + | Output -> + (* Shift remaining data: *) + let len = len - n in + Lwt_bytes.unsafe_blit ch.buffer n ch.buffer 0 len; + ch.ptr <- len + end; + return n + end + + | Type_bytes -> begin + match ch.mode with + | Input -> + return 0 + | Output -> + raise_lwt (Failure "cannot flush a channel created with Lwt_io.of_string") + end + end + + | Closed -> + raise_lwt (closed_channel ch) + + | Invalid -> + raise_lwt (invalid_channel ch) + + | Idle | Waiting_for_busy -> + assert false + +let refill = perform_io +let flush_partial = perform_io + +let rec flush_total oc = + if oc.ptr > 0 then + lwt _ = flush_partial oc in + flush_total oc + else + return () + +let safe_flush_total oc = + try_lwt + flush_total oc + with + _ -> return () + +let deepest_wrapper ch = + let rec loop wrapper = + match wrapper.state with + | Busy_atomic wrapper -> + loop wrapper + | _ -> + wrapper + in + loop ch.main + +let auto_flush oc = + lwt () = Lwt.pause () in + let wrapper = deepest_wrapper oc in + match wrapper.state with + | Busy_primitive | Waiting_for_busy -> + (* The channel is used, cancel auto flushing. It will be + restarted when the channel returns to the [Idle] state: *) + oc.auto_flushing <- false; + return () + + | Busy_atomic _ -> + (* Cannot happen since we took the deepest wrapper: *) + assert false + + | Idle -> + oc.auto_flushing <- false; + wrapper.state <- Busy_primitive; + lwt () = safe_flush_total oc in + if wrapper.state = Busy_primitive then + wrapper.state <- Idle; + if not (Lwt_sequence.is_empty wrapper.queued) then + wakeup_later (Lwt_sequence.take_l wrapper.queued) (); + return () + + | Closed | Invalid -> + return () + +(* A ``locked'' channel is a channel in the state [Busy_primitive] or + [Busy_atomic] *) + +#if ocaml_version >= (3, 13) +let unlock : type m. m channel -> unit = fun wrapper -> match wrapper.state with +#else +let unlock wrapper = match wrapper.state with +#endif + | Busy_primitive | Busy_atomic _ -> + if Lwt_sequence.is_empty wrapper.queued then + wrapper.state <- Idle + else begin + wrapper.state <- Waiting_for_busy; + wakeup_later (Lwt_sequence.take_l wrapper.queued) () + end; + (* Launches the auto-flusher: *) + let ch = wrapper.channel in + if (* Launch the auto-flusher only if the channel is not busy: *) + (wrapper.state = Idle && + (* Launch the auto-flusher only for output channel: *) + (match ch.mode with Input -> false | Output -> true) && + (* Do not launch two auto-flusher: *) + not ch.auto_flushing && + (* Do not launch the auto-flusher if operations are queued: *) + Lwt_sequence.is_empty wrapper.queued) then begin + ch.auto_flushing <- true; + ignore (auto_flush ch) + end + + | Closed | Invalid -> + (* Do not change channel state if the channel has been closed *) + if not (Lwt_sequence.is_empty wrapper.queued) then + wakeup_later (Lwt_sequence.take_l wrapper.queued) () + + | Idle | Waiting_for_busy -> + (* We must never unlock an unlocked channel *) + assert false + +(* Wrap primitives into atomic io operations: *) +let primitive f wrapper = match wrapper.state with + | Idle -> + wrapper.state <- Busy_primitive; + try_lwt + f wrapper.channel + finally + unlock wrapper; + return () + + | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> + let (res, w) = task () in + let node = Lwt_sequence.add_r w wrapper.queued in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + lwt () = res in + begin match wrapper.state with + | Closed -> + (* The channel has been closed while we were waiting *) + unlock wrapper; + raise_lwt (closed_channel wrapper.channel) + + | Idle | Waiting_for_busy -> + wrapper.state <- Busy_primitive; + try_lwt + f wrapper.channel + finally + unlock wrapper; + return () + + | Invalid -> + raise_lwt (invalid_channel wrapper.channel) + + | Busy_primitive | Busy_atomic _ -> + assert false + end + + | Closed -> + raise_lwt (closed_channel wrapper.channel) + + | Invalid -> + raise_lwt (invalid_channel wrapper.channel) + +(* Wrap a sequence of io operations into an atomic operation: *) +let atomic f wrapper = match wrapper.state with + | Idle -> + let tmp_wrapper = { state = Idle; + channel = wrapper.channel; + queued = Lwt_sequence.create () } in + wrapper.state <- Busy_atomic tmp_wrapper; + try_lwt + f tmp_wrapper + finally + (* The temporary wrapper is no more valid: *) + tmp_wrapper.state <- Invalid; + unlock wrapper; + return () + + | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> + let (res, w) = task () in + let node = Lwt_sequence.add_r w wrapper.queued in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + lwt () = res in + begin match wrapper.state with + | Closed -> + (* The channel has been closed while we were waiting *) + unlock wrapper; + raise_lwt (closed_channel wrapper.channel) + + | Idle | Waiting_for_busy -> + let tmp_wrapper = { state = Idle; + channel = wrapper.channel; + queued = Lwt_sequence.create () } in + wrapper.state <- Busy_atomic tmp_wrapper; + try_lwt + f tmp_wrapper + finally + tmp_wrapper.state <- Invalid; + unlock wrapper; + return () + + | Invalid -> + raise_lwt (invalid_channel wrapper.channel) + + | Busy_primitive | Busy_atomic _ -> + assert false + end + + | Closed -> + raise_lwt (closed_channel wrapper.channel) + + | Invalid -> + raise_lwt (invalid_channel wrapper.channel) + +let rec abort wrapper = match wrapper.state with + | Busy_atomic tmp_wrapper -> + (* Close the depest opened wrapper: *) + abort tmp_wrapper + | Closed -> + (* Double close, just returns the same thing as before *) + Lazy.force wrapper.channel.close + | Invalid -> + raise_lwt (invalid_channel wrapper.channel) + | Idle | Busy_primitive | Waiting_for_busy -> + wrapper.state <- Closed; + (* Abort any current real reading/writing operation on the + channel: *) + wakeup_exn wrapper.channel.abort_wakener (closed_channel wrapper.channel); + Lazy.force wrapper.channel.close + +#if ocaml_version >= (3, 13) +let close : type mode. mode channel -> unit Lwt.t = fun wrapper -> +#else +let close wrapper = +#endif + let channel = wrapper.channel in + if channel.main != wrapper then + raise_lwt (Failure "Lwt_io.close: cannot close a channel obtained via Lwt_io.atomic") + else + match channel.mode with + | Input -> + (* Just close it now: *) + abort wrapper + | Output -> + try_lwt + (* Performs all pending actions, flush the buffer, then + close it: *) + primitive (fun channel -> safe_flush_total channel >> abort wrapper) wrapper + with _ -> + abort wrapper + +let flush_all () = + let wrappers = Outputs.fold (fun x l -> x :: l) outputs [] in + Lwt_list.iter_p + (fun wrapper -> + try_lwt + primitive safe_flush_total wrapper + with _ -> + return ()) + wrappers + +let () = + (* Flush all opened ouput channels on exit: *) + Lwt_main.at_exit flush_all + +let no_seek pos cmd = + raise_lwt (Failure "Lwt_io.seek: seek not supported on this channel") + +#if ocaml_version < (3, 13) +external unsafe_output : 'a channel -> output channel = "%identity" +#endif + +#if ocaml_version >= (3, 13) +let make : + type m. + ?buffer_size : int -> + ?close : (unit -> unit Lwt.t) -> + ?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) -> + mode : m mode -> + (Lwt_bytes.t -> int -> int -> int Lwt.t) -> + m channel = fun ?buffer_size ?(close=return) ?(seek=no_seek) ~mode perform_io -> +#else +let make ?buffer_size ?(close=return) ?(seek=no_seek) ~mode perform_io = +#endif + let size = + match buffer_size with + | None -> + !default_buffer_size + | Some size -> + check_buffer_size "Lwt_io.make" size; + size + in + let buffer = Lwt_bytes.create size and abort_waiter, abort_wakener = Lwt.wait () in + let rec ch = { + buffer = buffer; + length = size; + ptr = 0; + max = (match mode with + | Input -> 0 + | Output -> size); + close = lazy(try_lwt close ()); + abort_waiter = abort_waiter; + abort_wakener = abort_wakener; + main = wrapper; + auto_flushing = false; + mode = mode; + offset = 0L; + typ = Type_normal(perform_io, fun pos cmd -> try seek pos cmd with e -> raise_lwt e); + } and wrapper = { + state = Idle; + channel = ch; + queued = Lwt_sequence.create (); + } in +#if ocaml_version < (3, 13) + if mode = Output then Outputs.add outputs (unsafe_output wrapper); +#else + (match mode with + | Input -> () + | Output -> Outputs.add outputs wrapper); +#endif + wrapper + +let of_bytes ~mode bytes = + let length = Lwt_bytes.length bytes in + let abort_waiter, abort_wakener = Lwt.wait () in + let rec ch = { + buffer = bytes; + length = length; + ptr = 0; + max = length; + close = lazy(return ()); + abort_waiter = abort_waiter; + abort_wakener = abort_wakener; + main = wrapper; + (* Auto flush is set to [true] to prevent writing functions from + trying to launch the auto-fllushed. *) + auto_flushing = true; + mode = mode; + offset = 0L; + typ = Type_bytes; + } and wrapper = { + state = Idle; + channel = ch; + queued = Lwt_sequence.create (); + } in + wrapper + +let of_string ~mode str = of_bytes ~mode (Lwt_bytes.of_string str) + +#if ocaml_version >= (3, 13) +let of_fd : type m. ?buffer_size : int -> ?close : (unit -> unit Lwt.t) -> mode : m mode -> Lwt_unix.file_descr -> m channel = fun ?buffer_size ?close ~mode fd -> +#else +let of_fd ?buffer_size ?close ~mode fd = +#endif + let perform_io = match mode with + | Input -> Lwt_bytes.read fd + | Output -> Lwt_bytes.write fd + in + make + ?buffer_size + ~close:(match close with + | Some f -> f + | None -> (fun () -> Lwt_unix.close fd)) + ~seek:(fun pos cmd -> Lwt_unix.LargeFile.lseek fd pos cmd) + ~mode + perform_io + +#if ocaml_version >= (3, 13) +let of_unix_fd : type m. ?buffer_size : int -> ?close : (unit -> unit Lwt.t) -> mode : m mode -> Unix.file_descr -> m channel = fun ?buffer_size ?close ~mode fd -> +#else +let of_unix_fd ?buffer_size ?close ~mode fd = +#endif + of_fd ?buffer_size ?close ~mode (Lwt_unix.of_unix_file_descr fd) + +#if ocaml_version >= (3, 13) +let buffered : type m. m channel -> int = fun ch -> +#else +let buffered ch = +#endif + match ch.channel.mode with + | Input -> ch.channel.max - ch.channel.ptr + | Output -> ch.channel.ptr + +let buffer_size ch = ch.channel.length + +#if ocaml_version >= (3, 13) +let resize_buffer : type m. m channel -> int -> unit Lwt.t = fun wrapper len -> +#else +let resize_buffer wrapper len = +#endif + if len < min_buffer_size then invalid_arg "Lwt_io.resize_buffer"; + match wrapper.channel.typ with + | Type_bytes -> + raise_lwt (Failure "Lwt_io.resize_buffer: cannot resize the buffer of a channel created with Lwt_io.of_string") + | Type_normal _ -> +#if ocaml_version >= (3, 13) + let f : type m. m _channel -> unit Lwt.t = fun ch -> +#else + let f ch = +#endif + match ch.mode with + | Input -> + let unread_count = ch.max - ch.ptr in + (* Fail if we want to decrease the buffer size and there is + too much unread data in the buffer: *) + if len < unread_count then + raise_lwt (Failure "Lwt_io.resize_buffer: cannot decrease buffer size") + else begin + let buffer = Lwt_bytes.create len in + Lwt_bytes.unsafe_blit ch.buffer ch.ptr buffer 0 unread_count; + ch.buffer <- buffer; + ch.length <- len; + ch.ptr <- 0; + ch.max <- unread_count; + return () + end + | Output -> + (* If we decrease the buffer size, flush the buffer until + the number of buffered bytes fits into the new buffer: *) + let rec loop () = + if ch.ptr > len then + lwt _ = flush_partial ch in + loop () + else + return () + in + lwt () = loop () in + let buffer = Lwt_bytes.create len in + Lwt_bytes.unsafe_blit ch.buffer 0 buffer 0 ch.ptr; + ch.buffer <- buffer; + ch.length <- len; + ch.max <- len; + return () + in + primitive f wrapper + +(* +-----------------------------------------------------------------+ + | Byte-order | + +-----------------------------------------------------------------+ *) + +module ByteOrder = +struct + module type S = sig + val pos16_0 : int + val pos16_1 : int + val pos32_0 : int + val pos32_1 : int + val pos32_2 : int + val pos32_3 : int + val pos64_0 : int + val pos64_1 : int + val pos64_2 : int + val pos64_3 : int + val pos64_4 : int + val pos64_5 : int + val pos64_6 : int + val pos64_7 : int + end + + module LE = + struct + let pos16_0 = 0 + let pos16_1 = 1 + let pos32_0 = 0 + let pos32_1 = 1 + let pos32_2 = 2 + let pos32_3 = 3 + let pos64_0 = 0 + let pos64_1 = 1 + let pos64_2 = 2 + let pos64_3 = 3 + let pos64_4 = 4 + let pos64_5 = 5 + let pos64_6 = 6 + let pos64_7 = 7 + end + + module BE = + struct + let pos16_0 = 1 + let pos16_1 = 0 + let pos32_0 = 3 + let pos32_1 = 2 + let pos32_2 = 1 + let pos32_3 = 0 + let pos64_0 = 7 + let pos64_1 = 6 + let pos64_2 = 5 + let pos64_3 = 4 + let pos64_4 = 3 + let pos64_5 = 2 + let pos64_6 = 1 + let pos64_7 = 0 + end +end + +module Primitives = +struct + + (* This module contains all primitives operations. The operates + without protection regarding locking, they are wrapped after into + safe operations. *) + + (* +---------------------------------------------------------------+ + | Reading | + +---------------------------------------------------------------+ *) + + let rec read_char ic = + let ptr = ic.ptr in + if ptr = ic.max then + refill ic >>= function + | 0 -> raise_lwt End_of_file + | _ -> read_char ic + else begin + ic.ptr <- ptr + 1; + return (Lwt_bytes.unsafe_get ic.buffer ptr) + end + + let read_char_opt ic = + try_lwt + read_char ic >|= fun ch -> Some ch + with End_of_file -> + return None + + let read_line ic = + let buf = Buffer.create 128 in + let rec loop cr_read = + try_bind (fun _ -> read_char ic) + (function + | '\n' -> + return(Buffer.contents buf) + | '\r' -> + if cr_read then Buffer.add_char buf '\r'; + loop true + | ch -> + if cr_read then Buffer.add_char buf '\r'; + Buffer.add_char buf ch; + loop false) + (function + | End_of_file -> + if cr_read then Buffer.add_char buf '\r'; + return(Buffer.contents buf) + | exn -> + raise_lwt exn) + in + read_char ic >>= function + | '\r' -> loop true + | '\n' -> return "" + | ch -> Buffer.add_char buf ch; loop false + + let read_line_opt ic = + try_lwt + read_line ic >|= fun ch -> Some ch + with End_of_file -> + return None + + let unsafe_read_into ic str ofs len = + let avail = ic.max - ic.ptr in + if avail > 0 then begin + let len = min len avail in + Lwt_bytes.unsafe_blit_bytes_string ic.buffer ic.ptr str ofs len; + ic.ptr <- ic.ptr + len; + return len + end else begin + refill ic >>= fun n -> + let len = min len n in + Lwt_bytes.unsafe_blit_bytes_string ic.buffer 0 str ofs len; + ic.ptr <- len; + ic.max <- n; + return len + end + + let read_into ic str ofs len = + if ofs < 0 || len < 0 || ofs + len > String.length str then + raise_lwt (Invalid_argument (Printf.sprintf + "Lwt_io.read_into(ofs=%d,len=%d,str_len=%d)" + ofs len (String.length str))) + else begin + if len = 0 then + return 0 + else + unsafe_read_into ic str ofs len + end + + let rec unsafe_read_into_exactly ic str ofs len = + unsafe_read_into ic str ofs len >>= function + | 0 -> + raise_lwt End_of_file + | n -> + let len = len - n in + if len = 0 then + return () + else + unsafe_read_into_exactly ic str (ofs + n) len + + let read_into_exactly ic str ofs len = + if ofs < 0 || len < 0 || ofs + len > String.length str then + raise_lwt (Invalid_argument (Printf.sprintf + "Lwt_io.read_into_exactly(ofs=%d,len=%d,str_len=%d)" + ofs len (String.length str))) + else begin + if len = 0 then + return () + else + unsafe_read_into_exactly ic str ofs len + end + + let rev_concat len l = + let buf = String.create len in + let _ = + List.fold_left + (fun ofs str -> + let len = String.length str in + let ofs = ofs - len in + String.unsafe_blit str 0 buf ofs len; + ofs) + len l + in + buf + + let rec read_all ic total_len acc = + let len = ic.max - ic.ptr in + let str = String.create len in + Lwt_bytes.unsafe_blit_bytes_string ic.buffer ic.ptr str 0 len; + ic.ptr <- ic.max; + refill ic >>= function + | 0 -> + return (rev_concat (len + total_len) (str :: acc)) + | n -> + read_all ic (len + total_len) (str :: acc) + + let read count ic = + match count with + | None -> + read_all ic 0 [] + | Some len -> + let str = String.create len in + lwt real_len = unsafe_read_into ic str 0 len in + if real_len < len then + return (String.sub str 0 real_len) + else + return str + + let read_value ic = + let header = String.create 20 in + lwt () = unsafe_read_into_exactly ic header 0 20 in + let bsize = Marshal.data_size header 0 in + let buffer = String.create (20 + bsize) in + String.unsafe_blit header 0 buffer 0 20; + lwt () = unsafe_read_into_exactly ic buffer 20 bsize in + return (Marshal.from_string buffer 0) + + (* +---------------------------------------------------------------+ + | Writing | + +---------------------------------------------------------------+ *) + + let flush = flush_total + + let rec write_char oc ch = + let ptr = oc.ptr in + if ptr < oc.length then begin + oc.ptr <- ptr + 1; + Lwt_bytes.unsafe_set oc.buffer ptr ch; + return () + end else + lwt _ = flush_partial oc in + write_char oc ch + + let rec unsafe_write_from oc str ofs len = + let avail = oc.length - oc.ptr in + if avail >= len then begin + Lwt_bytes.unsafe_blit_string_bytes str ofs oc.buffer oc.ptr len; + oc.ptr <- oc.ptr + len; + return 0 + end else begin + Lwt_bytes.unsafe_blit_string_bytes str ofs oc.buffer oc.ptr avail; + oc.ptr <- oc.length; + lwt _ = flush_partial oc in + let len = len - avail in + if oc.ptr = 0 then begin + if len = 0 then + return 0 + else + (* Everything has been written, try to write more: *) + unsafe_write_from oc str (ofs + avail) len + end else + (* Not everything has been written, just what is + remaining: *) + return len + end + + let write_from oc str ofs len = + if ofs < 0 || len < 0 || ofs + len > String.length str then + raise_lwt (Invalid_argument (Printf.sprintf + "Lwt_io.write_from(ofs=%d,len=%d,str_len=%d)" + ofs len (String.length str))) + else begin + if len = 0 then + return 0 + else + unsafe_write_from oc str ofs len >>= fun remaining -> return (len - remaining) + end + + let rec unsafe_write_from_exactly oc str ofs len = + unsafe_write_from oc str ofs len >>= function + | 0 -> + return () + | n -> + unsafe_write_from_exactly oc str (ofs + len - n) n + + let write_from_exactly oc str ofs len = + if ofs < 0 || len < 0 || ofs + len > String.length str then + raise_lwt (Invalid_argument (Printf.sprintf + "Lwt_io.write_from_exactly(ofs=%d,len=%d,str_len=%d)" + ofs len (String.length str))) + else begin + if len = 0 then + return () + else + unsafe_write_from_exactly oc str ofs len + end + + let write oc str = + unsafe_write_from_exactly oc str 0 (String.length str) + + let write_line oc str = + lwt () = unsafe_write_from_exactly oc str 0 (String.length str) in + write_char oc '\n' + + let write_value oc ?(flags=[]) x = + write oc (Marshal.to_string x flags) + + (* +---------------------------------------------------------------+ + | Low-level access | + +---------------------------------------------------------------+ *) + + let rec read_block_unsafe ic size f = + if ic.max - ic.ptr < size then + refill ic >>= function + | 0 -> + raise_lwt End_of_file + | _ -> + read_block_unsafe ic size f + else begin + let ptr = ic.ptr in + ic.ptr <- ptr + size; + f ic.buffer ptr + end + + let rec write_block_unsafe oc size f = + if oc.max - oc.ptr < size then + lwt _ = flush_partial oc in + write_block_unsafe oc size f + else begin + let ptr = oc.ptr in + oc.ptr <- ptr + size; + f oc.buffer ptr + end + +#if ocaml_version >= (3, 13) + let block : type m. m _channel -> int -> (Lwt_bytes.t -> int -> 'a Lwt.t) -> 'a Lwt.t = fun ch size f -> +#else + let block ch size f = +#endif + if size < 0 || size > min_buffer_size then + raise_lwt (Invalid_argument(Printf.sprintf "Lwt_io.block(size=%d)" size)) + else + if ch.max - ch.ptr >= size then begin + let ptr = ch.ptr in + ch.ptr <- ptr + size; + f ch.buffer ptr + end else + match ch.mode with + | Input -> + read_block_unsafe ch size f + | Output -> + write_block_unsafe ch size f + + let perform token da ch = + if !token then begin + if da.da_max <> ch.max || da.da_ptr < ch.ptr || da.da_ptr > ch.max then + raise_lwt (Invalid_argument "Lwt_io.direct_access.perform") + else begin + ch.ptr <- da.da_ptr; + lwt count = perform_io ch in + da.da_ptr <- ch.ptr; + da.da_max <- ch.max; + return count + end + end else + raise_lwt (Failure "Lwt_io.direct_access.perform: this function can not be called outside Lwt_io.direct_access") + + let direct_access ch f = + let token = ref true in + let rec da = { + da_ptr = ch.ptr; + da_max = ch.max; + da_buffer = ch.buffer; + da_perform = (fun _ -> perform token da ch); + } in + lwt x = f da in + token := false; + if da.da_max <> ch.max || da.da_ptr < ch.ptr || da.da_ptr > ch.max then + raise_lwt (Failure "Lwt_io.direct_access: invalid result of [f]") + else begin + ch.ptr <- da.da_ptr; + return x + end + + module MakeNumberIO(ByteOrder : ByteOrder.S) = + struct + open ByteOrder + + (* +-------------------------------------------------------------+ + | Reading numbers | + +-------------------------------------------------------------+ *) + + let get buffer ptr = Char.code (Lwt_bytes.unsafe_get buffer ptr) + + let read_int ic = + read_block_unsafe ic 4 + (fun buffer ptr -> + let v0 = get buffer (ptr + pos32_0) + and v1 = get buffer (ptr + pos32_1) + and v2 = get buffer (ptr + pos32_2) + and v3 = get buffer (ptr + pos32_3) in + let v = v0 lor (v1 lsl 8) lor (v2 lsl 16) lor (v3 lsl 24) in + if v3 land 0x80 = 0 then + return v + else + return (v - (1 lsl 32))) + + let read_int16 ic = + read_block_unsafe ic 2 + (fun buffer ptr -> + let v0 = get buffer (ptr + pos16_0) + and v1 = get buffer (ptr + pos16_1) in + let v = v0 lor (v1 lsl 8) in + if v1 land 0x80 = 0 then + return v + else + return (v - (1 lsl 16))) + + let read_int32 ic = + read_block_unsafe ic 4 + (fun buffer ptr -> + let v0 = get buffer (ptr + pos32_0) + and v1 = get buffer (ptr + pos32_1) + and v2 = get buffer (ptr + pos32_2) + and v3 = get buffer (ptr + pos32_3) in + return (Int32.logor + (Int32.logor + (Int32.of_int v0) + (Int32.shift_left (Int32.of_int v1) 8)) + (Int32.logor + (Int32.shift_left (Int32.of_int v2) 16) + (Int32.shift_left (Int32.of_int v3) 24)))) + + let read_int64 ic = + read_block_unsafe ic 8 + (fun buffer ptr -> + let v0 = get buffer (ptr + pos64_0) + and v1 = get buffer (ptr + pos64_1) + and v2 = get buffer (ptr + pos64_2) + and v3 = get buffer (ptr + pos64_3) + and v4 = get buffer (ptr + pos64_4) + and v5 = get buffer (ptr + pos64_5) + and v6 = get buffer (ptr + pos64_6) + and v7 = get buffer (ptr + pos64_7) in + return (Int64.logor + (Int64.logor + (Int64.logor + (Int64.of_int v0) + (Int64.shift_left (Int64.of_int v1) 8)) + (Int64.logor + (Int64.shift_left (Int64.of_int v2) 16) + (Int64.shift_left (Int64.of_int v3) 24))) + (Int64.logor + (Int64.logor + (Int64.shift_left (Int64.of_int v4) 32) + (Int64.shift_left (Int64.of_int v5) 40)) + (Int64.logor + (Int64.shift_left (Int64.of_int v6) 48) + (Int64.shift_left (Int64.of_int v7) 56))))) + + let read_float32 ic = read_int32 ic >>= fun x -> return (Int32.float_of_bits x) + let read_float64 ic = read_int64 ic >>= fun x -> return (Int64.float_of_bits x) + + (* +-------------------------------------------------------------+ + | Writing numbers | + +-------------------------------------------------------------+ *) + + let set buffer ptr x = Lwt_bytes.unsafe_set buffer ptr (Char.unsafe_chr x) + + let write_int oc v = + write_block_unsafe oc 4 + (fun buffer ptr -> + set buffer (ptr + pos32_0) v; + set buffer (ptr + pos32_1) (v lsr 8); + set buffer (ptr + pos32_2) (v lsr 16); + set buffer (ptr + pos32_3) (v asr 24); + return ()) + + let write_int16 oc v = + write_block_unsafe oc 2 + (fun buffer ptr -> + set buffer (ptr + pos16_0) v; + set buffer (ptr + pos16_1) (v lsr 8); + return ()) + + let write_int32 oc v = + write_block_unsafe oc 4 + (fun buffer ptr -> + set buffer (ptr + pos32_0) (Int32.to_int v); + set buffer (ptr + pos32_1) (Int32.to_int (Int32.shift_right v 8)); + set buffer (ptr + pos32_2) (Int32.to_int (Int32.shift_right v 16)); + set buffer (ptr + pos32_3) (Int32.to_int (Int32.shift_right v 24)); + return ()) + + let write_int64 oc v = + write_block_unsafe oc 8 + (fun buffer ptr -> + set buffer (ptr + pos64_0) (Int64.to_int v); + set buffer (ptr + pos64_1) (Int64.to_int (Int64.shift_right v 8)); + set buffer (ptr + pos64_2) (Int64.to_int (Int64.shift_right v 16)); + set buffer (ptr + pos64_3) (Int64.to_int (Int64.shift_right v 24)); + set buffer (ptr + pos64_4) (Int64.to_int (Int64.shift_right v 32)); + set buffer (ptr + pos64_5) (Int64.to_int (Int64.shift_right v 40)); + set buffer (ptr + pos64_6) (Int64.to_int (Int64.shift_right v 48)); + set buffer (ptr + pos64_7) (Int64.to_int (Int64.shift_right v 56)); + return ()) + + let write_float32 oc v = write_int32 oc (Int32.bits_of_float v) + let write_float64 oc v = write_int64 oc (Int64.bits_of_float v) + end + + (* +---------------------------------------------------------------+ + | Random access | + +---------------------------------------------------------------+ *) + + let do_seek seek pos = + lwt offset = seek pos Unix.SEEK_SET in + if offset <> pos then + raise_lwt (Failure "Lwt_io.set_position: seek failed") + else + return () + +#if ocaml_version >= (3, 13) + let set_position : type m. m _channel -> int64 -> unit Lwt.t = fun ch pos -> match ch.typ, ch.mode with +#else + let set_position ch pos = match ch.typ, ch.mode with +#endif + | Type_normal(perform_io, seek), Output -> + lwt () = flush_total ch in + lwt () = do_seek seek pos in + ch.offset <- pos; + return () + | Type_normal(perform_io, seek), Input -> + let current = Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) in + if pos >= current && pos <= ch.offset then begin + ch.ptr <- ch.max - (Int64.to_int (Int64.sub ch.offset pos)); + return () + end else begin + lwt () = do_seek seek pos in + ch.offset <- pos; + ch.ptr <- 0; + ch.max <- 0; + return () + end + | Type_bytes, _ -> + if pos < 0L || pos > Int64.of_int ch.length then + raise_lwt (Failure "Lwt_io.set_position: out of bounds") + else begin + ch.ptr <- Int64.to_int pos; + return () + end + + let length ch = match ch.typ with + | Type_normal(perform_io, seek) -> + lwt len = seek 0L Unix.SEEK_END in + lwt () = do_seek seek ch.offset in + return len + | Type_bytes -> + return (Int64.of_int ch.length) +end + +(* +-----------------------------------------------------------------+ + | Primitive operations | + +-----------------------------------------------------------------+ *) + +let read_char wrapper = + let channel = wrapper.channel in + let ptr = channel.ptr in + (* Speed-up in case a character is available in the buffer. It + increases performances by 10x. *) + if wrapper.state = Idle && ptr < channel.max then begin + channel.ptr <- ptr + 1; + return (Lwt_bytes.unsafe_get channel.buffer ptr) + end else + primitive Primitives.read_char wrapper + +let read_char_opt wrapper = + let channel = wrapper.channel in + let ptr = channel.ptr in + if wrapper.state = Idle && ptr < channel.max then begin + channel.ptr <- ptr + 1; + return (Some(Lwt_bytes.unsafe_get channel.buffer ptr)) + end else + primitive Primitives.read_char_opt wrapper + +let read_line ic = primitive Primitives.read_line ic +let read_line_opt ic = primitive Primitives.read_line_opt ic +let read ?count ic = primitive (fun ic -> Primitives.read count ic) ic +let read_into ic str ofs len = primitive (fun ic -> Primitives.read_into ic str ofs len) ic +let read_into_exactly ic str ofs len = primitive (fun ic -> Primitives.read_into_exactly ic str ofs len) ic +let read_value ic = primitive Primitives.read_value ic + +let flush oc = primitive Primitives.flush oc + +let write_char wrapper x = + let channel = wrapper.channel in + let ptr = channel.ptr in + if wrapper.state = Idle && ptr < channel.max then begin + channel.ptr <- ptr + 1; + Lwt_bytes.unsafe_set channel.buffer ptr x; + (* Fast launching of the auto flusher: *) + if not channel.auto_flushing then begin + channel.auto_flushing <- true; + ignore (auto_flush channel); + return () + end else + return () + end else + primitive (fun oc -> Primitives.write_char oc x) wrapper + +let write oc str = primitive (fun oc -> Primitives.write oc str) oc +let write_line oc x = primitive (fun oc -> Primitives.write_line oc x) oc +let write_from oc str ofs len = primitive (fun oc -> Primitives.write_from oc str ofs len) oc +let write_from_exactly oc str ofs len = primitive (fun oc -> Primitives.write_from_exactly oc str ofs len) oc +let write_value oc ?flags x = primitive (fun oc -> Primitives.write_value oc ?flags x) oc + +let block ch size f = primitive (fun ch -> Primitives.block ch size f) ch +let direct_access ch f = primitive (fun ch -> Primitives.direct_access ch f) ch + +let set_position ch pos = primitive (fun ch -> Primitives.set_position ch pos) ch +let length ch = primitive Primitives.length ch + +module type NumberIO = sig + val read_int : input_channel -> int Lwt.t + val read_int16 : input_channel -> int Lwt.t + val read_int32 : input_channel -> int32 Lwt.t + val read_int64 : input_channel -> int64 Lwt.t + val read_float32 : input_channel -> float Lwt.t + val read_float64 : input_channel -> float Lwt.t + val write_int : output_channel -> int -> unit Lwt.t + val write_int16 : output_channel -> int -> unit Lwt.t + val write_int32 : output_channel -> int32 -> unit Lwt.t + val write_int64 : output_channel -> int64 -> unit Lwt.t + val write_float32 : output_channel -> float -> unit Lwt.t + val write_float64 : output_channel -> float -> unit Lwt.t +end + +module MakeNumberIO(ByteOrder : ByteOrder.S) = +struct + module Primitives = Primitives.MakeNumberIO(ByteOrder) + + let read_int ic = primitive Primitives.read_int ic + let read_int16 ic = primitive Primitives.read_int16 ic + let read_int32 ic = primitive Primitives.read_int32 ic + let read_int64 ic = primitive Primitives.read_int64 ic + let read_float32 ic = primitive Primitives.read_float32 ic + let read_float64 ic = primitive Primitives.read_float64 ic + + let write_int oc x = primitive (fun oc -> Primitives.write_int oc x) oc + let write_int16 oc x = primitive (fun oc -> Primitives.write_int16 oc x) oc + let write_int32 oc x = primitive (fun oc -> Primitives.write_int32 oc x) oc + let write_int64 oc x = primitive (fun oc -> Primitives.write_int64 oc x) oc + let write_float32 oc x = primitive (fun oc -> Primitives.write_float32 oc x) oc + let write_float64 oc x = primitive (fun oc -> Primitives.write_float64 oc x) oc +end + +module LE = MakeNumberIO(ByteOrder.LE) +module BE = MakeNumberIO(ByteOrder.BE) + +type byte_order = Lwt_sys.byte_order = Little_endian | Big_endian +let system_byte_order = Lwt_sys.byte_order + +include (val (match system_byte_order with + | Little_endian -> (module LE : NumberIO) + | Big_endian -> (module BE : NumberIO)) : NumberIO) + +(* +-----------------------------------------------------------------+ + | Other | + +-----------------------------------------------------------------+ *) + +let read_chars ic = Lwt_stream.from (fun _ -> read_char_opt ic) +let write_chars oc chars = Lwt_stream.iter_s (fun char -> write_char oc char) chars +let read_lines ic = Lwt_stream.from (fun _ -> read_line_opt ic) +let write_lines oc lines = Lwt_stream.iter_s (fun line -> write_line oc line) lines + +let zero = + make + ~mode:input + ~buffer_size:min_buffer_size + (fun str ofs len -> Lwt_bytes.fill str ofs len '\x00'; return len) + +let null = + make + ~mode:output + ~buffer_size:min_buffer_size + (fun str ofs len -> return len) + +(* Do not close standard ios on close, otherwise uncaught exceptions + will not be printed *) +let stdin = of_fd ~mode:input Lwt_unix.stdin +let stdout = of_fd ~mode:output Lwt_unix.stdout +let stderr = of_fd ~mode:output Lwt_unix.stderr + +let fprint oc txt = write oc txt +let fprintl oc txt = write_line oc txt +let fprintf oc fmt = Printf.ksprintf (fun txt -> write oc txt) fmt +let fprintlf oc fmt = Printf.ksprintf (fun txt -> write_line oc txt) fmt + +let print txt = write stdout txt +let printl txt = write_line stdout txt +let printf fmt = Printf.ksprintf print fmt +let printlf fmt = Printf.ksprintf printl fmt + +let eprint txt = write stderr txt +let eprintl txt = write_line stderr txt +let eprintf fmt = Printf.ksprintf eprint fmt +let eprintlf fmt = Printf.ksprintf eprintl fmt + +let pipe ?buffer_size _ = + let fd_r, fd_w = Lwt_unix.pipe () in + (of_fd ?buffer_size ~mode:input fd_r, of_fd ?buffer_size ~mode:output fd_w) + +type file_name = string + +#if ocaml_version >= (3, 13) +let open_file : type m. ?buffer_size : int -> ?flags : Unix.open_flag list -> ?perm : Unix.file_perm -> mode : m mode -> file_name -> m channel Lwt.t = fun ?buffer_size ?flags ?perm ~mode filename -> +#else +let open_file ?buffer_size ?flags ?perm ~mode filename = +#endif + let flags = match flags, mode with + | Some l, _ -> + l + | None, Input -> + [Unix.O_RDONLY; Unix.O_NONBLOCK] + | None, Output -> + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK] + and perm = match perm, mode with + | Some p, _ -> + p + | None, Input -> + 0 + | None, Output -> + 0o666 + in + lwt fd = Lwt_unix.openfile filename flags perm in + return (of_fd ?buffer_size ~mode fd) + +let with_file ?buffer_size ?flags ?perm ~mode filename f = + lwt ic = open_file ?buffer_size ?flags ?perm ~mode filename in + try_lwt + f ic + finally + close ic + +let file_length filename = with_file ~mode:input filename length + +let open_connection ?buffer_size sockaddr = + let fd = Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in + let close = lazy begin + try_lwt + Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; + return () + with Unix.Unix_error(Unix.ENOTCONN, _, _) -> + (* This may happen if the server closed the connection before us *) + return () + finally + Lwt_unix.close fd + end in + try_lwt + lwt () = Lwt_unix.connect fd sockaddr in + (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); + return (make ?buffer_size + ~close:(fun _ -> Lazy.force close) + ~mode:input (Lwt_bytes.read fd), + make ?buffer_size + ~close:(fun _ -> Lazy.force close) + ~mode:output (Lwt_bytes.write fd)) + with exn -> + lwt () = Lwt_unix.close fd in + raise_lwt exn + +let with_connection ?buffer_size sockaddr f = + lwt ic, oc = open_connection ?buffer_size sockaddr in + try_lwt + f (ic, oc) + finally + close ic <&> close oc + +type server = { + shutdown : unit Lazy.t; +} + +let shutdown_server server = Lazy.force server.shutdown + +let establish_server ?buffer_size ?(backlog=5) sockaddr f = + let sock = Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in + Lwt_unix.setsockopt sock Unix.SO_REUSEADDR true; + Lwt_unix.bind sock sockaddr; + Lwt_unix.listen sock backlog; + let abort_waiter, abort_wakener = wait () in + let abort_waiter = abort_waiter >> return `Shutdown in + let rec loop () = + pick [Lwt_unix.accept sock >|= (fun x -> `Accept x); abort_waiter] >>= function + | `Accept(fd, addr) -> + (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); + let close = lazy begin + Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; + Lwt_unix.close fd + end in + f (of_fd ?buffer_size ~mode:input ~close:(fun () -> Lazy.force close) fd, + of_fd ?buffer_size ~mode:output ~close:(fun () -> Lazy.force close) fd); + loop () + | `Shutdown -> + lwt () = Lwt_unix.close sock in + match sockaddr with + | Unix.ADDR_UNIX path when path <> "" && path.[0] <> '\x00' -> + Unix.unlink path; + return () + | _ -> + return () + in + ignore (loop ()); + { shutdown = lazy(wakeup abort_wakener `Shutdown) } + +let ignore_close ch = + ignore (close ch) + +let make_stream f lazy_ic = + let lazy_ic = + lazy(lwt ic = Lazy.force lazy_ic in + Gc.finalise ignore_close ic; + return ic) + in + Lwt_stream.from (fun _ -> + lwt ic = Lazy.force lazy_ic in + lwt x = f ic in + if x = None then + lwt () = close ic in + return x + else + return x) + +let lines_of_file filename = + make_stream read_line_opt (lazy(open_file ~mode:input filename)) + +let lines_to_file filename lines = + with_file ~mode:output filename (fun oc -> write_lines oc lines) + +let chars_of_file filename = + make_stream read_char_opt (lazy(open_file ~mode:input filename)) + +let chars_to_file filename chars = + with_file ~mode:output filename (fun oc -> write_chars oc chars) + +let hexdump_stream oc stream = write_lines oc (Lwt_stream.hexdump stream) +let hexdump oc buf = hexdump_stream oc (Lwt_stream.of_string buf) + +let set_default_buffer_size size = + check_buffer_size "set_default_buffer_size" size; + default_buffer_size := size +let default_buffer_size _ = !default_buffer_size diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_io.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_io.mli new file mode 100644 index 0000000..ccac330 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_io.mli @@ -0,0 +1,522 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_io + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Buffered byte channels *) + +(** A {b channel} is a high-level object for performing IOs. It allow + to read/write things from/to the outside worlds in an efficient + way, by minimising the number of system calls. + + An {b output channel} is a channel that can be used to send data + and an {b input channel} is a channel that can used to receive + data. + + If you are familiar with buffered channels you may be familiar too + with the {b flush} operation. Note that byte channles of this + modules are automatically flushed when there is nothing else to do + (i.e. before the program goes into idle), so this means that you + no longer have to write: + + {[ + eprintf "log message\n"; + flush stderr; + ]} + + to have you messages displayed. + + Note about errors: input functions of this module raise + [End_of_file] when the end-of-file is reached (i.e. when the read + function returns [0]). Other exceptions are ones caused by the + backend read/write functions, such as [Unix.Unix_error]. +*) + +exception Channel_closed of string + (** Exception raised when a channel is closed. The parameter is a + description of the channel. *) + +(** {6 Types} *) + +type 'mode channel + (** Type of buffered byte channels *) + +type input + (** Input mode *) + +type output + (** Output mode *) + +(** Channel mode *) +#if ocaml_version >= (3, 13) +type 'a mode = + | Input : input mode + | Output : output mode +#else +type 'a mode = + private + | Input + | Output +#endif + +val input : input mode + (** [input] input mode representation *) + +val output : output mode + (** [output] output mode representation *) + +type input_channel = input channel + (** Type of input channels *) + +type output_channel = output channel + (** Type of output channels *) + +val mode : 'a channel -> 'a mode + (** [mode ch] returns the mode of a channel *) + +(** {6 Well-known instances} *) + +val stdin : input_channel + (** The standard input, it reads data from {!Lwt_unix.stdin} *) + +val stdout : output_channel + (** The standard output, it writes data to {!Lwt_unix.stdout} *) + +val stderr : output_channel + (** The standard output for error messages, it writes data to + {!Lwt_unix.stderr} *) + +val zero : input_channel + (** Inputs which returns always ['\x00'] *) + +val null : output_channel + (** Output which drops everything *) + +(** {6 Channels creation/manipulation} *) + +val pipe : ?buffer_size : int -> unit -> input_channel * output_channel + (** [pipe ?buffer_size ()] creates a pipe using {!Lwt_unix.pipe} and + makes two channels from the two returned file descriptors *) + +val make : + ?buffer_size : int -> + ?close : (unit -> unit Lwt.t) -> + ?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) -> + mode : 'mode mode -> + (Lwt_bytes.t -> int -> int -> int Lwt.t) -> 'mode channel + (** [make ?buffer_size ?close ~mode perform_io] is the + main function for creating new channels. + + @param buffer_size size of the internal buffer. It must be + between 16 and [Sys.max_string_length] + + @param close close function of the channel. It defaults to + [Lwt.return] + + @param seek same meaning as [Unix.lseek] + + @param mode either {!input} or {!output} + + @param perform_io is the read or write function. It is called + when more input is needed or when the buffer need to be + flushed. *) + +val of_bytes : mode : 'mode mode -> Lwt_bytes.t -> 'mode channel + (** Create a channel from a byte array. Reading/writing is done + directly on the provided array. *) + +val of_fd : ?buffer_size : int -> ?close : (unit -> unit Lwt.t) -> mode : 'mode mode -> Lwt_unix.file_descr -> 'mode channel + (** [of_fd ?buffer_size ?close ~mode fd] creates a channel from a + file descriptor. + + @param close defaults to closing the file descriptor. *) + +val of_unix_fd : ?buffer_size : int -> ?close : (unit -> unit Lwt.t) -> mode : 'mode mode -> Unix.file_descr -> 'mode channel + (** [of_unix_fd ?buffer_size ?close ~mode fd] is a short-hand for: + + [of_fd ?buffer_size ?close (Lwt_unix.of_unix_file_descr fd)] *) + +val close : 'a channel -> unit Lwt.t + (** [close ch] closes the given channel. If [ch] is an output + channel, it performs all pending actions, flush it and close + it. If [ch] is an input channel, it just close it immediatly. + + [close] returns the result of the close function of the + channel. Multiple calls to [close] will return exactly the same + value. + + Note: you cannot use [close] on channel obtained with an + {!atomic}. *) + +val abort : 'a channel -> unit Lwt.t + (** [abort ch] abort current operations and close the channel + immediatly. *) + +val atomic : ('a channel -> 'b Lwt.t) -> ('a channel -> 'b Lwt.t) + (** [atomic f] transforms a sequence of io operations into one + single atomic io operation. + + Note: + - the channel passed to [f] is invalid after [f] terminates + - [atomic] can be called inside another [atomic] *) + +val file_length : string -> int64 Lwt.t + (** Returns the length of a file *) + +val buffered : 'a channel -> int + (** [buffered oc] returns the number of bytes in the buffer *) + +val flush : output_channel -> unit Lwt.t + (** [flush oc] performs all pending writes on [oc] *) + +val flush_all : unit -> unit Lwt.t + (** [flush_all ()] flushes all open output channels *) + +val buffer_size : 'a channel -> int + (** Returns the size of the internal buffer. *) + +val resize_buffer : 'a channel -> int -> unit Lwt.t + (** Resize the internal buffer to the given size *) + +val is_busy : 'a channel -> bool + (** [is_busy channel] returns whether the given channel is currently + busy. A channel is busy when there is at least one job using it + that has not yet terminated. *) + +(** {6 Random access} *) + +val position : 'a channel -> int64 + (** [position ch] Returns the current position in the channel. *) + +val set_position : 'a channel -> int64 -> unit Lwt.t + (** [set_position ch pos] Sets the position in the output channel. This + does not work if the channel do not support random access. *) + +val length : 'a channel -> int64 Lwt.t + (** Returns the length of the channel in bytes *) + +(** {6 Reading} *) + +(** Note: except for functions dealing with streams ({!read_chars} and + {!read_lines}) all functions are {b atomic}. *) + +val read_char : input_channel -> char Lwt.t + (** [read_char ic] reads the next character of [ic]. + + @raise End_of_file if the end of the file is reached *) + +val read_char_opt : input_channel -> char option Lwt.t + (** Same as {!read_byte} but does not raises [End_of_file] on end of + input *) + +val read_chars : input_channel -> char Lwt_stream.t + (** [read_chars ic] returns a stream holding all characters of + [ic] *) + +val read_line : input_channel -> string Lwt.t + (** [read_line ic] reads one complete line from [ic] and returns it + without the end of line. End of line is either ["\n"] or + ["\r\n"]. + + If the end of line is reached before reading any character, + [End_of_file] is raised. If it is reached before reading an end + of line but characters have already been read, they are + returned. *) + +val read_line_opt : input_channel -> string option Lwt.t + (** Same as {!read_line} but do not raise [End_of_file] on end of + input. *) + +val read_lines : input_channel -> string Lwt_stream.t + (** [read_lines ic] returns a stream holding all lines of [ic] *) + +val read : ?count : int -> input_channel -> string Lwt.t + (** [read ?count ic] reads at most [len] characters from [ic]. It + returns [""] if the end of input is reached. If [count] is not + specified, it reads all bytes until the end of input. *) + +val read_into : input_channel -> string -> int -> int -> int Lwt.t + (** [read_into ic buffer offset length] reads up to [length] bytes, + stores them in [buffer] at offset [offset], and returns the + number of bytes read. + + Note: [read_into] does not raise [End_of_file], it returns a + length of [0] instead. *) + +val read_into_exactly : input_channel -> string -> int -> int -> unit Lwt.t + (** [read_into_exactly ic buffer offset length] reads exactly + [length] bytes and stores them in [buffer] at offset [offset]. + + @raise End_of_file on end of input *) + +val read_value : input_channel -> 'a Lwt.t + (** [read_value ic] reads a marshaled value from [ic] *) + +(** {6 Writing} *) + +(** Note: as for reading functions, all functions except + {!write_chars} and {!write_lines} are {b atomic}. + + For example if you use {!write_line} in to different threads, the + two operations will be serialized, and lines cannot be mixed. +*) + +val write_char : output_channel -> char -> unit Lwt.t + (** [write_char oc char] writes [char] on [oc] *) + +val write_chars : output_channel -> char Lwt_stream.t -> unit Lwt.t + (** [write_chars oc chars] writes all characters of [chars] on + [oc] *) + +val write : output_channel -> string -> unit Lwt.t + (** [write oc str] writes all characters of [str] on [oc] *) + +val write_line : output_channel -> string -> unit Lwt.t + (** [write_line oc str] writes [str] on [oc] followed by a + new-line. *) + +val write_lines : output_channel -> string Lwt_stream.t -> unit Lwt.t + (** [write_lines oc lines] writes all lines of [lines] to [oc] *) + +val write_from : output_channel -> string -> int -> int -> int Lwt.t + (** [write_from oc buffer offset length] writes up to [length] bytes + to [oc], from [buffer] at offset [offset] and returns the number + of bytes actually written *) + +val write_from_exactly : output_channel -> string -> int -> int -> unit Lwt.t + (** [write_from_exactly oc buffer offset length] writes all [length] + bytes from [buffer] at offset [offset] to [oc] *) + +val write_value : output_channel -> ?flags : Marshal.extern_flags list -> 'a -> unit Lwt.t + (** [write_value oc ?flags x] marshals the value [x] to [oc] *) + +(** {6 Printing} *) + +(** These functions are basically helpers. Also you may prefer the + using the name {!printl} rather than {!write_line} because it is + shorter. + + The general name of a printing function is [print]. + + Where [] is one of: + - ['f'], which means that the function takes as argument a channel + - nothing, which means that the function prints on {!stdout} + - ['e'], which means that the function prints on {!stderr} + + and [] is a combination of: + - ['l'] which means that a new-line character is printed after the message + - ['f'] which means that the function takes as argument a {b format} instead + of a string +*) + +val fprint : output_channel -> string -> unit Lwt.t +val fprintl : output_channel -> string -> unit Lwt.t +val fprintf : output_channel -> ('a, unit, string, unit Lwt.t) format4 -> 'a +val fprintlf : output_channel -> ('a, unit, string, unit Lwt.t) format4 -> 'a +val print : string -> unit Lwt.t +val printl : string -> unit Lwt.t +val printf : ('a, unit, string, unit Lwt.t) format4 -> 'a +val printlf : ('a, unit, string, unit Lwt.t) format4 -> 'a +val eprint : string -> unit Lwt.t +val eprintl : string -> unit Lwt.t +val eprintf : ('a, unit, string, unit Lwt.t) format4 -> 'a +val eprintlf : ('a, unit, string, unit Lwt.t) format4 -> 'a + +(** {6 Utilities} *) + +val hexdump_stream : output_channel -> char Lwt_stream.t -> unit Lwt.t + (** [hexdump_stream oc byte_stream] produces the same output as the + command [hexdump -C]. *) + +val hexdump : output_channel -> string -> unit Lwt.t + (** [hexdump oc str = hexdump_stream oc (Lwt_stream.of_string str)] *) + +(** {6 File utilities} *) + +type file_name = string + (** Type of file names *) + +val open_file : + ?buffer_size : int -> + ?flags : Unix.open_flag list -> + ?perm : Unix.file_perm -> + mode : 'a mode -> + file_name -> 'a channel Lwt.t + (** [open_file ?buffer_size ?flags ?perm ~mode filename] open the + file with name [filename] and returns a channel for + reading/writing it. + + @raise Unix.Unix_error on error. + *) + +val with_file : + ?buffer_size : int -> + ?flags : Unix.open_flag list -> + ?perm : Unix.file_perm -> + mode : 'a mode -> + file_name -> ('a channel -> 'b Lwt.t) -> 'b Lwt.t + (** [with_file ?buffer_size ?flags ?perm ~mode filename f] open a + file and passes the channel to [f]. It is ensured that the + channel is closed when [f ch] terminates (even if it fails). *) + +val open_connection : ?buffer_size : int -> Unix.sockaddr -> (input_channel * output_channel) Lwt.t + (** [open_connection ?buffer_size ~mode addr] open a connection to + the given address and returns two channels for using it. + + The connection is completly closed when you close both + channels. + + @raise Unix.Unix_error on error. + *) + +val with_connection : ?buffer_size : int -> Unix.sockaddr -> (input_channel * output_channel -> 'a Lwt.t) -> 'a Lwt.t + (** [with_connection ?buffer_size ~mode addr f] open a connection to + the given address and passes the channels to [f] *) + +type server + (** Type of a server *) + +val establish_server : ?buffer_size : int -> ?backlog : int -> Unix.sockaddr -> (input_channel * output_channel -> unit) -> server + (** [establich_server ?buffer_size ?backlog sockaddr f] creates a + server which will listen for incomming connections. New + connections are passed to [f]. Note that [f] must not raise any + exception. + + [backlog] is the argument passed to [Lwt_unix.listen] *) + +val shutdown_server : server -> unit + (** Shutdown the given server *) + +val lines_of_file : file_name -> string Lwt_stream.t + (** [lines_of_file name] returns a stream of all lines of the file + with name [name]. The file is automatically closed when all + lines have been read. *) + +val lines_to_file : file_name -> string Lwt_stream.t -> unit Lwt.t + (** [lines_to_file name lines] writes all lines of [lines] to + [files] *) + +val chars_of_file : file_name -> char Lwt_stream.t + (** [chars_of_file name] returns a stream of all characters of the + file with name [name]. As for {!lines_of_file} the file is + closed when all characters have been read. *) + +val chars_to_file : file_name -> char Lwt_stream.t -> unit Lwt.t + (** [chars_to_file name chars] writes all characters of [chars] to + [name] *) + +(** {6 Input/output of integers} *) + +(** Common interface for reading/writing integers in binary *) +module type NumberIO = sig + + (** {8 Reading} *) + + val read_int : input_channel -> int Lwt.t + (** Reads a 32-bits integer as an ocaml int *) + + val read_int16 : input_channel -> int Lwt.t + val read_int32 : input_channel -> int32 Lwt.t + val read_int64 : input_channel -> int64 Lwt.t + + val read_float32 : input_channel -> float Lwt.t + (** Reads an IEEE single precision floating point value *) + + val read_float64 : input_channel -> float Lwt.t + (** Reads an IEEE double precision floating point value *) + + (** {8 Writing} *) + + val write_int : output_channel -> int -> unit Lwt.t + (** Writes an ocaml int as a 32-bits integer *) + + val write_int16 : output_channel -> int -> unit Lwt.t + val write_int32 : output_channel -> int32 -> unit Lwt.t + val write_int64 : output_channel -> int64 -> unit Lwt.t + + val write_float32 : output_channel -> float -> unit Lwt.t + (** Writes an IEEE single precision floating point value *) + + val write_float64 : output_channel -> float -> unit Lwt.t + (** Writes an IEEE double precision floating point value *) +end + +module LE : NumberIO + (** Reading/writing of numbers in little-endian *) + +module BE : NumberIO + (** Reading/writing of numbers in big-endian *) + +include NumberIO +(** Reading/writing of numbers in the system endianness. *) + +type byte_order = Lwt_sys.byte_order = Little_endian | Big_endian + (** Type of byte order *) + +val system_byte_order : byte_order + (** Same as {!Lwt_sys.byte_order}. *) + +(** {6 Low-level access to the internal buffer} *) + +val block : 'a channel -> int -> (Lwt_bytes.t -> int -> 'b Lwt.t) -> 'b Lwt.t + (** [block ch size f] pass to [f] the internal buffer and an + offset. The buffer contains [size] chars at [offset]. [f] may + reads or writes these chars. [size] must verify [0 <= size <= + 16] *) + +(** Informations for accessing directly to the internal buffer of a + channel *) +type direct_access = { + da_buffer : Lwt_bytes.t; + (** The internal buffer *) + mutable da_ptr : int; + (** The pointer to: + - the beginning of free space for output channels + - the beginning of data for input channels *) + mutable da_max : int; + (** The maximum offset *) + da_perform : unit -> int Lwt.t; + (** - for input channels: + refill the buffer and returns how many bytes have been read + - for output channels: + flush partially the buffer and returns how many bytes have been written *) +} + +val direct_access : 'a channel -> (direct_access -> 'b Lwt.t) -> 'b Lwt.t + (** [direct_access ch f] pass to [f] a {!direct_access} + structure. [f] must use it and update [da_ptr] to reflect how + many bytes have been read/written. *) + +(** {6 Misc} *) + +val default_buffer_size : unit -> int + (** Return the default size for buffers. Channels that are created + without specific size use this one. *) + +val set_default_buffer_size : int -> unit + (** Change the default buffer size. + + @raise Invalid_argument if the given size is smaller than [16] + or greater than [Sys.max_string_length] *) + +(**/**) + +val of_string : mode : 'mode mode -> string -> 'mode channel + (* Deprecated *) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_libev_stubs.c b/thirdparty/lwt-2.3.2/src/unix/lwt_libev_stubs.c new file mode 100644 index 0000000..6fb3517 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_libev_stubs.c @@ -0,0 +1,211 @@ +/* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_unix_stubs + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + */ + +/* Stubs for libev */ + +#include "lwt_config.h" + +#if defined(HAVE_LIBEV) + +#include +#include +#include +#include +#include +#include +#include +#include + +#include "lwt_unix.h" + +/* +-----------------------------------------------------------------+ + | Loops | + +-----------------------------------------------------------------+ */ + +static int compare_loops(value a, value b) +{ + return (int)(Data_custom_val(a) - Data_custom_val(b)); +} + +static long hash_loop(value loop) +{ + return (long)Data_custom_val(loop); +} + +static struct custom_operations loop_ops = { + "lwt.libev.loop", + custom_finalize_default, + compare_loops, + hash_loop, + custom_serialize_default, + custom_deserialize_default +}; + +CAMLprim value lwt_libev_init() +{ + struct ev_loop *loop = ev_loop_new(EVFLAG_FORKCHECK); + if (!loop) caml_failwith("lwt_libev_init"); + value result = caml_alloc_custom(&loop_ops, sizeof(struct ev_loop*), 0, 1); + Ev_loop_val(result) = loop; + return result; +} + +CAMLprim value lwt_libev_stop(value loop) +{ + ev_loop_destroy(Ev_loop_val(loop)); + return Val_unit; +} + +static int lwt_libev_in_blocking_section = 0; + +#define LWT_LIBEV_CHECK \ + if (lwt_libev_in_blocking_section) { \ + lwt_libev_in_blocking_section = 0; \ + caml_leave_blocking_section(); \ + } + +CAMLprim value lwt_libev_loop(value loop, value block) +{ + caml_enter_blocking_section(); + lwt_libev_in_blocking_section = 1; + ev_loop(Ev_loop_val(loop), Bool_val(block) ? EVLOOP_ONESHOT : EVLOOP_ONESHOT | EVLOOP_NONBLOCK); + LWT_LIBEV_CHECK; + return Val_unit; +} + +CAMLprim value lwt_libev_unloop(value loop) +{ + ev_unloop(Ev_loop_val(loop), EVUNLOOP_ONE); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | Watchers | + +-----------------------------------------------------------------+ */ + +#define Ev_io_val(v) *(struct ev_io**)Data_custom_val(v) +#define Ev_timer_val(v) *(struct ev_timer**)Data_custom_val(v) + +static int compare_watchers(value a, value b) +{ + return (int)(Data_custom_val(a) - Data_custom_val(b)); +} + +static long hash_watcher(value watcher) +{ + return (long)Data_custom_val(watcher); +} + +static struct custom_operations watcher_ops = { + "lwt.libev.watcher", + custom_finalize_default, + compare_watchers, + hash_watcher, + custom_serialize_default, + custom_deserialize_default +}; + +/* +-----------------------------------------------------------------+ + | IO watchers | + +-----------------------------------------------------------------+ */ + +static void handle_io(struct ev_loop *loop, ev_io *watcher, int revents) +{ + LWT_LIBEV_CHECK; + caml_callback((value)watcher->data, Val_unit); +} + +static value lwt_libev_io_init(struct ev_loop *loop, int fd, int event, value callback) +{ + CAMLparam1(callback); + CAMLlocal1(result); + /* Create and initialise the watcher */ + struct ev_io* watcher = lwt_unix_new(struct ev_io); + ev_io_init(watcher, handle_io, fd, event); + /* Wrap the watcher into a custom caml value */ + result = caml_alloc_custom(&watcher_ops, sizeof(struct ev_io*), 0, 1); + Ev_io_val(result) = watcher; + /* Store the callback in the watcher, and register it as a root */ + watcher->data = (void*)callback; + caml_register_generational_global_root((value*)(&(watcher->data))); + /* Start the event */ + ev_io_start(loop, watcher); + CAMLreturn(result); +} + +CAMLprim value lwt_libev_readable_init(value loop, value fd, value callback) +{ + return lwt_libev_io_init(Ev_loop_val(loop), FD_val(fd), EV_READ, callback); +} + +CAMLprim value lwt_libev_writable_init(value loop, value fd, value callback) +{ + return lwt_libev_io_init(Ev_loop_val(loop), FD_val(fd), EV_WRITE, callback); +} + +CAMLprim value lwt_libev_io_stop(value loop, value val_watcher) +{ + struct ev_io* watcher = Ev_io_val(val_watcher); + caml_remove_generational_global_root((value*)(&(watcher->data))); + ev_io_stop(Ev_loop_val(loop), watcher); + free(watcher); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | Timer watchers | + +-----------------------------------------------------------------+ */ + +static void handle_timer(struct ev_loop *loop, ev_timer *watcher, int revents) +{ + LWT_LIBEV_CHECK; + caml_callback((value)watcher->data, Val_unit); +} + +CAMLprim value lwt_libev_timer_init(value loop, value delay, value repeat, value callback) +{ + CAMLparam2(delay, callback); + CAMLlocal1(result); + /* Create and initialise the watcher */ + struct ev_timer* watcher = lwt_unix_new(struct ev_timer); + ev_timer_init(watcher, handle_timer, Double_val(delay), Bool_val(repeat)); + /* Wrap the watcher into a custom caml value */ + result = caml_alloc_custom(&watcher_ops, sizeof(struct ev_timer*), 0, 1); + Ev_timer_val(result) = watcher; + /* Store the callback in the watcher, and register it as a root */ + watcher->data = (void*)callback; + caml_register_generational_global_root((value*)(&(watcher->data))); + /* Start the event */ + ev_timer_start(Ev_loop_val(loop), watcher); + CAMLreturn(result); +} + +CAMLprim value lwt_libev_timer_stop(value loop, value val_watcher) +{ + struct ev_timer* watcher = Ev_timer_val(val_watcher); + caml_remove_generational_global_root((value*)(&(watcher->data))); + ev_timer_stop(Ev_loop_val(loop), watcher); + free(watcher); + return Val_unit; +} + +#endif diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_log.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_log.ml new file mode 100644 index 0000000..e9542f5 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_log.ml @@ -0,0 +1,559 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_log + * Copyright (C) 2002 Shawn Wagner + * 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(* This code is an adaptation of [syslog-ocaml] *) + +open Lwt + +let program_name = Filename.basename Sys.argv.(0) + +(* Errors happening in this module are always logged to [stderr]: *) +let log_intern fmt = + Printf.ksprintf (fun msg -> ignore_result (Lwt_io.eprintlf "%s: Lwt_log: %s" program_name msg)) fmt + +(* +-----------------------------------------------------------------+ + | Log levels | + +-----------------------------------------------------------------+ *) + +type level = + | Debug + | Info + | Notice + | Warning + | Error + | Fatal + +let string_of_level = function + | Debug -> "debug" + | Info -> "info" + | Notice -> "notice" + | Warning -> "warning" + | Error -> "error" + | Fatal -> "fatal" + +(* +-----------------------------------------------------------------+ + | Patterns and rules | + +-----------------------------------------------------------------+ *) + +type pattern = string list + (* A pattern is represented by a list of literals: + + For example ["foo*bar*"] is represented by ["foo"; "bar"; ""]. *) + +let sub_equal str ofs patt = + let str_len = String.length str and patt_len = String.length patt in + let rec loop ofs ofs_patt = + ofs_patt = patt_len || (str.[ofs] = patt.[ofs_patt] && loop (ofs + 1) (ofs_patt + 1)) + in + ofs + patt_len <= str_len && loop ofs 0 + +let pattern_match pattern string = + let length = String.length string in + let rec loop offset pattern = + if offset = length then + pattern = [] || pattern = [""] + else + match pattern with + | [] -> + false + | literal :: pattern -> + let literal_length = String.length literal in + let max_offset = length - literal_length in + let rec search offset = + offset <= max_offset + && ((sub_equal string offset literal && loop (offset + literal_length) pattern) + || search (offset + 1)) + in + search offset + in + match pattern with + | [] -> + string = "" + | literal :: pattern -> + sub_equal string 0 literal && loop (String.length literal) pattern + +let split pattern = + let len = String.length pattern in + let rec loop ofs = + if ofs = len then + [""] + else + match try Some(String.index_from pattern ofs '*') with Not_found -> None with + | Some ofs' -> + String.sub pattern ofs (ofs' - ofs) :: loop (ofs' + 1) + | None -> + [String.sub pattern ofs (len - ofs)] + in + loop 0 + +let rules = ref ( + match try Some(Sys.getenv "LWT_LOG") with Not_found -> None with + | Some str -> + let rec loop = function + | [] -> + [] + | (pattern, level) :: rest -> + let pattern = split pattern in + match String.lowercase level with + | "debug" -> (pattern, Debug) :: loop rest + | "info" -> (pattern, Info) :: loop rest + | "notice" -> (pattern, Notice) :: loop rest + | "warning" -> (pattern, Warning) :: loop rest + | "error" -> (pattern, Error) :: loop rest + | "fatal" -> (pattern, Fatal) :: loop rest + | level -> log_intern "invalid log level (%s)" level; loop rest + in + loop (Lwt_log_rules.rules (Lexing.from_string str)) + | None -> + [] +) + +(* +-----------------------------------------------------------------+ + | Sections | + +-----------------------------------------------------------------+ *) + +module Section = +struct + type t = { + name : string; + mutable level : level; + mutable modified : bool; + } + + type section = t + + module Sections = Weak.Make(struct + type t = section + let equal a b = a.name = b.name + let hash s = Hashtbl.hash s.name + end) + + let sections = Sections.create 32 + + let find_level name = + let rec loop = function + | [] -> + Notice + | (pattern, level) :: rest -> + if pattern_match pattern name then + level + else + loop rest + in + loop !rules + + let recompute_levels () = + Sections.iter + (fun section -> + if not section.modified then + section.level <- find_level section.name) + sections + + let make name = + let section = { name = name; level = Notice; modified = false } in + try + Sections.find sections section + with Not_found -> + section.level <- find_level name; + Sections.add sections section; + section + + let name section = section.name + + let main = make "main" + + let level section = section.level + + let set_level section level = + section.level <- level; + section.modified <- true + + let reset_level section = + if section.modified then begin + section.modified <- false; + section.level <- find_level section.name + end +end + +type section = Section.t + +let add_rule pattern level = + rules := (split pattern, level) :: !rules; + Section.recompute_levels () + +let append_rule pattern level = + rules := !rules @ [(split pattern, level)]; + Section.recompute_levels () + +(* +-----------------------------------------------------------------+ + | Loggers | + +-----------------------------------------------------------------+ *) + +exception Logger_closed + +type logger = { + mutable lg_closed : bool; + lg_output : section -> level -> string list -> unit Lwt.t; + lg_close : unit Lwt.t Lazy.t; +} + +let close logger = + logger.lg_closed <- true; + Lazy.force logger.lg_close + +let make ~output ~close = + { + lg_closed = false; + lg_output = output; + lg_close = Lazy.lazy_from_fun close; + } + +let broadcast loggers = + make + ~output:(fun section level lines -> + Lwt_list.iter_p (fun logger -> logger.lg_output section level lines) loggers) + ~close:return + +let dispatch f = + make + ~output:(fun section level lines -> (f section level).lg_output section level lines) + ~close:return + +(* +-----------------------------------------------------------------+ + | Templates | + +-----------------------------------------------------------------+ *) + +type template = string + +let location_key = Lwt.new_key () + +let date_string time = + let tm = Unix.localtime time in + let month_string = + match tm.Unix.tm_mon with + | 0 -> "Jan" + | 1 -> "Feb" + | 2 -> "Mar" + | 3 -> "Apr" + | 4 -> "May" + | 5 -> "Jun" + | 6 -> "Jul" + | 7 -> "Aug" + | 8 -> "Sep" + | 9 -> "Oct" + | 10 -> "Nov" + | 11 -> "Dec" + | _ -> Printf.ksprintf failwith "Lwt_log.ascdate: invalid month, %d" tm.Unix.tm_mon + in + Printf.sprintf "%s %2d %02d:%02d:%02d" month_string tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + +let render ~buffer ~template ~section ~level ~message = + let time = lazy(Unix.gettimeofday ()) in + let file, line, column = + match Lwt.get location_key with + | Some loc -> loc + | None -> ("", -1, -1) + in + Buffer.add_substitute buffer + (function + | "date" -> date_string (Lazy.force time) + | "milliseconds" -> String.sub (Printf.sprintf "%.4f" (fst (modf (Lazy.force time)))) 2 4 + | "name" -> program_name + | "pid" -> string_of_int (Unix.getpid ()) + | "message" -> message + | "level" -> string_of_level level + | "section" -> Section.name section + | "loc-file" -> file + | "loc-line" -> string_of_int line + | "loc-column" -> string_of_int column + | var -> Printf.ksprintf invalid_arg "Lwt_log.render_buffer: unknown variable %S" var) + template + +(* +-----------------------------------------------------------------+ + | Predefined loggers | + +-----------------------------------------------------------------+ *) + +let null = + make + ~output:(fun section level lines -> return ()) + ~close:return + +let channel ?(template="$(name): $(section): $(message)") ~close_mode ~channel () = + make + ~output:(fun section level lines -> + Lwt_io.atomic begin fun oc -> + let buf = Buffer.create 42 in + lwt () = + Lwt_list.iter_s + (fun line -> + Buffer.clear buf; + render ~buffer:buf ~template ~section ~level ~message:line; + Buffer.add_char buf '\n'; + Lwt_io.write oc (Buffer.contents buf)) + lines + in + Lwt_io.flush oc + end channel) + ~close:(match close_mode with + | `Keep -> return + | `Close -> (fun () -> Lwt_io.close channel)) + +let default = + ref(channel ~close_mode:`Keep ~channel:Lwt_io.stderr ()) + +let file ?(template="$(date): $(section): $(message)") ?(mode=`Append) ?(perm=0o640) ~file_name () = + let flags = match mode with + | `Append -> + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND; Unix.O_NONBLOCK] + | `Truncate -> + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK] in + lwt fd = Lwt_unix.openfile file_name flags 0o666 in + Lwt_unix.set_close_on_exec fd; + let oc = Lwt_io.of_fd ~mode:Lwt_io.output fd in + return (channel ~template ~close_mode:`Close ~channel:oc ()) + +let level_code = function + | Fatal -> 0 + | Error -> 3 + | Warning -> 4 + | Notice -> 5 + | Info -> 6 + | Debug -> 7 + +type syslog_facility = + [ `Auth | `Authpriv | `Cron | `Daemon | `FTP | `Kernel + | `Local0 | `Local1 | `Local2 | `Local3 | `Local4 | `Local5 | `Local6 | `Local7 + | `LPR | `Mail | `News | `Syslog | `User | `UUCP | `NTP | `Security | `Console ] + +let facility_code = function + | `Kernel -> 0 + | `User -> 1 + | `Mail -> 2 + | `Daemon -> 3 + | `Auth -> 4 + | `Syslog -> 5 + | `LPR -> 6 + | `News -> 7 + | `UUCP -> 8 + | `Cron -> 9 + | `Authpriv -> 10 + | `FTP -> 11 + | `NTP -> 12 + | `Security -> 13 + | `Console -> 14 + | `Local0 -> 16 + | `Local1 -> 17 + | `Local2 -> 18 + | `Local3 -> 19 + | `Local4 -> 20 + | `Local5 -> 21 + | `Local6 -> 22 + | `Local7 -> 23 + +type syslog_connection_type = STREAM | DGRAM + +let shutdown fd = + Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; + Lwt_unix.close fd + +(* Try to find a socket in [paths]. For each path it check that the + file is a socket and try to establish connection in DGRAM mode then in + STREAM mode. *) +let syslog_connect paths = + let rec loop = function + | [] -> + (* No working socket found *) + log_intern "no working socket found in {%s}; is syslogd running?" + (String.concat ", " (List.map (Printf.sprintf "\"%s\"") paths)); + raise_lwt (Sys_error(Unix.error_message Unix.ENOENT)) + | path :: paths -> + begin try + return (Some (Unix.stat path).Unix.st_kind) + with + | Unix.Unix_error(Unix.ENOENT, _, _) -> + return None + | Unix.Unix_error(error, _, _) -> + log_intern "can not stat \"%s\": %s" path (Unix.error_message error); + return None + end >>= function + | None -> + loop paths + | Some Unix.S_SOCK -> begin + (* First, we try with a dgram socket : *) + let fd = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_DGRAM 0 in + try_lwt + lwt () = Lwt_unix.connect fd (Unix.ADDR_UNIX path) in + Lwt_unix.set_close_on_exec fd; + return (DGRAM, fd) + with + | Unix.Unix_error(Unix.EPROTOTYPE, _, _) -> begin + lwt () = Lwt_unix.close fd in + (* Then try with a stream socket: *) + let fd = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + try_lwt + lwt () = Lwt_unix.connect fd (Unix.ADDR_UNIX path) in + Lwt_unix.set_close_on_exec fd; + return (STREAM, fd) + with Unix.Unix_error(error, _, _) -> + lwt () = Lwt_unix.close fd in + log_intern "can not connect to \"%s\": %s" path (Unix.error_message error); + loop paths + end + | Unix.Unix_error(error, _, _) -> + lwt () = Lwt_unix.close fd in + log_intern "can not connect to \"%s\": %s" path (Unix.error_message error); + loop paths + end + | Some _ -> + log_intern "\"%s\" is not a socket" path; + loop paths + in + loop paths + +(* Write the whole contents of a string on the given file + descriptor: *) +let write_string fd str = + let len = String.length str in + let rec aux start_ofs = + if start_ofs = len then + return () + else + lwt n = Lwt_unix.write fd str start_ofs (len - start_ofs) in + if n <> 0 then + aux (start_ofs + n) + else + return () + in + aux 0 + +let truncate buf max = + if Buffer.length buf > max then begin + let suffix = "" in + let len_suffix = String.length suffix in + let str = Buffer.sub buf 0 max in + StringLabels.blit ~src:suffix ~src_pos:0 ~dst:str ~dst_pos:(max - len_suffix) ~len:len_suffix; + str + end else + Buffer.contents buf + +let syslog ?(template="$(date) $(name)[$(pid)]: $(section): $(message)") ?(paths=["/dev/log"; "/var/run/log"]) ~facility () = + let syslog_socket = ref None and mutex = Lwt_mutex.create () in + let get_syslog () = match !syslog_socket with + | Some x -> + return x + | None -> + lwt x = syslog_connect paths in + syslog_socket := Some x; + return x + in + make + ~output:(fun section level lines -> + Lwt_mutex.with_lock mutex + (fun () -> + let buf = Buffer.create 42 in + let make_line socket_type msg = + Buffer.clear buf; + Printf.bprintf buf "<%d>" ((facility_code facility lsl 3) lor level_code level); + render ~buffer:buf ~template ~section ~level ~message:msg; + if socket_type = STREAM then Buffer.add_char buf '\x00'; + truncate buf 1024 + in + let rec print socket_type fd = function + | [] -> + return () + | line :: lines -> + try_lwt + lwt () = write_string fd (make_line socket_type line) in + print socket_type fd lines + with Unix.Unix_error(_, _, _) -> + (* Try to reconnect *) + lwt () = shutdown fd in + syslog_socket := None; + lwt socket_type, fd = get_syslog () in + lwt () = write_string fd (make_line socket_type line) in + print socket_type fd lines + in + lwt socket_type, fd = get_syslog () in + print socket_type fd lines)) + ~close:(fun () -> + match !syslog_socket with + | None -> + return () + | Some(socket_type, fd) -> + shutdown fd) + +(* +-----------------------------------------------------------------+ + | Logging functions | + +-----------------------------------------------------------------+ *) + +let split str = + let len = String.length str in + let rec aux i = + if i >= len then + [] + else + let j = try String.index_from str i '\n' with Not_found -> String.length str in + String.sub str i (j - i) :: aux (j + 1) + in + aux 0 + +let log ?exn ?(section=Section.main) ?location ?logger ~level message = + let logger = match logger with + | None -> !default + | Some logger -> logger + in + if logger.lg_closed then + raise_lwt Logger_closed + else if level >= section.Section.level then + match exn with + | None -> + Lwt.with_value location_key location (fun () -> logger.lg_output section level (split message)) + | Some exn -> + let message = message ^ ": " ^ Printexc.to_string exn in + let message = + if Printexc.backtrace_status () then + match Printexc.get_backtrace () with + | "" -> message + | backtrace -> message ^ "\nbacktrace:\n" ^ backtrace + else + message + in + Lwt.with_value location_key location (fun () -> logger.lg_output section level (split message)) + else + return () + +let log_f ?exn ?section ?location ?logger ~level format = + Printf.ksprintf (log ?exn ?section ?location ?logger ~level) format + +let debug ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Debug msg +let debug_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (debug ?exn ?section ?location ?logger) fmt +let info ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Info msg +let info_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (info ?exn ?section ?location ?logger) fmt +let notice ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Notice msg +let notice_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (notice ?exn ?section ?location ?logger) fmt +let warning ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Warning msg +let warning_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (warning ?exn ?section ?location ?logger) fmt +let error ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Error msg +let error_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (error ?exn ?section ?location ?logger) fmt +let fatal ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Fatal msg +let fatal_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (fatal ?exn ?section ?location ?logger) fmt diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_log.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_log.mli new file mode 100644 index 0000000..6c203ef --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_log.mli @@ -0,0 +1,316 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_log + * Copyright (C) 2002 Shawn Wagner + * 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Logging facility *) + +(** This module provides functions to deal with logging. + It support: + + - logging to the syslog daemon + - logging to a channel (stderr, stdout, ...) + - logging to a file + - logging to multiple destination at the same time +*) + +(** {6 Types} *) + +(** Type of log levels. A level determines the importance of a + message *) +type level = + | Debug + (** Debugging message. They can be automatically removed by the + syntax extension. *) + | Info + (** Informational message. Suitable to be displayed when the + program is in verbose mode. *) + | Notice + (** Same as {!Info}, but is displayed by default. *) + | Warning + (** Something strange happend *) + | Error + (** An error message, which should not means the end of the + program. *) + | Fatal + (** A fatal error happened, in most cases the program will end + after a fatal error. *) + +type logger + (** Type of a logger. A logger is responsible for dispatching messages + and storing them somewhere. + + Lwt provides loggers sending log messages to a file, syslog, + ... but you can also create you own logger. *) + +type section + (** Each logging message has a section. Sections can be used to + structure your logs. For example you can choose different + loggers according to the section. + + Each section carries a level, and messages with a lower log + level than than the section level will be dropped. + + Section levels are initialised using the [LWT_LOG] environment + variable, which must contains one or more rules of the form + [pattern -> level] separated by ";". Where [pattern] is a string + that may contain [*]. + + For example, if [LWT_LOG] contains: + {[ + access -> warning; + foo[*] -> error + ]} + then the level of the section ["access"] is {!Warning} and the + level of any section matching ["foo[*]"] is {!Error}. + + If the pattern is omited in a rule then the pattern ["*"] is + used instead, so [LWT_LOG] may just contains ["debug"] for + instance. + + If [LWT_LOG] is not defined then the rule ["* -> notice"] is + used instead. *) + +val add_rule : string -> level -> unit + (** [add_rule pattern level] adds a rule for sections logging + levels. The rule is added before all other rules. It takes + effect immediatly and affect all sections for which the level + has not been set explicitly with {!Section.set_level}. [pattern] + may contains [*]. For example: + + {[ + Lwt_log.add_rule "lwt*" Lwt_log.Info + ]} + *) + +val append_rule : string -> level -> unit + (** [append_rule pattern level] adds the given rule after all other + rules. For example to set the default fallback rule: + + {[ + Lwt_log.append_rule "*" Lwt_log.Info + ]} + *) + +(** {6 Logging functions} *) + +val log : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> level : level -> string -> unit Lwt.t + (** [log ?section ?logger ~level message] logs a message. + + [section] defaults to {!Section.main}. If [logger] is not + specified, then the default one is used instead (see + {!default}). + + If [exn] is provided, then its string representation + (= [Printexc.to_string exn]) will be append to the message, and if + possible the backtrace will also be logged. + + [location] contains the location of the logging directive, it is + of the form [(file_name, line, column)]. *) + +val log_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> level : level -> ('a, unit, string, unit Lwt.t) format4 -> 'a + (** [log_f] is the same as [log] except that it takes a format + string *) + +(** The following functions are the same as {!log} except that their + name determines which level is used. + + For example {!info msg} is the same as {!log ~level:Info msg}. +*) + +val debug : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t +val debug_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a + +val info : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t +val info_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a + +val notice : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t +val notice_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a + +val warning : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t +val warning_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a + +val error : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t +val error_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a + +val fatal : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t +val fatal_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a + +(** Sections *) +module Section : sig + type t = section + + val make : string -> section + (** [make name] creates a section with the given name. Two calls + to {!make} with the same name will return the same section + object. *) + + val name : section -> string + (** [name section] returns the name of [section]. *) + + val main : section + (** The main section. It is the section used by default when no + one is provided. *) + + val level : section -> level + (** [level section] returns the logging level of [section]. *) + + val set_level : section -> level -> unit + (** [set_level section] sets the logging level of the given + section. Modifications of rules using {!add_rule} won't affect + the level of this section after this operation. *) + + val reset_level : section -> unit + (** [reset_level section] resets the level of [section] to its + default value, i.e. to the value obtained by applying + rules. *) +end + +(** {6 Log templates} *) + +type template = string + (** A template is for generating log messages. + + It is a string which may contains variables of the form + [$(var)], where [var] is one of: + + - [date] which will be replaced with the current date + - [milliseconds] which will be replaced by the fractionnal part + of the current unix time + - [name] which will be replaced by the program name + - [pid] which will be replaced by the pid of the program + - [message] which will be replaced by the message emited + - [level] which will be replaced by a string representation of + the level + - [section] which will be replaced by the name of the + message's section + - [loc-file] which will be replaced by the file name of the + calling logging function + - [loc-line] which will be replaced by the line number of the + calling logging function + - [loc-column] which will be replaced by the column number of + the calling logging function + + For example: + - ["$(name): $(message)"] + - ["$(date) $(name)[$(pid)]: $(message)"] + - ["$(date).$(milliseconds) $(name)[$(pid)]: $(message)"] + - ["$(date): $(loc-file): $(loc-line): $(loc-column): $(message)"] + *) + +val render : buffer : Buffer.t -> template : template -> section : section -> level : level -> message : string -> unit + (** [render ~buffer ~template ~section ~level ~message] instantiate + all variables of [template], and store the result in + [buffer]. The location is obtained from threads local + storage. *) + +val location_key : (string * int * int) Lwt.key + (** The key for storing current location. *) + +(** {6 Loggers} *) + +exception Logger_closed + (** Exception raised when trying to use a closed logger *) + +val make : output : (section -> level -> string list -> unit Lwt.t) -> close : (unit -> unit Lwt.t) -> logger + (** [make ~output ~close] creates a new logger. + + @param output is used to write logs. It is a function which + receive a section, a level and a list lines that must be logged + together. + @param close is used to close the logger. *) + +val close : logger -> unit Lwt.t + (** Close the given logger *) + +val default : logger ref + (** The default logger. It is used as default when no one is + specified. Initially, it sends messages to the standard output + for error messages. *) + +val broadcast : logger list -> logger + (** [broadcast loggers] is a logger which send messages to all the + given loggers. + + Note: closing a broadcast logger does not close its + components. *) + +val dispatch : (section -> level -> logger) -> logger + (** [dispatch f] is a logger which dispatch logging instructions to + different logger according to their level and/or section. + + Here is an example: + + {[ + let access_logger = Lwt_log.file "access.log" + and error_logger = Lwt_log.file "error.log" in + + Lwt_log.dispatch + (fun section level -> + match Lwt_log.Section.name section, level with + | "access", _ -> access_logger + | _, Lwt_log.Error -> error_logger) + ]} + *) + +(** {6 Predefined loggers} *) + +val null : logger + (** Logger which drops everything *) + +(** Syslog facility. Look at the SYSLOG(3) man page for a description + of syslog facilities *) +type syslog_facility = + [ `Auth | `Authpriv | `Cron | `Daemon | `FTP | `Kernel + | `Local0 | `Local1 | `Local2 | `Local3 | `Local4 | `Local5 | `Local6 | `Local7 + | `LPR | `Mail | `News | `Syslog | `User | `UUCP | `NTP | `Security | `Console ] + +val syslog : ?template : template -> ?paths : string list -> facility : syslog_facility -> unit -> logger + (** [syslog ?template ?paths ~facility ()] creates an logger + which send message to the system logger. + + @param paths is a list of path to try for the syslogd socket. It + default to [\["/dev/log"; "/var/run/log"\]]. + @param template defaults to ["$(date) $(name)[$(pid)]: $(section): $(message)"] + *) + +val file : ?template : template -> ?mode : [ `Truncate | `Append ] -> ?perm : Unix.file_perm -> file_name : string -> unit -> logger Lwt.t + (** [desf_file ?template ?mode ?perm ~file_name ()] creates an + logger which will write messages to [file_name]. + + - if [mode = `Truncate] then the file is truncated and previous + contents will be lost. + + - if [mode = `Append], new messages will be appended at the end + of the file + + @param mode defaults to [`Append] + @param template defaults to ["$(date): $(section): $(message)"] + *) + +val channel :?template : template -> close_mode : [ `Close | `Keep ] -> channel : Lwt_io.output_channel -> unit -> logger + (** [channel ?template ~close_mode ~channel ()] creates a logger + from a channel. + + If [close_mode = `Close] then [channel] is closed when the + logger is closed, otherwise it is left open. + + @param template defaults to ["$(name): $(section): $(message)"] *) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mli new file mode 100644 index 0000000..024e066 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mli @@ -0,0 +1,27 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_log_rules + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Logging rules parsing *) + +val rules : Lexing.lexbuf -> (string * string) list + (** [parse lexbuf] returns the list of rules contained in + [lexbuf] *) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mll b/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mll new file mode 100644 index 0000000..d5db4fa --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_log_rules.mll @@ -0,0 +1,49 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_log_rules + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +{ + let invalid () = + Printf.eprintf "%s: invalid contents of the LWT_LOG variable\n%!" (Filename.basename Sys.argv.(0)) +} + +let space = [' ' '\t' '\n'] +let pattern = [^ ' ' '\t' '\n']+ +let level = ['a'-'z' 'A'-'Z']+ + +rule rules = parse + | space* (pattern as pattern) space* "->" space* (level as level) + { (pattern, level) :: semi_colon_and_rules lexbuf } + | space* (level as level) + { ("*", level) :: semi_colon_and_rules lexbuf } + | space* eof + { [] } + | "" + { invalid (); [] } + +and semi_colon_and_rules = parse + | space* ";" + { rules lexbuf } + | space* eof + { [] } + | "" + { invalid (); [] } + diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_main.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_main.ml new file mode 100644 index 0000000..fd5a7d7 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_main.ml @@ -0,0 +1,74 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_main + * Copyright (C) 2009-2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt + +let enter_iter_hooks = Lwt_sequence.create () +let leave_iter_hooks = Lwt_sequence.create () +let yielded = Lwt_sequence.create () + +let yield () = + let waiter, wakener = task () in + let node = Lwt_sequence.add_l wakener yielded in + on_cancel waiter (fun () -> Lwt_sequence.remove node); + waiter + +let rec run t = + (* Wakeup paused threads now. *) + Lwt.wakeup_paused (); + match Lwt.poll t with + | Some x -> + x + | None -> + (* Call enter hooks. *) + Lwt_sequence.iter_l (fun f -> f ()) enter_iter_hooks; + (* Do the main loop call. *) + Lwt_engine.iter (Lwt.paused_count () = 0 && Lwt_sequence.is_empty yielded); + (* Wakeup paused threads again. *) + Lwt.wakeup_paused (); + (* Wakeup yielded threads now. *) + if not (Lwt_sequence.is_empty yielded) then begin + let tmp = Lwt_sequence.create () in + Lwt_sequence.transfer_r yielded tmp; + Lwt_sequence.iter_l (fun wakener -> wakeup wakener ()) tmp + end; + (* Call leave hooks. *) + Lwt_sequence.iter_l (fun f -> f ()) leave_iter_hooks; + run t + +let exit_hooks = Lwt_sequence.create () + +let rec call_hooks () = + match Lwt_sequence.take_opt_l exit_hooks with + | None -> + return () + | Some f -> + lwt () = + try_lwt + f () + with exn -> + return () + in + call_hooks () + +let () = at_exit (fun () -> run (call_hooks ())) +let at_exit f = ignore (Lwt_sequence.add_l f exit_hooks) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_main.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_main.mli new file mode 100644 index 0000000..c48e80c --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_main.mli @@ -0,0 +1,61 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_main + * Copyright (C) 2009-2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Main loop and event queue *) + +(** This module controls the ``main-loop'' of Lwt. *) + +val run : 'a Lwt.t -> 'a + (** [run t] calls the Lwt scheduler repeatedly until [t] terminates, + then returns the value returned by the thread. It [t] fails with + an exception, this exception is raised. + + Note that you should avoid using [run] inside threads + - The calling threads will not resume before [run] + returns. + - Successive invocations of [run] are serialized: an + invocation of [run] will not terminate before all + subsequent invocations are terminated. + + Note also that it is not safe to call [run] in a function + registered with [Pervasives.at_exit], use the {!at_exit} + function of this module instead. *) + +val yield : unit -> unit Lwt.t + (** [yield ()] is a threads which suspends itself and then resumes + as soon as possible and terminates. *) + +val enter_iter_hooks : (unit -> unit) Lwt_sequence.t + (** Functions that are called before the main iteration. *) + +val leave_iter_hooks : (unit -> unit) Lwt_sequence.t + (** Functions that are called after the main iteration. *) + +val exit_hooks : (unit -> unit Lwt.t) Lwt_sequence.t + (** Sets of functions executed just before the program exit. + + Notes: + - each hook is called exactly one time + - exceptions raised by hooks are ignored *) + +val at_exit : (unit -> unit Lwt.t) -> unit + (** [at_exit hook] adds hook at the left of [exit_hooks]*) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_process.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_process.ml new file mode 100644 index 0000000..8c4d42c --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_process.ml @@ -0,0 +1,328 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_process + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt + +type command = string * string array + +let shell cmd = ("/bin/sh", [| "/bin/sh"; "-c"; cmd |]) + +type redirection = + [ `Keep + | `Dev_null + | `Close + | `FD_copy of Unix.file_descr + | `FD_move of Unix.file_descr ] + +(* +-----------------------------------------------------------------+ + | Spawing commands | + +-----------------------------------------------------------------+ *) + +let redirect fd redirection = match redirection with + | `Keep -> + () + | `Dev_null -> + Unix.close fd; + let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR] 0o666 in + if fd <> dev_null then begin + Unix.dup2 dev_null fd; + Unix.close dev_null + end + | `Close -> + Unix.close fd + | `FD_copy fd' -> + Unix.dup2 fd' fd + | `FD_move fd' -> + Unix.dup2 fd' fd; + Unix.close fd' + +let spawn (prog, args) env ?(stdin:redirection=`Keep) ?(stdout:redirection=`Keep) ?(stderr:redirection=`Keep) toclose = + match Lwt_unix.fork() with + | 0 -> + redirect Unix.stdin stdin; + redirect Unix.stdout stdout; + redirect Unix.stderr stderr; + List.iter Unix.close toclose; + begin + try + match env with + | None -> + Unix.execvp prog args + | Some env -> + Unix.execvpe prog args env + with _ -> + (* Prevent hooks from running, otherwise thay may use + notifications and the result would be unspecified. *) + Lwt_sequence.iter_node_l Lwt_sequence.remove Lwt_main.exit_hooks; + exit 127 + end + | id -> + let close = function + | `FD_move fd -> + Unix.close fd + | _ -> + () + in + close stdin; + close stdout; + close stderr; + id + +type state = + | Running + | Exited of Unix.process_status + +let status (pid, status, rusage) = status +let rusage (pid, status, rusage) = rusage + +class virtual common timeout (w : (int * Unix.process_status * Lwt_unix.resource_usage) Lwt.t) pid = + let status = lazy(w >|= status) and rusage = lazy(w >|= rusage) in +object(self) + + method virtual close : Unix.process_status Lwt.t + + method pid = pid + + method state = match Lwt.poll w with + | None -> Running + | Some(pid, status, rusage) -> Exited status + + method kill signum = match Lwt.poll w with + | None -> Unix.kill pid signum + | Some _ -> () + + method status = Lazy.force status + method rusage = Lazy.force rusage + + initializer + match timeout with + | None -> + () + | Some dt -> + Lwt.ignore_result begin + try_lwt + lwt _ = Lwt.pick [Lwt_unix.timeout dt; w] in + return () + with + | Lwt_unix.Timeout -> + (try Unix.kill pid Sys.sigkill with _ -> ()); + (try_lwt self#close >> return () with _ -> return ()) + | _ -> + return () + end +end + +class process_none ?timeout ?env ?stdin ?stdout ?stderr cmd = + let pid = spawn cmd env ?stdin ?stdout ?stderr [] in + let w = Lwt_unix.wait4 [] pid in + let close = lazy(w >|= status) in +object + inherit common timeout w pid + method close = Lazy.force close +end + +class process_in ?timeout ?env ?stdin ?stderr cmd = + let stdout_r, stdout_w = Unix.pipe () in + let pid = spawn cmd env ?stdin ~stdout:(`FD_move stdout_w) ?stderr [stdout_r] in + let stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r + and w = Lwt_unix.wait4 [] pid in + let close = lazy(Lwt_io.close stdout >> w >|= status) in +object + inherit common timeout w pid + method close = Lazy.force close + method stdout = stdout +end + +class process_out ?timeout ?env ?stdout ?stderr cmd = + let stdin_r, stdin_w = Unix.pipe () in + let pid = spawn cmd env ~stdin:(`FD_move stdin_r) ?stdout ?stderr [stdin_w] in + let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w + and w = Lwt_unix.wait4 [] pid in + let close = lazy (Lwt_io.close stdin >> w >|= status) in +object + inherit common timeout w pid + method close = Lazy.force close + method stdin = stdin +end + +class process ?timeout ?env ?stderr cmd = + let stdin_r, stdin_w = Unix.pipe () + and stdout_r, stdout_w = Unix.pipe () in + let pid = spawn cmd env ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ?stderr [stdin_w; stdout_r] in + let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w + and stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r + and w = Lwt_unix.wait4 [] pid in + let close = lazy(Lwt_io.close stdin <&> Lwt_io.close stdout >> w >|= status) in +object + inherit common timeout w pid + method close = Lazy.force close + method stdin = stdin + method stdout = stdout +end + +class process_full ?timeout ?env cmd = + let stdin_r, stdin_w = Unix.pipe () + and stdout_r, stdout_w = Unix.pipe () + and stderr_r, stderr_w = Unix.pipe () in + let pid = spawn cmd env ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ~stderr:(`FD_move stderr_w) [stdin_w; stdout_r; stderr_r] in + let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w + and stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r + and stderr = Lwt_io.of_unix_fd ~mode:Lwt_io.input stderr_r + and w = Lwt_unix.wait4 [] pid in + let close = lazy(join [Lwt_io.close stdin; Lwt_io.close stdout; Lwt_io.close stderr] >> w >|= status) in +object + inherit common timeout w pid + method close = Lazy.force close + method stdin = stdin + method stdout = stdout + method stderr = stderr +end + +let open_process_none ?timeout ?env ?stdin ?stdout ?stderr cmd = new process_none ?timeout ?env ?stdin ?stdout ?stderr cmd +let open_process_in ?timeout ?env ?stdin ?stderr cmd = new process_in ?timeout ?env ?stdin ?stderr cmd +let open_process_out ?timeout ?env ?stdout ?stderr cmd = new process_out ?timeout ?env ?stdout ?stderr cmd +let open_process ?timeout ?env ?stderr cmd = new process ?timeout ?env ?stderr cmd +let open_process_full ?timeout ?env cmd = new process_full ?timeout ?env cmd + +let make_with backend ?timeout ?env cmd f = + let process = backend ?timeout ?env cmd in + try_lwt + f process + finally + lwt _ = process#close in + return () + +let with_process_none ?timeout ?env ?stdin ?stdout ?stderr cmd f = make_with (open_process_none ?stdin ?stdout ?stderr) ?timeout ?env cmd f +let with_process_in ?timeout ?env ?stdin ?stderr cmd f = make_with (open_process_in ?stdin ?stderr) ?timeout ?env cmd f +let with_process_out ?timeout ?env ?stdout ?stderr cmd f = make_with (open_process_out ?stdout ?stderr) ?timeout ?env cmd f +let with_process ?timeout ?env ?stderr cmd f = make_with (open_process ?stderr) ?timeout ?env cmd f +let with_process_full ?timeout ?env cmd f = make_with open_process_full ?timeout ?env cmd f + +(* +-----------------------------------------------------------------+ + | High-level functions | + +-----------------------------------------------------------------+ *) + +let exec ?timeout ?env ?stdin ?stdout ?stderr cmd = (open_process_none ?timeout ?env ?stdin ?stdout ?stderr cmd)#close + +let ingore_close ch = + ignore (Lwt_io.close ch) + +let recv_chars pr = + let ic = pr#stdout in + Gc.finalise ingore_close ic; + Lwt_stream.from (fun _ -> + lwt x = Lwt_io.read_char_opt ic in + if x = None then begin + lwt () = Lwt_io.close ic in + return x + end else + return x) + +let recv_lines pr = + let ic = pr#stdout in + Gc.finalise ingore_close ic; + Lwt_stream.from (fun _ -> + lwt x = Lwt_io.read_line_opt ic in + if x = None then begin + lwt () = Lwt_io.close ic in + return x + end else + return x) + +let recv pr = + let ic = pr#stdout in + try_lwt + Lwt_io.read ic + finally + Lwt_io.close ic >> return () + +let recv_line pr = + let ic = pr#stdout in + try_lwt + Lwt_io.read_line ic + finally + Lwt_io.close ic + +(* Receiving *) + +let pread ?timeout ?env ?stdin ?stderr cmd = + recv (open_process_in ?timeout ?env ?stdin ?stderr cmd) + +let pread_chars ?timeout ?env ?stdin ?stderr cmd = + recv_chars (open_process_in ?timeout ?env ?stdin ?stderr cmd) + +let pread_line ?timeout ?env ?stdin ?stderr cmd = + recv_line (open_process_in ?timeout ?env ?stdin ?stderr cmd) + +let pread_lines ?timeout ?env ?stdin ?stderr cmd = + recv_lines (open_process_in ?timeout ?env ?stdin ?stderr cmd) + +(* Sending *) + +let send f pr data = + let oc = pr#stdin in + try_lwt + f oc data + finally + Lwt_io.close oc + +let pwrite ?timeout ?env ?stdout ?stderr cmd text = + send Lwt_io.write (open_process_out ?timeout ?env ?stdout ?stderr cmd) text + +let pwrite_chars ?timeout ?env ?stdout ?stderr cmd chars = + send Lwt_io.write_chars (open_process_out ?timeout ?env ?stdout ?stderr cmd) chars + +let pwrite_line ?timeout ?env ?stdout ?stderr cmd line = + send Lwt_io.write_line (open_process_out ?timeout ?env ?stdout ?stderr cmd) line + +let pwrite_lines ?timeout ?env ?stdout ?stderr cmd lines = + send Lwt_io.write_lines (open_process_out ?timeout ?env ?stdout ?stderr cmd) lines + +(* Mapping *) + +(* Dump something to a command: *) +let dump f pr data = + let oc = pr#stdin in + ignore_result (try_lwt + f oc data + finally + Lwt_io.close oc) + +let pmap ?timeout ?env ?stderr cmd text = + let pr = open_process ?timeout ?env ?stderr cmd in + dump Lwt_io.write pr text; + recv pr + +let pmap_chars ?timeout ?env ?stderr cmd chars = + let pr = open_process ?timeout ?env ?stderr cmd in + dump Lwt_io.write_chars pr chars; + recv_chars pr + +let pmap_line ?timeout ?env ?stderr cmd line = + let pr = open_process ?timeout ?env ?stderr cmd in + dump Lwt_io.write_line pr line; + recv_line pr + +let pmap_lines ?timeout ?env ?stderr cmd lines = + let pr = open_process ?timeout ?env ?stderr cmd in + dump Lwt_io.write_lines pr lines; + recv_lines pr diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_process.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_process.mli new file mode 100644 index 0000000..4ee6633 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_process.mli @@ -0,0 +1,296 @@ +(* Lightweight thread library for Objective Caml + * http://www.output_channelsigen.org/lwt + * Module Lwt_process + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Process management *) + +(** This modules allow you to spawn processes and communicate with them. *) + +type command = string * string array + (** A command is a program name with a list of arguments *) + +val shell : string -> command + (** A command executed with ["/bin/sh"] *) + +(** All the following functions take an optionnal argument + [timeout]. If specified, after expiration, the process will be + sent a [Unix.sigkill] signal and channels will be closed. *) + +(** {6 High-level functions} *) + +(** {8 Redirections} *) + +(** A file descriptor redirection. It describe how standard file + descriptors are redirected in the child process. *) +type redirection = + [ `Keep + (** The file descriptor is left unchanged *) + | `Dev_null + (** Connect the file descriptor to [/dev/null] *) + | `Close + (** The file descriptor is closed *) + | `FD_copy of Unix.file_descr + (** The file descriptor is replaced by the given + one *) + | `FD_move of Unix.file_descr + (** The file descriptor is replaced by the given one, which is + then closed. *) ] + +(** Note: all optionnal redirection argumetns default to [`Keep] *) + +(** {8 Executing} *) + +val exec : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> Unix.process_status Lwt.t + (** Executes the given command and returns its exit status. *) + +(** {8 Receiving} *) + +val pread : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stderr : redirection -> + command -> string Lwt.t +val pread_chars : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stderr : redirection -> + command -> char Lwt_stream.t +val pread_line : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stderr : redirection -> + command -> string Lwt.t +val pread_lines : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stderr : redirection -> + command -> string Lwt_stream.t + +(** {8 Sending} *) + +val pwrite : + ?timeout : float -> + ?env : string array -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> string -> unit Lwt.t +val pwrite_chars : + ?timeout : float -> + ?env : string array -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> char Lwt_stream.t -> unit Lwt.t +val pwrite_line : + ?timeout : float -> + ?env : string array -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> string -> unit Lwt.t +val pwrite_lines : + ?timeout : float -> + ?env : string array -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> string Lwt_stream.t -> unit Lwt.t + +(** {8 Mapping} *) + +val pmap : + ?timeout : float -> + ?env : string array -> + ?stderr : redirection -> + command -> string -> string Lwt.t +val pmap_chars : + ?timeout : float -> + ?env : string array -> + ?stderr : redirection -> + command -> char Lwt_stream.t -> char Lwt_stream.t +val pmap_line : + ?timeout : float -> + ?env : string array -> + ?stderr : redirection -> + command -> string -> string Lwt.t +val pmap_lines : + ?timeout : float -> + ?env : string array -> + ?stderr : redirection -> + command -> string Lwt_stream.t -> string Lwt_stream.t + +(** {6 Spawning processes} *) + +(** State of a sub-process *) +type state = + | Running + (** The process is still running *) + | Exited of Unix.process_status + (** The process has exited *) + +class process_none : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> +object + method pid : int + (** Pid of the sub-process *) + + method state : state + (** Return the state of the process *) + + method kill : int -> unit + (** [kill signum] sends [signum] to the process if it is still + running *) + + method status : Unix.process_status Lwt.t + (** Threads which wait for the sub-process to exit then returns its + exit status *) + + method rusage : Lwt_unix.resource_usage Lwt.t + (** Threads which wait for the sub-process to exit then returns + its resource usages *) + + method close : Unix.process_status Lwt.t + (** Closes the process and returns its exit status. This close all + channels used to communicate with the process *) +end + +val open_process_none : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> process_none +val with_process_none : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> (process_none -> 'a Lwt.t) -> 'a Lwt.t + +class process_in : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stderr : redirection -> + command -> +object + inherit process_none + + method stdout : Lwt_io.input_channel + (** The standard output of the process *) +end + +val open_process_in : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stderr : redirection -> + command -> process_in +val with_process_in : + ?timeout : float -> + ?env : string array -> + ?stdin : redirection -> + ?stderr : redirection -> + command -> (process_in -> 'a Lwt.t) -> 'a Lwt.t + +class process_out : + ?timeout : float -> + ?env : string array -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> +object + inherit process_none + + method stdin : Lwt_io.output_channel + (** The standard input of the process *) +end + +val open_process_out : + ?timeout : float -> + ?env : string array -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> process_out +val with_process_out : + ?timeout : float -> + ?env : string array -> + ?stdout : redirection -> + ?stderr : redirection -> + command -> (process_out -> 'a Lwt.t) -> 'a Lwt.t + +class process : + ?timeout : float -> + ?env : string array -> + ?stderr : redirection -> + command -> +object + inherit process_none + + method stdin : Lwt_io.output_channel + method stdout : Lwt_io.input_channel +end + +val open_process : + ?timeout : float -> + ?env : string array -> + ?stderr : redirection -> + command -> process +val with_process : + ?timeout : float -> + ?env : string array -> + ?stderr : redirection -> + command -> (process -> 'a Lwt.t) -> 'a Lwt.t + +class process_full : + ?timeout : float -> + ?env : string array -> + command -> +object + inherit process_none + + method stdin : Lwt_io.output_channel + method stdout : Lwt_io.input_channel + method stderr : Lwt_io.input_channel +end + +val open_process_full : + ?timeout : float -> + ?env : string array -> + command -> process_full +val with_process_full : + ?timeout : float -> + ?env : string array -> + command -> (process_full -> 'a Lwt.t) -> 'a Lwt.t diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_sys.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_sys.ml new file mode 100644 index 0000000..4ce61cd --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_sys.ml @@ -0,0 +1,63 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_sys + * Copyright (C) 2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +#include "src/unix/lwt_config.ml" + +exception Not_available of string + +let () = Callback.register_exception "lwt:not-available" (Not_available "") + +let windows = Sys.os_type <> "Unix" + +type feature = + [ `wait4 + | `get_cpu + | `get_affinity + | `set_affinity + | `recv_msg + | `send_msg + | `fd_passing + | `get_credentials + | `mincore + | `madvise + | `fdatasync + | `libev ] + +let have = function + | `wait4 + | `recv_msg + | `send_msg + | `mincore + | `madvise -> not windows + | `get_cpu -> <:optcomp< HAVE_GETCPU >> + | `get_affinity + | `set_affinity -> <:optcomp< HAVE_AFFINITY >> + | `fd_passing -> <:optcomp< HAVE_FD_PASSING >> + | `get_credentials -> <:optcomp< HAVE_GET_CREDENTIALS >> + | `fdatasync -> <:optcomp< HAVE_FDATASYNC >> + | `libev -> <:optcomp< HAVE_LIBEV >> + +type byte_order = Little_endian | Big_endian + +external get_byte_order : unit -> byte_order = "lwt_unix_system_byte_order" + +let byte_order = get_byte_order () diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_sys.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_sys.mli new file mode 100644 index 0000000..ceebafa --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_sys.mli @@ -0,0 +1,55 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_sys + * Copyright (C) 2011 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** System informations. *) + +exception Not_available of string + (** [Not_available(feature)] is an exception that may be raised when + a feature is not available on the current system. *) + +val windows : bool + (** [true] iff running on windows. *) + +(** Features that can be tested. *) +type feature = + [ `wait4 + | `get_cpu + | `get_affinity + | `set_affinity + | `recv_msg + | `send_msg + | `fd_passing + | `get_credentials + | `mincore + | `madvise + | `fdatasync + | `libev ] + +val have : feature -> bool + (** Test whether the given feature is available on the current + system. *) + +type byte_order = Little_endian | Big_endian + (** Type of byte order *) + +val byte_order : byte_order + (** The byte order used by the computer running the program. *) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.ml new file mode 100644 index 0000000..d3cf42e --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.ml @@ -0,0 +1,133 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_throttle + * Copyright (C) 2008 Stphane Glondu + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt + +module type S = sig + type key + type t + + val create : rate:int -> max:int -> n:int -> t + val wait : t -> key -> bool Lwt.t +end + +let section = Lwt_log.Section.make "Lwt_throttle" + +module Make (H : Hashtbl.HashedType) : (S with type key = H.t) = struct + module MH = Hashtbl.Make(H) + + type key = H.t + type elt = { + mutable consumed : int; + queue : bool Lwt.u Queue.t; + } + + type t = { + rate : int; + max : int; (* maximum number of waiting threads *) + mutable waiting : int; + table : elt MH.t; + mutable cleaning : unit Lwt.t option; + } + + let create ~rate ~max ~n = + if rate < 1 || max < 1 || n < 0 then + invalid_arg "Lwt_throttle.S.create" + else { + rate = rate; + max = max; + waiting = 0; + table = MH.create n; + cleaning = None; + } + + let update_key t key elt (old_waiting,to_run) = + let rec update to_run = function + | 0 -> 0, Queue.length elt.queue, to_run + | i -> + try + let to_run = (Queue.take elt.queue)::to_run in + update to_run (i-1) + with + | Queue.Empty -> i, 0, to_run + in + let not_consumed, waiting, to_run = update to_run t.rate in + let consumed = t.rate - not_consumed in + if consumed = 0 + then + (* there is no waiting threads for this key: we can clean the table *) + MH.remove t.table key + else elt.consumed <- consumed; + (old_waiting+waiting, to_run) + + let rec clean_table t = + let waiting,to_run = MH.fold (update_key t) t.table (0,[]) in + t.waiting <- waiting; + if waiting = 0 && to_run = [] + then + (* the table is empty: we do not need to clean in 1 second *) + t.cleaning <- None + else launch_cleaning t; + List.iter (fun u -> wakeup u true) to_run + + and launch_cleaning t = + t.cleaning <- + let t = + lwt () = Lwt_unix.sleep 1. in + try_lwt + clean_table t; + return (); + with + | exn -> Lwt_log.fatal ~exn ~section "internal error" + in + Some t + + let really_wait t elt = + let w,u = Lwt.task () in + if t.max > t.waiting + then (Queue.add u elt.queue; + t.waiting <- succ t.waiting; + w) + else return false + + let wait t key = + let res = + try + let elt = MH.find t.table key in + if elt.consumed >= t.rate + then really_wait t elt + else (elt.consumed <- succ elt.consumed; + return true) + with + | Not_found -> + let elt = { consumed = 1; + queue = Queue.create () } in + MH.add t.table key elt; + return true + in + (match t.cleaning with + | None -> launch_cleaning t + | Some _ -> ()); + res + +end diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.mli new file mode 100644 index 0000000..94ad925 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_throttle.mli @@ -0,0 +1,47 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_throttle + * Copyright (C) 2008 Stphane Glondu + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Rate limiters *) + +(** This module defines rate limiters. A rate limiter is parametrized + by its limit and a maximum waiting time. The [wait] function will + collaboratively hang for a delay necessary to respect the + limit. If that delay exceeds the maximum waiting time, [wait] + returns [false]; otherwise it returns [true]. *) + +module type S = sig + type key + type t + + val create : rate:int -> max:int -> n:int -> t + (** + @param rate maximum number of connections per second + @param max maximum waiting time (in seconds) + @param n initial size of the hash table + *) + + val wait : t -> key -> bool Lwt.t + (** @return [false] if maximum reached, [true] else *) +end + +module Make (H : Hashtbl.HashedType) : S with type key = H.t diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.ml new file mode 100644 index 0000000..7baa2e0 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.ml @@ -0,0 +1,127 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_timeout + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +let section = Lwt_log.Section.make "lwt(timeout)" + +type t = + { mutable delay : int; action : unit -> unit; + mutable prev : t; mutable next : t } + +let make delay action = + let rec x = { delay = delay; action = action; prev = x; next = x } in + x + +let lst_empty () = make (-1) (fun () -> ()) + +let lst_remove x = + let p = x.prev in + let n = x.next in + p.next <- n; + n.prev <- p; + x.next <- x; + x.prev <- x + +let lst_insert p x = + let n = p.next in + p.next <- x; + x.prev <- p; + x.next <- n; + n.prev <- x + +let lst_in_list x = x.next != x + +let lst_is_empty set = set.next == set + +let lst_peek s = let x = s.next in lst_remove x; x + +(****) + +let count = ref 0 + +let buckets = ref [||] + +let curr = ref 0 + +let stopped = ref true + +let size l = + let len = Array.length !buckets in + if l >= len then begin + let b = Array.init (l + 1) (fun _ -> lst_empty ()) in + Array.blit !buckets !curr b 0 (len - !curr); + Array.blit !buckets 0 b (len - !curr) !curr; + buckets := b; curr := 0; + end + +(****) + +let handle_exn = + ref + (fun exn -> + ignore (Lwt_log.error ~section ~exn "uncaught exception after timeout"); + exit 1) + +let set_exn_handler f = handle_exn := f + +let rec loop () = + stopped := false; + Lwt.bind (Lwt_unix.sleep 1.) (fun () -> + let s = !buckets.(!curr) in + while not (lst_is_empty s) do + let x = lst_peek s in + decr count; +(*XXX Should probably report any exception *) + try + x.action () + with e -> !handle_exn e + done; + curr := (!curr + 1) mod (Array.length !buckets); + if !count > 0 then loop () else begin stopped := true; Lwt.return () end) + +let start x = + let in_list = lst_in_list x in + let slot = (!curr + x.delay) mod (Array.length !buckets) in + lst_remove x; + lst_insert !buckets.(slot) x; + if not in_list then begin + incr count; + if !count = 1 && !stopped then ignore (loop ()) + end + +let create delay action = + if delay < 1 then invalid_arg "Lwt_timeout.create"; + let x = make delay action in + size delay; + x + +let stop x = + if lst_in_list x then begin + lst_remove x; + decr count + end + +let change x delay = + if delay < 1 then invalid_arg "Lwt_timeout.change"; + x.delay <- delay; + size delay; + if lst_in_list x then start x diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.mli new file mode 100644 index 0000000..314fe17 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_timeout.mli @@ -0,0 +1,47 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_timeout + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Timeouts *) + +type t + +val set_exn_handler : (exn -> unit) -> unit +(** set the default handler for exception occurring after a timeout. + The function lauched after a timeout should not raise any exception. + That's why the default handler will exit the program. +*) + +val create : int -> (unit -> unit) -> t +(** [create n f] defines a new timeout with [n] seconds duration. [f] is + the function to be called after the timeout. + That function must not raise any exception. +*) + +val start : t -> unit +(** starts a timeout. *) + +val stop : t -> unit +(** stops a timeout. *) + +val change : t -> int -> unit +(** changes the duration of a timeout. *) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_unix.h b/thirdparty/lwt-2.3.2/src/unix/lwt_unix.h new file mode 100644 index 0000000..995dcbb --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_unix.h @@ -0,0 +1,218 @@ +/* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Header lwt_unix + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + */ + +#ifndef __LWT_UNIX_H +#define __LWT_UNIX_H + +#include +#include + +/* Detect the target OS */ +#if defined(_WIN32) || defined(_WIN64) +# define LWT_ON_WINDOWS +#endif + +/* The macro to get the file-descriptor from a value. */ +#if defined(LWT_ON_WINDOWS) +# define FD_val(value) win_CRT_fd_of_filedescr(value) +#else +# define FD_val(value) Int_val(value) +#endif + +/* Macro to extract a libev loop from a caml value. */ +#define Ev_loop_val(value) *(struct ev_loop**)Data_custom_val(value) + +/* +-----------------------------------------------------------------+ + | Utils | + +-----------------------------------------------------------------+ */ + +/* Allocate the given amount of memory and abort the program if there + is no free memory left. */ +void *lwt_unix_malloc(size_t size); + +/* Same as [strdup] and abort hte program if there is not memory + left. */ +char *lwt_unix_strdup(char *string); + +/* Helper for allocating structures. */ +#define lwt_unix_new(type) (type*)lwt_unix_malloc(sizeof(type)) + +/* Raise [Lwt_unix.Not_available]. */ +void lwt_unix_not_available(char const *feature) Noreturn; + +/* +-----------------------------------------------------------------+ + | Notifications | + +-----------------------------------------------------------------+ */ + +/* Sends a notification for the given id. */ +void lwt_unix_send_notification(int id); + +/* +-----------------------------------------------------------------+ + | Threading | + +-----------------------------------------------------------------+ */ + +#if defined(LWT_ON_WINDOWS) + +typedef DWORD lwt_unix_thread; +typedef CRITICAL_SECTION lwt_unix_mutex; +typedef struct lwt_unix_condition lwt_unix_condition; + +#else + +#include + +typedef pthread_t lwt_unix_thread; +typedef pthread_mutex_t lwt_unix_mutex; +typedef pthread_cond_t lwt_unix_condition; + +#endif + +/* Launch a thread in detached mode. */ +void lwt_unix_launch_thread(void* (*start)(void*), void* data); + +/* Return a handle to the currently running thread. */ +lwt_unix_thread lwt_unix_thread_self(); + +/* Returns whether two thread handles refer to the same thread. */ +int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2); + +/* Initialises a mutex. */ +void lwt_unix_mutex_init(lwt_unix_mutex *mutex); + +/* Destroy a mutex. */ +void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex); + +/* Lock a mutex. */ +void lwt_unix_mutex_lock(lwt_unix_mutex *mutex); + +/* Unlock a mutex. */ +void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex); + +/* Initialises a condition variable. */ +void lwt_unix_condition_init(lwt_unix_condition *condition); + +/* Destroy a condition variable. */ +void lwt_unix_condition_destroy(lwt_unix_condition *condition); + +/* Signal a condition variable. */ +void lwt_unix_condition_signal(lwt_unix_condition *condition); + +/* Broadcast a signal on a condition variable. */ +void lwt_unix_condition_broadcast(lwt_unix_condition *condition); + +/* Wait for a signal on a condition variable. */ +void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex); + +/* +-----------------------------------------------------------------+ + | Detached jobs | + +-----------------------------------------------------------------+ */ + +/* How job are executed. */ +enum lwt_unix_async_method { + /* Synchronously. */ + LWT_UNIX_ASYNC_METHOD_NONE = 0, + + /* Asynchronously, on another thread. */ + LWT_UNIX_ASYNC_METHOD_DETACH = 1, + + /* Asynchronously, on the main thread, switcing to another thread if + necessary. */ + LWT_UNIX_ASYNC_METHOD_SWITCH = 2 +}; + +/* Type of job execution modes. */ +typedef enum lwt_unix_async_method lwt_unix_async_method; + +/* State of a job. */ +enum lwt_unix_job_state { + /* The job has not yet started. */ + LWT_UNIX_JOB_STATE_PENDING, + + /* The job is running. */ + LWT_UNIX_JOB_STATE_RUNNING, + + /* The job is done. */ + LWT_UNIX_JOB_STATE_DONE, + + /* The job has been canceled. */ + LWT_UNIX_JOB_STATE_CANCELED +}; + +/* A job descriptor. */ +struct lwt_unix_job { + /* The next job in the queue. */ + struct lwt_unix_job *next; + + /* Id used to notify the main thread in case the job do not + terminate immediatly. */ + int notification_id; + + /* The function to call to do the work. */ + void (*worker)(struct lwt_unix_job *job); + + /* State of the job. */ + enum lwt_unix_job_state state; + + /* Is the main thread still waiting for the job ? */ + int fast; + + /* Mutex to protect access to [state] and [fast]. */ + lwt_unix_mutex mutex; + + /* Thread running the job. */ + lwt_unix_thread thread; + + /* The async method in used by the job. */ + lwt_unix_async_method async_method; +}; + +/* Type of job descriptors. */ +typedef struct lwt_unix_job* lwt_unix_job; + +/* Type of worker functions. */ +typedef void (*lwt_unix_job_worker)(lwt_unix_job job); + +/* Allocate a caml custom value for the given job. */ +value lwt_unix_alloc_job(lwt_unix_job job); + +/* Free resourecs allocated for this job and free it. */ +void lwt_unix_free_job(lwt_unix_job job); + +/* Define not implement methods. */ +#define LWT_UNIX_JOB_NOT_IMPLEMENTED(name) \ + CAMLprim value lwt_unix_##name##_job() \ + { \ + caml_invalid_argument("not implemented"); \ + } \ + \ + CAMLprim value lwt_unix_##name##_result() \ + { \ + caml_invalid_argument("not implemented"); \ + } \ + \ + CAMLprim value lwt_unix_##name##_free() \ + { \ + caml_invalid_argument("not implemented"); \ + } + + +#endif /* __LWT_UNIX_H */ diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_unix.ml b/thirdparty/lwt-2.3.2/src/unix/lwt_unix.ml new file mode 100644 index 0000000..7acc69c --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_unix.ml @@ -0,0 +1,2681 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_unix + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * 2009 Jrmie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +#include "src/unix/lwt_config.ml" + +open Lwt + +(* +-----------------------------------------------------------------+ + | Configuration | + +-----------------------------------------------------------------+ *) + +type async_method = + | Async_none + | Async_detach + | Async_switch + +let default_async_method_var = ref Async_detach + +let () = + try + match Sys.getenv "LWT_ASYNC_METHOD" with + | "none" -> + default_async_method_var := Async_none + | "detach" -> + default_async_method_var := Async_detach + | "switch" -> + default_async_method_var := Async_switch + | str -> + Printf.eprintf + "%s: invalid lwt async method: '%s', must be 'none', 'detach' or 'switch'\n%!" + (Filename.basename Sys.executable_name) str + with Not_found -> + () + +let default_async_method () = !default_async_method_var +let set_default_async_method am = default_async_method_var := am + +let async_method_key = Lwt.new_key () + +let async_method () = + match Lwt.get async_method_key with + | Some am -> am + | None -> !default_async_method_var + +let with_async_none f = + with_value async_method_key (Some Async_none) f + +let with_async_detach f = + with_value async_method_key (Some Async_detach) f + +let with_async_switch f = + with_value async_method_key (Some Async_switch) f + +(* +-----------------------------------------------------------------+ + | Notifications management | + +-----------------------------------------------------------------+ *) + +(* Informations about a notifier *) +type notifier = { + notify_handler : unit -> unit; + (* The callback *) + + notify_once : bool; + (* Whether to remove the notifier after the reception of the first + notification *) +} + +module Notifiers = Hashtbl.Make(struct + type t = int + let equal (x : int) (y : int) = x = y + let hash (x : int) = x + end) + +let notifiers = Notifiers.create 1024 + +let current_notification_id = ref 0 + +let rec find_free_id id = + if Notifiers.mem notifiers id then + find_free_id (id + 1) + else + id + +let make_notification ?(once=false) f = + let id = find_free_id (!current_notification_id + 1) in + current_notification_id := id; + Notifiers.add notifiers id { notify_once = once; notify_handler = f }; + id + +let stop_notification id = + Notifiers.remove notifiers id + +let set_notification id f = + let notifier = Notifiers.find notifiers id in + Notifiers.replace notifiers id { notifier with notify_handler = f } + +(* +-----------------------------------------------------------------+ + | Sleepers | + +-----------------------------------------------------------------+ *) + +let sleep delay = + let waiter, wakener = Lwt.task () in + let ev = Lwt_engine.on_timer delay false (fun ev -> Lwt_engine.stop_event ev; Lwt.wakeup wakener ()) in + Lwt.on_cancel waiter (fun () -> Lwt_engine.stop_event ev); + waiter + +let yield = Lwt_main.yield + +let auto_yield timeout = + let limit = ref (Unix.gettimeofday () +. timeout) in + fun () -> + let current = Unix.gettimeofday () in + if current >= !limit then begin + limit := current +. timeout; + yield (); + end else + return () + +exception Timeout + +let timeout d = sleep d >> Lwt.fail Timeout + +let with_timeout d f = Lwt.pick [timeout d; Lwt.apply f ()] + +(* +-----------------------------------------------------------------+ + | Jobs | + +-----------------------------------------------------------------+ *) + +type 'a job + +external start_job : 'a job -> async_method -> bool = "lwt_unix_start_job" + (* Starts the given job with given parameters. It returns [true] + if the job is already terminated. *) + +external check_job : 'a job -> int -> bool = "lwt_unix_check_job" "noalloc" + (* Check whether that a job has terminated or not. If it has not + yet terminated, it is marked so it will send a notification + when it finishes. *) + +external cancel_job : 'a job -> unit = "lwt_unix_cancel_job" "noalloc" + (* Cancel the thread of the given job. *) + +(* All running jobs. *) +let jobs = Lwt_sequence.create () + +(* Cancel all running jobs. *) +let rec cancel_jobs () = + match Lwt_sequence.take_opt_l jobs with + | Some w -> cancel w; cancel_jobs () + | None -> () + +let wait_for_jobs () = + join (Lwt_sequence.fold_l (fun w l -> w :: l) jobs []) + +let execute_job ?async_method ~job ~result ~free = + let async_method = + match async_method with + | Some am -> am + | None -> + match Lwt.get async_method_key with + | Some am -> am + | None -> !default_async_method_var + in + (* Starts the job. *) + let job_done = start_job job async_method in + let w = + lwt status = + if job_done then + return None + else + (* Create the notification for asynchronous wakeup. *) + let id = make_notification ~once:true ignore in + try_lwt + (* Give some time to the job before we fallback to + asynchronous notification. *) + lwt () = pause () in + if check_job job id then begin + stop_notification id; + return None + end else + return (Some id) + with Canceled as exn -> + cancel_job job; + (* Free resources when the job terminates. *) + if check_job job id then begin + stop_notification id; + free job + end else + set_notification id (fun () -> free job); + raise_lwt exn + in + match status with + | None -> + (* The job has already terminated, read and return the result + immediatly. *) + let thread = + try + return (result job) + with exn -> + fail exn + in + free job; + thread + | Some id -> + (* The job has not terminated, setup the notification for the + asynchronous wakeup. *) + let waiter, wakener = task () in + set_notification id + (fun () -> + begin + try + wakeup wakener (result job); + with exn -> + wakeup_exn wakener exn + end; + free job); + on_cancel waiter + (fun () -> + cancel_job job; + set_notification id (fun () -> free job)); + waiter + in + if state w = Sleep then begin + (* Add the job to the sequence of all jobs. *) + let node = Lwt_sequence.add_l (w >> return ()) jobs in + (* Remove it on termination. *) + on_termination w (fun () -> Lwt_sequence.remove node) + end; + w + +(* +-----------------------------------------------------------------+ + | File descriptor wrappers | + +-----------------------------------------------------------------+ *) + +type state = Opened | Closed | Aborted of exn + +type file_descr = { + fd : Unix.file_descr; + (* The underlying unix file descriptor *) + + mutable state: state; + (* The state of the file descriptor *) + + mutable set_flags : bool; + (* Whether to set file flags *) + + mutable blocking : bool Lwt.t Lazy.t; + (* Is the file descriptor in blocking or non-blocking mode *) + + mutable event_readable : Lwt_engine.event option; + (* The event used to check the file descriptor for readability. *) + + mutable event_writable : Lwt_engine.event option; + (* The event used to check the file descriptor for writability. *) + + hooks_readable : (unit -> unit) Lwt_sequence.t; + (* Hooks to call when the file descriptor becomes readable. *) + + hooks_writable : (unit -> unit) Lwt_sequence.t; + (* Hooks to call when the file descriptor becomes writable. *) +} + +#if windows + +external is_socket : Unix.file_descr -> bool = "lwt_unix_is_socket" "noalloc" + +let is_blocking ?blocking ?(set_flags=true) fd = + if is_socket fd then + match blocking, set_flags with + | Some state, false -> + lazy(return state) + | Some true, true -> + Unix.clear_nonblock fd; + lazy(return true) + | Some false, true -> + Unix.set_nonblock fd; + lazy(return false) + | None, false -> + lazy(return false) + | None, true -> + Unix.set_nonblock fd; + lazy(return false) + else + match blocking with + | Some state -> + lazy(return state) + | None -> + lazy(return true) + +#else + +external guess_blocking_job : Unix.file_descr -> [ `unix_guess_blocking ] job = "lwt_unix_guess_blocking_job" +external guess_blocking_result : [ `unix_guess_blocking ] job -> bool = "lwt_unix_guess_blocking_result" "noalloc" +external guess_blocking_free : [ `unix_guess_blocking ] job -> unit = "lwt_unix_guess_blocking_free" "noalloc" + +let guess_blocking fd = + execute_job (guess_blocking_job fd) guess_blocking_result guess_blocking_free + +let is_blocking ?blocking ?(set_flags=true) fd = + match blocking, set_flags with + | Some state, false -> + lazy(return state) + | Some true, true -> + Unix.clear_nonblock fd; + lazy(return true) + | Some false, true -> + Unix.set_nonblock fd; + lazy(return false) + | None, false -> + lazy(guess_blocking fd) + | None, true -> + lazy(guess_blocking fd >>= function + | true -> + Unix.clear_nonblock fd; + return true + | false -> + Unix.set_nonblock fd; + return false) + +#endif + +let mk_ch ?blocking ?(set_flags=true) fd = { + fd = fd; + state = Opened; + set_flags = set_flags; + blocking = is_blocking ?blocking ~set_flags fd; + event_readable = None; + event_writable = None; + hooks_readable = Lwt_sequence.create (); + hooks_writable = Lwt_sequence.create (); +} + +let rec check_descriptor ch = + match ch.state with + | Opened -> + () + | Aborted e -> + raise e + | Closed -> + raise (Unix.Unix_error (Unix.EBADF, "check_descriptor", "")) + +let state ch = ch.state + +let blocking ch = + check_descriptor ch; + Lazy.force ch.blocking + +let set_blocking ?(set_flags=true) ch blocking = + check_descriptor ch; + ch.set_flags <- set_flags; + ch.blocking <- is_blocking ~blocking ~set_flags ch.fd + +#if windows + +let stub_readable fd = Unix.select [fd] [] [] (-1.0) <> ([], [], []) +let stub_writable fd = Unix.select [] [fd] [] (-1.0) <> ([], [], []) + +#else + +external stub_readable : Unix.file_descr -> bool = "lwt_unix_readable" +external stub_writable : Unix.file_descr -> bool = "lwt_unix_writable" + +#endif + +let readable ch = + check_descriptor ch; + stub_readable ch.fd + +let writable ch = + check_descriptor ch; + stub_writable ch.fd + +let set_state ch st = + ch.state <- st + +let clear_events ch = + Lwt_sequence.iter_node_l (fun node -> Lwt_sequence.remove node; Lwt_sequence.get node ()) ch.hooks_readable; + Lwt_sequence.iter_node_l (fun node -> Lwt_sequence.remove node; Lwt_sequence.get node ()) ch.hooks_writable; + begin + match ch.event_readable with + | Some ev -> + ch.event_readable <- None; + Lwt_engine.stop_event ev + | None -> + () + end; + begin + match ch.event_writable with + | Some ev -> + ch.event_writable <- None; + Lwt_engine.stop_event ev + | None -> + () + end + +let abort ch e = + if ch.state <> Closed then begin + set_state ch (Aborted e); + clear_events ch + end + +let unix_file_descr ch = ch.fd + +let of_unix_file_descr = mk_ch + +let stdin = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stdin +let stdout = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stdout +let stderr = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stderr + +(* +-----------------------------------------------------------------+ + | Actions on file descriptors | + +-----------------------------------------------------------------+ *) + +type io_event = Read | Write + +exception Retry +exception Retry_write +exception Retry_read + +type 'a outcome = + | Success of 'a + | Exn of exn + | Requeued of io_event + +(* Wait a bit, then stop events that are no more used. *) +let stop_events ch = + on_success + (pause ()) + (fun () -> + if Lwt_sequence.is_empty ch.hooks_readable then begin + match ch.event_readable with + | Some ev -> + ch.event_readable <- None; + Lwt_engine.stop_event ev + | None -> + () + end; + if Lwt_sequence.is_empty ch.hooks_writable then begin + match ch.event_writable with + | Some ev -> + ch.event_writable <- None; + Lwt_engine.stop_event ev + | None -> + () + end) + +let register_readable ch = + if ch.event_readable = None then + ch.event_readable <- Some(Lwt_engine.on_readable ch.fd (fun _ -> Lwt_sequence.iter_l (fun f -> f ()) ch.hooks_readable)) + +let register_writable ch = + if ch.event_writable = None then + ch.event_writable <- Some(Lwt_engine.on_writable ch.fd (fun _ -> Lwt_sequence.iter_l (fun f -> f ()) ch.hooks_writable)) + +(* Retry a queued syscall, [wakener] is the thread to wakeup if the + action succeeds: *) +let rec retry_syscall node event ch wakener action = + let res = + try + check_descriptor ch; + Success(action ()) + with + | Retry + | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) + | Sys_blocked_io -> + (* EINTR because we are catching SIG_CHLD hence the system + call might be interrupted to handle the signal; this lets + us restart the system call eventually. *) + Requeued event + | Retry_read -> + Requeued Read + | Retry_write -> + Requeued Write + | e -> + Exn e + in + match res with + | Success v -> + Lwt_sequence.remove !node; + stop_events ch; + Lwt.wakeup wakener v + | Exn e -> + Lwt_sequence.remove !node; + stop_events ch; + Lwt.wakeup_exn wakener e + | Requeued event' -> + if event <> event' then begin + Lwt_sequence.remove !node; + stop_events ch; + match event' with + | Read -> + node := Lwt_sequence.add_r (fun () -> retry_syscall node Read ch wakener action) ch.hooks_readable ; + register_readable ch + | Write -> + node := Lwt_sequence.add_r (fun () -> retry_syscall node Write ch wakener action) ch.hooks_writable; + register_writable ch + end + +let dummy = Lwt_sequence.add_r ignore (Lwt_sequence.create ()) + +let register_action event ch action = + let waiter, wakener = Lwt.task () in + match event with + | Read -> + let node = ref dummy in + node := Lwt_sequence.add_r (fun () -> retry_syscall node Read ch wakener action) ch.hooks_readable; + on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); + register_readable ch; + waiter + | Write -> + let node = ref dummy in + node := Lwt_sequence.add_r (fun () -> retry_syscall node Write ch wakener action) ch.hooks_writable; + on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); + register_writable ch; + waiter + +(* Wraps a system call *) +let wrap_syscall event ch action = + try + check_descriptor ch; + lwt blocking = Lazy.force ch.blocking in + if not blocking || (event = Read && stub_readable ch.fd) || (event = Write && stub_writable ch.fd) then + return (action ()) + else + register_action event ch action + with + | Retry + | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) + | Sys_blocked_io -> + (* The action could not be completed immediatly, register it: *) + register_action event ch action + | Retry_read -> + register_action Read ch action + | Retry_write -> + register_action Write ch action + | e -> + raise_lwt e + +(* +-----------------------------------------------------------------+ + | Basic file input/output | + +-----------------------------------------------------------------+ *) + +type open_flag = + Unix.open_flag = + | O_RDONLY + | O_WRONLY + | O_RDWR + | O_NONBLOCK + | O_APPEND + | O_CREAT + | O_TRUNC + | O_EXCL + | O_NOCTTY + | O_DSYNC + | O_SYNC + | O_RSYNC + +#if windows + +let openfile name flags perms = + return (of_unix_file_descr (Unix.openfile name flags perms)) + +#else + +external open_job : string -> Unix.open_flag list -> int -> [ `unix_open ] job = "lwt_unix_open_job" +external open_result : [ `unix_open ] job -> Unix.file_descr * bool = "lwt_unix_open_result" +external open_free : [ `unix_open ] job -> unit = "lwt_unix_open_free" "noalloc" + +let openfile name flags perms = + lwt fd, blocking = + execute_job + (open_job name flags perms) + open_result + open_free + in + return (of_unix_file_descr ~blocking fd) + +#endif + +#if windows + +let close ch = + if ch.state = Closed then check_descriptor ch; + set_state ch Closed; + clear_events ch; + return (Unix.close ch.fd) + +#else + +external close_job : Unix.file_descr -> [ `unix_close ] job = "lwt_unix_close_job" +external close_result : [ `unix_close ] job -> unit = "lwt_unix_close_result" +external close_free : [ `unix_close ] job -> unit = "lwt_unix_close_free" "noalloc" + +let close ch = + if ch.state = Closed then check_descriptor ch; + set_state ch Closed; + clear_events ch; + execute_job (close_job ch.fd) close_result close_free + +#endif + +let wait_read ch = + try_lwt + if readable ch then + return () + else + register_action Read ch ignore + +external stub_read : Unix.file_descr -> string -> int -> int -> int = "lwt_unix_read" +external read_job : Unix.file_descr -> int -> [ `unix_read ] job = "lwt_unix_read_job" +external read_result : [ `unix_read ] job -> string -> int -> int = "lwt_unix_read_result" +external read_free : [ `unix_read ] job -> unit = "lwt_unix_read_free" "noalloc" + +let read ch buf pos len = + if pos < 0 || len < 0 || pos > String.length buf - len then + invalid_arg "Lwt_unix.read" + else + Lazy.force ch.blocking >>= function + | true -> + lwt () = wait_read ch in + execute_job (read_job ch.fd len) (fun job -> read_result job buf pos) read_free + | false -> + wrap_syscall Read ch (fun () -> stub_read ch.fd buf pos len) + +let wait_write ch = + try_lwt + if writable ch then + return () + else + register_action Write ch ignore + +external stub_write : Unix.file_descr -> string -> int -> int -> int = "lwt_unix_write" +external write_job : Unix.file_descr -> string -> int -> int -> [ `unix_write ] job = "lwt_unix_write_job" +external write_result : [ `unix_write ] job -> int = "lwt_unix_write_result" +external write_free : [ `unix_write ] job -> unit = "lwt_unix_write_free" "noalloc" + +let write ch buf pos len = + if pos < 0 || len < 0 || pos > String.length buf - len then + invalid_arg "Lwt_unix.write" + else + Lazy.force ch.blocking >>= function + | true -> + lwt () = wait_write ch in + execute_job (write_job ch.fd buf pos len) write_result write_free + | false -> + wrap_syscall Write ch (fun () -> stub_write ch.fd buf pos len) + +(* +-----------------------------------------------------------------+ + | Seeking and truncating | + +-----------------------------------------------------------------+ *) + +type seek_command = + Unix.seek_command = + | SEEK_SET + | SEEK_CUR + | SEEK_END + +#if windows + +let lseek ch offset whence = + check_descriptor ch; + return (Unix.lseek ch.fd offset whence) + +#else + +external lseek_job : Unix.file_descr -> int -> Unix.seek_command -> [ `unix_lseek ] job = "lwt_unix_lseek_job" +external lseek_result : [ `unix_lseek ] job -> int = "lwt_unix_lseek_result" +external lseek_free : [ `unix_lseek ] job -> unit = "lwt_unix_lseek_free" + +let lseek ch offset whence = + check_descriptor ch; + execute_job (lseek_job ch.fd offset whence) lseek_result lseek_free + +#endif + +#if windows + +let truncate name offset = + return (Unix.truncate name offset) + +#else + +external truncate_job : string -> int -> [ `unix_truncate ] job = "lwt_unix_truncate_job" +external truncate_result : [ `unix_truncate ] job -> unit = "lwt_unix_truncate_result" +external truncate_free : [ `unix_truncate ] job -> unit = "lwt_unix_truncate_free" + +let truncate name offset = + execute_job (truncate_job name offset) truncate_result truncate_free + +#endif + +#if windows + +let ftruncate ch offset = + check_descriptor ch; + return (Unix.ftruncate ch.fd offset) + +#else + +external ftruncate_job : Unix.file_descr -> int -> [ `unix_ftruncate ] job = "lwt_unix_ftruncate_job" +external ftruncate_result : [ `unix_ftruncate ] job -> unit = "lwt_unix_ftruncate_result" +external ftruncate_free : [ `unix_ftruncate ] job -> unit = "lwt_unix_ftruncate_free" + +let ftruncate ch offset = + check_descriptor ch; + execute_job (ftruncate_job ch.fd offset) ftruncate_result ftruncate_free + +#endif + +(* +-----------------------------------------------------------------+ + | Syncing | + +-----------------------------------------------------------------+ *) + +external fsync_job : Unix.file_descr -> [ `unix_fsync ] job = "lwt_unix_fsync_job" +external fsync_result : [ `unix_fsync ] job -> unit = "lwt_unix_fsync_result" +external fsync_free : [ `unix_fsync ] job -> unit = "lwt_unix_fsync_free" + +let fsync ch = + check_descriptor ch; + execute_job (fsync_job ch.fd) fsync_result fsync_free + +#if HAVE_FDATASYNC + +external fdatasync_job : Unix.file_descr -> [ `unix_fdatasync ] job = "lwt_unix_fdatasync_job" +external fdatasync_result : [ `unix_fdatasync ] job -> unit = "lwt_unix_fdatasync_result" +external fdatasync_free : [ `unix_fdatasync ] job -> unit = "lwt_unix_fdatasync_free" + +let fdatasync ch = + check_descriptor ch; + execute_job (fdatasync_job ch.fd) fdatasync_result fdatasync_free + +#else + +let fdatasync ch = + fail (Lwt_sys.Not_available "fdatasync") + +#endif + +(* +-----------------------------------------------------------------+ + | File status | + +-----------------------------------------------------------------+ *) + +type file_perm = Unix.file_perm + +type file_kind = + Unix.file_kind = + | S_REG + | S_DIR + | S_CHR + | S_BLK + | S_LNK + | S_FIFO + | S_SOCK + +type stats = + Unix.stats = + { + st_dev : int; + st_ino : int; + st_kind : file_kind; + st_perm : file_perm; + st_nlink : int; + st_uid : int; + st_gid : int; + st_rdev : int; + st_size : int; + st_atime : float; + st_mtime : float; + st_ctime : float; + } + +#if windows + +let stat name = + return (Unix.stat name) + +#else + +external stat_job : string -> [ `unix_stat ] job = "lwt_unix_stat_job" +external stat_result : [ `unix_stat ] job -> Unix.stats = "lwt_unix_stat_result" +external stat_free : [ `unix_stat ] job -> unit = "lwt_unix_stat_free" + +let stat name = + execute_job (stat_job name) stat_result stat_free + +#endif + +#if windows + +let lstat name = + return (Unix.lstat name) + +#else + +external lstat_job : string -> [ `unix_lstat ] job = "lwt_unix_lstat_job" +external lstat_result : [ `unix_lstat ] job -> Unix.stats = "lwt_unix_lstat_result" +external lstat_free : [ `unix_lstat ] job -> unit = "lwt_unix_lstat_free" + +let lstat name = + execute_job (lstat_job name) lstat_result lstat_free + +#endif + +#if windows + +let fstat ch = + check_descriptor ch; + return (Unix.fstat ch.fd) + +#else + +external fstat_job : Unix.file_descr -> [ `unix_fstat ] job = "lwt_unix_fstat_job" +external fstat_result : [ `unix_fstat ] job -> Unix.stats = "lwt_unix_fstat_result" +external fstat_free : [ `unix_fstat ] job -> unit = "lwt_unix_fstat_free" + +let fstat ch = + check_descriptor ch; + execute_job (fstat_job ch.fd) fstat_result fstat_free + +#endif + +#if windows + +let isatty ch = + check_descriptor ch; + return (Unix.isatty ch.fd) + +#else + +external isatty_job : Unix.file_descr -> [ `unix_isatty ] job = "lwt_unix_isatty_job" +external isatty_result : [ `unix_isatty ] job -> bool = "lwt_unix_isatty_result" +external isatty_free : [ `unix_isatty ] job -> unit = "lwt_unix_isatty_free" + +let isatty ch = + check_descriptor ch; + execute_job (isatty_job ch.fd) isatty_result isatty_free + +#endif + +(* +-----------------------------------------------------------------+ + | File operations on large files | + +-----------------------------------------------------------------+ *) + +module LargeFile = +struct + + type stats = + Unix.LargeFile.stats = + { + st_dev : int; + st_ino : int; + st_kind : file_kind; + st_perm : file_perm; + st_nlink : int; + st_uid : int; + st_gid : int; + st_rdev : int; + st_size : int64; + st_atime : float; + st_mtime : float; + st_ctime : float; + } + +#if windows + + let lseek ch offset whence = + check_descriptor ch; + return (Unix.LargeFile.lseek ch.fd offset whence) + +#else + + external lseek_job : Unix.file_descr -> int64 -> Unix.seek_command -> [ `unix_lseek ] job = "lwt_unix_lseek_64_job" + external lseek_result : [ `unix_lseek ] job -> int64 = "lwt_unix_lseek_64_result" + external lseek_free : [ `unix_lseek ] job -> unit = "lwt_unix_lseek_64_free" + + let lseek ch offset whence = + check_descriptor ch; + execute_job (lseek_job ch.fd offset whence) lseek_result lseek_free + +#endif + +#if windows + + let truncate name offset = + return (Unix.LargeFile.truncate name offset) + +#else + + external truncate_job : string -> int64 -> [ `unix_truncate ] job = "lwt_unix_truncate_64_job" + external truncate_result : [ `unix_truncate ] job -> unit = "lwt_unix_truncate_64_result" + external truncate_free : [ `unix_truncate ] job -> unit = "lwt_unix_truncate_64_free" + + let truncate name offset = + execute_job (truncate_job name offset) truncate_result truncate_free + +#endif + +#if windows + + let ftruncate ch offset = + check_descriptor ch; + return (Unix.LargeFile.ftruncate ch.fd offset) + +#else + + external ftruncate_job : Unix.file_descr -> int64 -> [ `unix_ftruncate ] job = "lwt_unix_ftruncate_64_job" + external ftruncate_result : [ `unix_ftruncate ] job -> unit = "lwt_unix_ftruncate_64_result" + external ftruncate_free : [ `unix_ftruncate ] job -> unit = "lwt_unix_ftruncate_64_free" + + let ftruncate ch offset = + check_descriptor ch; + execute_job (ftruncate_job ch.fd offset) ftruncate_result ftruncate_free + +#endif + +#if windows + + let stat name = + return (Unix.LargeFile.stat name) + +#else + + external stat_job : string -> [ `unix_stat ] job = "lwt_unix_stat_64_job" + external stat_result : [ `unix_stat ] job -> Unix.LargeFile.stats = "lwt_unix_stat_64_result" + external stat_free : [ `unix_stat ] job -> unit = "lwt_unix_stat_64_free" + + let stat name = + execute_job (stat_job name) stat_result stat_free + +#endif + +#if windows + + let lstat name = + return (Unix.LargeFile.lstat name) + +#else + + external lstat_job : string -> [ `unix_lstat ] job = "lwt_unix_lstat_64_job" + external lstat_result : [ `unix_lstat ] job -> Unix.LargeFile.stats = "lwt_unix_lstat_64_result" + external lstat_free : [ `unix_lstat ] job -> unit = "lwt_unix_lstat_64_free" + + let lstat name = + execute_job (lstat_job name) lstat_result lstat_free + +#endif + +#if windows + + let fstat ch = + check_descriptor ch; + return (Unix.LargeFile.fstat ch.fd) + +#else + + external fstat_job : Unix.file_descr -> [ `unix_fstat ] job = "lwt_unix_fstat_64_job" + external fstat_result : [ `unix_fstat ] job -> Unix.LargeFile.stats = "lwt_unix_fstat_64_result" + external fstat_free : [ `unix_fstat ] job -> unit = "lwt_unix_fstat_64_free" + + let fstat ch = + check_descriptor ch; + execute_job (fstat_job ch.fd) fstat_result fstat_free + +#endif + +end + +(* +-----------------------------------------------------------------+ + | Operations on file names | + +-----------------------------------------------------------------+ *) + +#if windows + +let unlink name = + return (Unix.unlink name) + +#else + +external unlink_job : string -> [ `unix_unlink ] job = "lwt_unix_unlink_job" +external unlink_result : [ `unix_unlink ] job -> unit = "lwt_unix_unlink_result" +external unlink_free : [ `unix_unlink ] job -> unit = "lwt_unix_unlink_free" + +let unlink name = + execute_job (unlink_job name) unlink_result unlink_free + +#endif + +#if windows + +let rename name1 name2 = + return (Unix.rename name1 name2) + +#else + +external rename_job : string -> string -> [ `unix_rename ] job = "lwt_unix_rename_job" +external rename_result : [ `unix_rename ] job -> unit = "lwt_unix_rename_result" +external rename_free : [ `unix_rename ] job -> unit = "lwt_unix_rename_free" + +let rename name1 name2 = + execute_job (rename_job name1 name2) rename_result rename_free + +#endif + +#if windows + +let link name1 name2 = + return (Unix.link name1 name2) + +#else + +external link_job : string -> string -> [ `unix_link ] job = "lwt_unix_link_job" +external link_result : [ `unix_link ] job -> unit = "lwt_unix_link_result" +external link_free : [ `unix_link ] job -> unit = "lwt_unix_link_free" + +let link name1 name2 = + execute_job (link_job name1 name2) link_result link_free + +#endif + +(* +-----------------------------------------------------------------+ + | File permissions and ownership | + +-----------------------------------------------------------------+ *) + +#if windows + +let chmod name perms = + return (Unix.chmod name perms) + +#else + +external chmod_job : string -> Unix.file_perm -> [ `unix_chmod ] job = "lwt_unix_chmod_job" +external chmod_result : [ `unix_chmod ] job -> unit = "lwt_unix_chmod_result" +external chmod_free : [ `unix_chmod ] job -> unit = "lwt_unix_chmod_free" + +let chmod name perms = + execute_job (chmod_job name perms) chmod_result chmod_free + +#endif + +#if windows + +let fchmod ch perms = + check_descriptor ch; + return (Unix.fchmod ch.fd perms) + +#else + +external fchmod_job : Unix.file_descr -> Unix.file_perm -> [ `unix_fchmod ] job = "lwt_unix_fchmod_job" +external fchmod_result : [ `unix_fchmod ] job -> unit = "lwt_unix_fchmod_result" +external fchmod_free : [ `unix_fchmod ] job -> unit = "lwt_unix_fchmod_free" + +let fchmod ch perms = + check_descriptor ch; + execute_job (fchmod_job ch.fd perms) fchmod_result fchmod_free + +#endif + +#if windows + +let chown name uid gid = + return (Unix.chown name uid gid) + +#else + +external chown_job : string -> int -> int -> [ `unix_chown ] job = "lwt_unix_chown_job" +external chown_result : [ `unix_chown ] job -> unit = "lwt_unix_chown_result" +external chown_free : [ `unix_chown ] job -> unit = "lwt_unix_chown_free" + +let chown name uid gid = + execute_job (chown_job name uid gid) chown_result chown_free + +#endif + +#if windows + +let fchown ch uid gid = + check_descriptor ch; + return (Unix.fchown ch.fd uid gid) + +#else + +external fchown_job : Unix.file_descr -> int -> int -> [ `unix_fchown ] job = "lwt_unix_fchown_job" +external fchown_result : [ `unix_fchown ] job -> unit = "lwt_unix_fchown_result" +external fchown_free : [ `unix_fchown ] job -> unit = "lwt_unix_fchown_free" + +let fchown ch uid gid = + check_descriptor ch; + execute_job (fchown_job ch.fd uid gid) fchown_result fchown_free + +#endif + +type access_permission = + Unix.access_permission = + | R_OK + | W_OK + | X_OK + | F_OK + +#if windows + +let access name perms = + return (Unix.access name perms) + +#else + +external access_job : string -> Unix.access_permission list -> [ `unix_access ] job = "lwt_unix_access_job" +external access_result : [ `unix_access ] job -> unit = "lwt_unix_access_result" +external access_free : [ `unix_access ] job -> unit = "lwt_unix_access_free" + +let access name perms = + execute_job (access_job name perms) access_result access_free + +#endif + +(* +-----------------------------------------------------------------+ + | Operations on file descriptors | + +-----------------------------------------------------------------+ *) + +let dup ch = + check_descriptor ch; + let fd = Unix.dup ch.fd in + { + fd = fd; + state = Opened; + set_flags = ch.set_flags; + blocking = + if ch.set_flags then + lazy(Lazy.force ch.blocking >>= function + | true -> + Unix.clear_nonblock fd; + return true + | false -> + Unix.set_nonblock fd; + return false) + else + ch.blocking; + event_readable = None; + event_writable = None; + hooks_readable = Lwt_sequence.create (); + hooks_writable = Lwt_sequence.create (); + } + +let dup2 ch1 ch2 = + check_descriptor ch1; + Unix.dup2 ch1.fd ch2.fd; + ch2.set_flags <- ch1.set_flags; + ch2.blocking <- ( + if ch2.set_flags then + lazy(Lazy.force ch1.blocking >>= function + | true -> + Unix.clear_nonblock ch2.fd; + return true + | false -> + Unix.set_nonblock ch2.fd; + return false) + else + ch1.blocking + ) + +let set_close_on_exec ch = + check_descriptor ch; + Unix.set_close_on_exec ch.fd + +let clear_close_on_exec ch = + check_descriptor ch; + Unix.clear_close_on_exec ch.fd + +(* +-----------------------------------------------------------------+ + | Directories | + +-----------------------------------------------------------------+ *) + +#if windows + +let mkdir name perms = + return (Unix.mkdir name perms) + +#else + +external mkdir_job : string -> Unix.file_perm -> [ `unix_mkdir ] job = "lwt_unix_mkdir_job" +external mkdir_result : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_result" +external mkdir_free : [ `unix_mkdir ] job -> unit = "lwt_unix_mkdir_free" + +let mkdir name perms = + execute_job (mkdir_job name perms) mkdir_result mkdir_free + +#endif + +#if windows + +let rmdir name = + return (Unix.rmdir name) + +#else + +external rmdir_job : string -> [ `unix_rmdir ] job = "lwt_unix_rmdir_job" +external rmdir_result : [ `unix_rmdir ] job -> unit = "lwt_unix_rmdir_result" +external rmdir_free : [ `unix_rmdir ] job -> unit = "lwt_unix_rmdir_free" + +let rmdir name = + execute_job (rmdir_job name) rmdir_result rmdir_free + +#endif + +#if windows + +let chdir name = + return (Unix.chdir name) + +#else + +external chdir_job : string -> [ `unix_chdir ] job = "lwt_unix_chdir_job" +external chdir_result : [ `unix_chdir ] job -> unit = "lwt_unix_chdir_result" +external chdir_free : [ `unix_chdir ] job -> unit = "lwt_unix_chdir_free" + +let chdir name = + execute_job (chdir_job name) chdir_result chdir_free + +#endif + +#if windows + +let chroot name = + return (Unix.chroot name) + +#else + +external chroot_job : string -> [ `unix_chroot ] job = "lwt_unix_chroot_job" +external chroot_result : [ `unix_chroot ] job -> unit = "lwt_unix_chroot_result" +external chroot_free : [ `unix_chroot ] job -> unit = "lwt_unix_chroot_free" + +let chroot name = + execute_job (chroot_job name) chroot_result chroot_free + +#endif + +type dir_handle = Unix.dir_handle + +#if windows + +let opendir name = + return (Unix.opendir name) + +#else + +external opendir_job : string -> [ `unix_opendir ] job = "lwt_unix_opendir_job" +external opendir_result : [ `unix_opendir ] job -> Unix.dir_handle = "lwt_unix_opendir_result" +external opendir_free : [ `unix_opendir ] job -> unit = "lwt_unix_opendir_free" + +let opendir name = + execute_job (opendir_job name) opendir_result opendir_free + +#endif + +#if windows + +let readdir handle = + return (Unix.readdir handle) + +#else + +external readdir_job : Unix.dir_handle -> [ `unix_readdir ] job = "lwt_unix_readdir_job" +external readdir_result : [ `unix_readdir ] job -> string = "lwt_unix_readdir_result" +external readdir_free : [ `unix_readdir ] job -> unit = "lwt_unix_readdir_free" + +let readdir handle = + execute_job (readdir_job handle) readdir_result readdir_free + +#endif + +#if windows + +let readdir_n handle count = + if count < 0 then + fail (Invalid_argument "Lwt_uinx.readdir_n") + else + let array = Array.make count "" in + let rec fill i = + if i = count then + return array + else + match try array.(i) <- Unix.readdir handle; true with End_of_file -> false with + | true -> + fill (i + 1) + | false -> + return (Array.sub array 0 i) + in + fill 0 + +#else + +external readdir_n_job : Unix.dir_handle -> int -> [ `unix_readdir_n ] job = "lwt_unix_readdir_n_job" +external readdir_n_result : [ `unix_readdir_n ] job -> string array = "lwt_unix_readdir_n_result" +external readdir_n_free : [ `unix_readdir_n ] job -> unit = "lwt_unix_readdir_n_free" + +let readdir_n handle count = + if count < 0 then + fail (Invalid_argument "Lwt_uinx.readdir_n") + else + execute_job (readdir_n_job handle count) readdir_n_result readdir_n_free + +#endif + +#if windows + +let rewinddir handle = + return (Unix.rewinddir handle) + +#else + +external rewinddir_job : Unix.dir_handle -> [ `unix_rewinddir ] job = "lwt_unix_rewinddir_job" +external rewinddir_result : [ `unix_rewinddir ] job -> unit = "lwt_unix_rewinddir_result" +external rewinddir_free : [ `unix_rewinddir ] job -> unit = "lwt_unix_rewinddir_free" + +let rewinddir handle = + execute_job (rewinddir_job handle) rewinddir_result rewinddir_free + +#endif + +#if windows + +let closedir handle = + return (Unix.closedir handle) + +#else + +external closedir_job : Unix.dir_handle -> [ `unix_closedir ] job = "lwt_unix_closedir_job" +external closedir_result : [ `unix_closedir ] job -> unit = "lwt_unix_closedir_result" +external closedir_free : [ `unix_closedir ] job -> unit = "lwt_unix_closedir_free" + +let closedir handle = + execute_job (closedir_job handle) closedir_result closedir_free + +#endif + +type list_directory_state = + | LDS_not_started + | LDS_listing of Unix.dir_handle + | LDS_done + +let cleanup_dir_handle state = + match !state with + | LDS_listing handle -> + ignore (closedir handle) + | LDS_not_started | LDS_done -> + () + +let files_of_directory path = + let state = ref LDS_not_started in + Lwt_stream.concat + (Lwt_stream.from + (fun () -> + match !state with + | LDS_not_started -> + lwt handle = opendir path in + lwt entries = + try_lwt + readdir_n handle 1024 + with exn -> + lwt () = closedir handle in + raise exn + in + if Array.length entries < 1024 then begin + state := LDS_done; + lwt () = closedir handle in + return (Some(Lwt_stream.of_array entries)) + end else begin + state := LDS_listing handle; + Gc.finalise cleanup_dir_handle state; + return (Some(Lwt_stream.of_array entries)) + end + | LDS_listing handle -> + lwt entries = + try_lwt + readdir_n handle 1024 + with exn -> + lwt () = closedir handle in + raise exn + in + if Array.length entries < 1024 then begin + state := LDS_done; + lwt () = closedir handle in + return (Some(Lwt_stream.of_array entries)) + end else + return (Some(Lwt_stream.of_array entries)) + | LDS_done -> + return None)) + +(* +-----------------------------------------------------------------+ + | Pipes and redirections | + +-----------------------------------------------------------------+ *) + +let pipe () = + let (out_fd, in_fd) = Unix.pipe() in + (mk_ch ~blocking:Lwt_sys.windows out_fd, mk_ch ~blocking:Lwt_sys.windows in_fd) + +let pipe_in () = + let (out_fd, in_fd) = Unix.pipe() in + (mk_ch ~blocking:Lwt_sys.windows out_fd, in_fd) + +let pipe_out () = + let (out_fd, in_fd) = Unix.pipe() in + (out_fd, mk_ch ~blocking:Lwt_sys.windows in_fd) + +#if windows + +let mkfifo name perms = + return (Unix.mkfifo name perms) + +#else + +external mkfifo_job : string -> Unix.file_perm -> [ `unix_mkfifo ] job = "lwt_unix_mkfifo_job" +external mkfifo_result : [ `unix_mkfifo ] job -> unit = "lwt_unix_mkfifo_result" +external mkfifo_free : [ `unix_mkfifo ] job -> unit = "lwt_unix_mkfifo_free" + +let mkfifo name perms = + execute_job (mkfifo_job name perms) mkfifo_result mkfifo_free + +#endif + +(* +-----------------------------------------------------------------+ + | Symbolic links | + +-----------------------------------------------------------------+ *) + +#if windows + +let symlink name1 name2 = + return (Unix.symlink name1 name2) + +#else + +external symlink_job : string -> string -> [ `unix_symlink ] job = "lwt_unix_symlink_job" +external symlink_result : [ `unix_symlink ] job -> unit = "lwt_unix_symlink_result" +external symlink_free : [ `unix_symlink ] job -> unit = "lwt_unix_symlink_free" + +let symlink name1 name2 = + execute_job (symlink_job name1 name2) symlink_result symlink_free + +#endif + +#if windows + +let readlink name = + return (Unix.readlink name) + +#else + +external readlink_job : string -> [ `unix_readlink ] job = "lwt_unix_readlink_job" +external readlink_result : [ `unix_readlink ] job -> string = "lwt_unix_readlink_result" +external readlink_free : [ `unix_readlink ] job -> unit = "lwt_unix_readlink_free" + +let readlink name = + execute_job (readlink_job name) readlink_result readlink_free + +#endif + +(* +-----------------------------------------------------------------+ + | Locking | + +-----------------------------------------------------------------+ *) + +type lock_command = + Unix.lock_command = + | F_ULOCK + | F_LOCK + | F_TLOCK + | F_TEST + | F_RLOCK + | F_TRLOCK + +#if windows + +let lockf ch cmd size = + check_descriptor ch; + return (Unix.lockf ch.fd cmd size) + +#else + +external lockf_job : Unix.file_descr -> Unix.lock_command -> int -> [ `unix_lockf ] job = "lwt_unix_lockf_job" +external lockf_result : [ `unix_lockf ] job -> unit = "lwt_unix_lockf_result" +external lockf_free : [ `unix_lockf ] job -> unit = "lwt_unix_lockf_free" + +let lockf ch cmd size = + check_descriptor ch; + execute_job (lockf_job ch.fd cmd size) lockf_result lockf_free + +#endif + +(* +-----------------------------------------------------------------+ + | User id, group id | + +-----------------------------------------------------------------+ *) + +type passwd_entry = + Unix.passwd_entry = + { + pw_name : string; + pw_passwd : string; + pw_uid : int; + pw_gid : int; + pw_gecos : string; + pw_dir : string; + pw_shell : string + } + +type group_entry = + Unix.group_entry = + { + gr_name : string; + gr_passwd : string; + gr_gid : int; + gr_mem : string array + } + +#if windows + +let getlogin () = + return (Unix.getlogin ()) + +#else + +external getlogin_job : unit -> [ `unix_getlogin ] job = "lwt_unix_getlogin_job" +external getlogin_result : [ `unix_getlogin ] job -> string = "lwt_unix_getlogin_result" +external getlogin_free : [ `unix_getlogin ] job -> unit = "lwt_unix_getlogin_free" + +let getlogin () = + execute_job (getlogin_job ()) getlogin_result getlogin_free + +#endif + +#if windows + +let getpwnam name = + return (Unix.getpwnam name) + +#else + +external getpwnam_job : string -> [ `unix_getpwnam ] job = "lwt_unix_getpwnam_job" +external getpwnam_result : [ `unix_getpwnam ] job -> Unix.passwd_entry = "lwt_unix_getpwnam_result" +external getpwnam_free : [ `unix_getpwnam ] job -> unit = "lwt_unix_getpwnam_free" + +let getpwnam name = + execute_job (getpwnam_job name) getpwnam_result getpwnam_free + +#endif + +#if windows + +let getgrnam name = + return (Unix.getgrnam name) + +#else + +external getgrnam_job : string -> [ `unix_getgrnam ] job = "lwt_unix_getgrnam_job" +external getgrnam_result : [ `unix_getgrnam ] job -> Unix.group_entry = "lwt_unix_getgrnam_result" +external getgrnam_free : [ `unix_getgrnam ] job -> unit = "lwt_unix_getgrnam_free" + +let getgrnam name = + execute_job (getgrnam_job name) getgrnam_result getgrnam_free + +#endif + +#if windows + +let getpwuid uid = + return (Unix.getpwuid uid) + +#else + +external getpwuid_job : int -> [ `unix_getpwuid ] job = "lwt_unix_getpwuid_job" +external getpwuid_result : [ `unix_getpwuid ] job -> Unix.passwd_entry = "lwt_unix_getpwuid_result" +external getpwuid_free : [ `unix_getpwuid ] job -> unit = "lwt_unix_getpwuid_free" + +let getpwuid uid = + execute_job (getpwuid_job uid) getpwuid_result getpwuid_free + +#endif + +#if windows + +let getgrgid gid = + return (Unix.getgrgid gid) + +#else + +external getgrgid_job : int -> [ `unix_getgrgid ] job = "lwt_unix_getgrgid_job" +external getgrgid_result : [ `unix_getgrgid ] job -> Unix.group_entry = "lwt_unix_getgrgid_result" +external getgrgid_free : [ `unix_getgrgid ] job -> unit = "lwt_unix_getgrgid_free" + +let getgrgid gid = + execute_job (getgrgid_job gid) getgrgid_result getgrgid_free + +#endif + +(* +-----------------------------------------------------------------+ + | Sockets | + +-----------------------------------------------------------------+ *) + +type msg_flag = + Unix.msg_flag = + | MSG_OOB + | MSG_DONTROUTE + | MSG_PEEK + +#if windows +let stub_recv = Unix.recv +#else +external stub_recv : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_recv" +#endif + +let recv ch buf pos len flags = + if pos < 0 || len < 0 || pos > String.length buf - len then + invalid_arg "Lwt_unix.recv" + else + wrap_syscall Read ch (fun () -> stub_recv ch.fd buf pos len flags) + +#if windows +let stub_send = Unix.send +#else +external stub_send : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_send" +#endif + +let send ch buf pos len flags = + if pos < 0 || len < 0 || pos > String.length buf - len then + invalid_arg "Lwt_unix.send" + else + wrap_syscall Write ch (fun () -> stub_send ch.fd buf pos len flags) + +#if windows +let stub_recvfrom = Unix.recvfrom +#else +external stub_recvfrom : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr = "lwt_unix_recvfrom" +#endif + +let recvfrom ch buf pos len flags = + if pos < 0 || len < 0 || pos > String.length buf - len then + invalid_arg "Lwt_unix.recvfrom" + else + wrap_syscall Read ch (fun () -> stub_recvfrom ch.fd buf pos len flags) + +#if windows +let stub_sendto = Unix.sendto +#else +external stub_sendto : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int = "lwt_unix_sendto_byte" "lwt_unix_sendto" +#endif + +let sendto ch buf pos len flags addr = + if pos < 0 || len < 0 || pos > String.length buf - len then + invalid_arg "Lwt_unix.sendto" + else + wrap_syscall Write ch (fun () -> stub_sendto ch.fd buf pos len flags addr) + +type io_vector = { + iov_buffer : string; + iov_offset : int; + iov_length : int; +} + +let io_vector ~buffer ~offset ~length = { + iov_buffer = buffer; + iov_offset = offset; + iov_length = length; +} + +let check_io_vectors func_name iovs = + List.iter (fun iov -> + if iov.iov_offset < 0 + || iov.iov_length < 0 + || iov.iov_offset > String.length iov.iov_buffer - iov.iov_length then + invalid_arg func_name) iovs + +#if windows + +let recv_msg ~socket ~io_vectors = + raise (Lwt_sys.Not_available "recv_msg") + +#else + +external stub_recv_msg : Unix.file_descr -> int -> io_vector list -> int * Unix.file_descr list = "lwt_unix_recv_msg" + +let recv_msg ~socket ~io_vectors = + check_io_vectors "Lwt_unix.recv_msg" io_vectors; + let n_iovs = List.length io_vectors in + wrap_syscall Read socket + (fun () -> + stub_recv_msg socket.fd n_iovs io_vectors) + +#endif + +#if windows + +let send_msg ~socket ~io_vectors ~fds = + raise (Lwt_sys.Not_available "send_msg") + +#else + +external stub_send_msg : Unix.file_descr -> int -> io_vector list -> int -> Unix.file_descr list -> int = "lwt_unix_send_msg" + +let send_msg ~socket ~io_vectors ~fds = + check_io_vectors "Lwt_unix.send_msg" io_vectors; + let n_iovs = List.length io_vectors and n_fds = List.length fds in + wrap_syscall Write socket + (fun () -> + stub_send_msg socket.fd n_iovs io_vectors n_fds fds) + +#endif + +type inet_addr = Unix.inet_addr + +type socket_domain = + Unix.socket_domain = + | PF_UNIX + | PF_INET + | PF_INET6 + +type socket_type = + Unix.socket_type = + | SOCK_STREAM + | SOCK_DGRAM + | SOCK_RAW + | SOCK_SEQPACKET + +type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int + +let socket dom typ proto = + let s = Unix.socket dom typ proto in + mk_ch ~blocking:false s + +type shutdown_command = + Unix.shutdown_command = + | SHUTDOWN_RECEIVE + | SHUTDOWN_SEND + | SHUTDOWN_ALL + +let shutdown ch shutdown_command = + check_descriptor ch; + Unix.shutdown ch.fd shutdown_command + +let socketpair dom typ proto = + let (s1, s2) = Unix.socketpair dom typ proto in + (mk_ch ~blocking:false s1, mk_ch ~blocking:false s2) + +let accept ch = + wrap_syscall Read ch (fun _ -> let (fd, addr) = Unix.accept ch.fd in (mk_ch ~blocking:false fd, addr)) + +let accept_n ch n = + let l = ref [] in + lwt blocking = Lazy.force ch.blocking in + try_lwt + wrap_syscall Read ch begin fun () -> + begin + try + for i = 1 to n do + if blocking && not (stub_readable ch.fd) then raise Retry; + let fd, addr = Unix.accept ch.fd in + l := (mk_ch ~blocking:false fd, addr) :: !l + done + with + | (Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) | Retry) when !l <> [] -> + (* Ignore blocking errors if we have at least one file-descriptor: *) + () + end; + (List.rev !l, None) + end + with exn -> + return (List.rev !l, Some exn) + +#if windows + +let connect ch addr = + (* [in_progress] tell wether connection has started but not + terminated: *) + let in_progress = ref false in + wrap_syscall Write ch begin fun () -> + if !in_progress then + (* Nothing works without this test and i have no idea why... *) + if writable ch then + try + Unix.connect ch.fd addr + with + | Unix.Unix_error (Unix.EISCONN, _, _) -> + (* This is the windows way of telling that the connection + has completed. *) + () + else + raise Retry + else + try + Unix.connect ch.fd addr + with + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> + in_progress := true; + raise Retry + end + +#else + +let connect ch addr = + (* [in_progress] tell wether connection has started but not + terminated: *) + let in_progress = ref false in + wrap_syscall Write ch begin fun () -> + if !in_progress then + (* If the connection is in progress, [getsockopt_error] tells + wether it succceed: *) + match Unix.getsockopt_error ch.fd with + | None -> + (* The socket is connected *) + () + | Some err -> + (* An error happened: *) + raise (Unix.Unix_error(err, "connect", "")) + else + try + (* We should pass only one time here, unless the system call + is interrupted by a signal: *) + Unix.connect ch.fd addr + with + | Unix.Unix_error (Unix.EINPROGRESS, _, _) -> + in_progress := true; + raise Retry + end + +#endif + +let setsockopt ch opt v = + check_descriptor ch; + Unix.setsockopt ch.fd opt v + +let bind ch addr = + check_descriptor ch; + Unix.bind ch.fd addr + +let listen ch cnt = + check_descriptor ch; + Unix.listen ch.fd cnt + +let getpeername ch = + check_descriptor ch; + Unix.getpeername ch.fd + +let getsockname ch = + check_descriptor ch; + Unix.getsockname ch.fd + +type credentials = { + cred_pid : int; + cred_uid : int; + cred_gid : int; +} + +#if HAVE_GET_CREDENTIALS + +external stub_get_credentials : Unix.file_descr -> credentials = "lwt_unix_get_credentials" + +let get_credentials ch = + check_descriptor ch; + stub_get_credentials ch.fd + +#else + +let get_credentials ch = + raise (Lwt_sys.Not_available "get_credentials") + +#endif + +(* +-----------------------------------------------------------------+ + | Socket options | + +-----------------------------------------------------------------+ *) + +type socket_bool_option = + Unix.socket_bool_option = + | SO_DEBUG + | SO_BROADCAST + | SO_REUSEADDR + | SO_KEEPALIVE + | SO_DONTROUTE + | SO_OOBINLINE + | SO_ACCEPTCONN + | TCP_NODELAY + | IPV6_ONLY + +type socket_int_option = + Unix.socket_int_option = + | SO_SNDBUF + | SO_RCVBUF + | SO_ERROR + | SO_TYPE + | SO_RCVLOWAT + | SO_SNDLOWAT + +type socket_optint_option = Unix.socket_optint_option = SO_LINGER + +type socket_float_option = + Unix.socket_float_option = + | SO_RCVTIMEO + | SO_SNDTIMEO + +let getsockopt ch opt = + check_descriptor ch; + Unix.getsockopt ch.fd opt + +let setsockopt ch opt x = + check_descriptor ch; + Unix.setsockopt ch.fd opt x + +let getsockopt_int ch opt = + check_descriptor ch; + Unix.getsockopt_int ch.fd opt + +let setsockopt_int ch opt x = + check_descriptor ch; + Unix.setsockopt_int ch.fd opt x + +let getsockopt_optint ch opt = + check_descriptor ch; + Unix.getsockopt_optint ch.fd opt + +let setsockopt_optint ch opt x = + check_descriptor ch; + Unix.setsockopt_optint ch.fd opt x + +let getsockopt_float ch opt = + check_descriptor ch; + Unix.getsockopt_float ch.fd opt + +let setsockopt_float ch opt x = + check_descriptor ch; + Unix.setsockopt_float ch.fd opt x + +let getsockopt_error ch = + check_descriptor ch; + Unix.getsockopt_error ch.fd + +(* +-----------------------------------------------------------------+ + | Host and protocol databases | + +-----------------------------------------------------------------+ *) + +type host_entry = + Unix.host_entry = + { + h_name : string; + h_aliases : string array; + h_addrtype : socket_domain; + h_addr_list : inet_addr array + } + +type protocol_entry = + Unix.protocol_entry = + { + p_name : string; + p_aliases : string array; + p_proto : int + } + +type service_entry = + Unix.service_entry = + { + s_name : string; + s_aliases : string array; + s_port : int; + s_proto : string + } + +#if windows + +let gethostname () = + return (Unix.gethostname ()) + +#else + +external gethostname_job : unit -> [ `unix_gethostname ] job = "lwt_unix_gethostname_job" +external gethostname_result : [ `unix_gethostname ] job -> string = "lwt_unix_gethostname_result" +external gethostname_free : [ `unix_gethostname ] job -> unit = "lwt_unix_gethostname_free" + +let gethostname () = + execute_job (gethostname_job ()) gethostname_result gethostname_free + +#endif + +#if windows + +let gethostbyname name = + return (Unix.gethostbyname name) + +#else + +external gethostbyname_job : string -> [ `unix_gethostbyname ] job = "lwt_unix_gethostbyname_job" +external gethostbyname_result : [ `unix_gethostbyname ] job -> Unix.host_entry = "lwt_unix_gethostbyname_result" +external gethostbyname_free : [ `unix_gethostbyname ] job -> unit = "lwt_unix_gethostbyname_free" + +let gethostbyname name = + execute_job (gethostbyname_job name) gethostbyname_result gethostbyname_free + +#endif + +#if windows + +let gethostbyaddr addr = + return (Unix.gethostbyaddr addr) + +#else + +external gethostbyaddr_job : Unix.inet_addr -> [ `unix_gethostbyaddr ] job = "lwt_unix_gethostbyaddr_job" +external gethostbyaddr_result : [ `unix_gethostbyaddr ] job -> Unix.host_entry = "lwt_unix_gethostbyaddr_result" +external gethostbyaddr_free : [ `unix_gethostbyaddr ] job -> unit = "lwt_unix_gethostbyaddr_free" + +let gethostbyaddr addr = + execute_job (gethostbyaddr_job addr) gethostbyaddr_result gethostbyaddr_free + +#endif + +#if windows + +let getprotobyname name = + return (Unix.getprotobyname name) + +#else + +external getprotobyname_job : string -> [ `unix_getprotobyname ] job = "lwt_unix_getprotobyname_job" +external getprotobyname_result : [ `unix_getprotobyname ] job -> Unix.protocol_entry = "lwt_unix_getprotobyname_result" +external getprotobyname_free : [ `unix_getprotobyname ] job -> unit = "lwt_unix_getprotobyname_free" + +let getprotobyname name = + execute_job (getprotobyname_job name) getprotobyname_result getprotobyname_free + +#endif + +#if windows + +let getprotobynumber number = + return (Unix.getprotobynumber number) + +#else + +external getprotobynumber_job : int -> [ `unix_getprotobynumber ] job = "lwt_unix_getprotobynumber_job" +external getprotobynumber_result : [ `unix_getprotobynumber ] job -> Unix.protocol_entry = "lwt_unix_getprotobynumber_result" +external getprotobynumber_free : [ `unix_getprotobynumber ] job -> unit = "lwt_unix_getprotobynumber_free" + +let getprotobynumber number = + execute_job (getprotobynumber_job number) getprotobynumber_result getprotobynumber_free + +#endif + +#if windows + +let getservbyname name x = + return (Unix.getservbyname name x) + +#else + +external getservbyname_job : string -> string -> [ `unix_getservbyname ] job = "lwt_unix_getservbyname_job" +external getservbyname_result : [ `unix_getservbyname ] job -> Unix.service_entry = "lwt_unix_getservbyname_result" +external getservbyname_free : [ `unix_getservbyname ] job -> unit = "lwt_unix_getservbyname_free" + +let getservbyname name x = + execute_job (getservbyname_job name x) getservbyname_result getservbyname_free + +#endif + +#if windows + +let getservbyport port x = + return (Unix.getservbyport port x) + +#else + +external getservbyport_job : int -> string -> [ `unix_getservbyport ] job = "lwt_unix_getservbyport_job" +external getservbyport_result : [ `unix_getservbyport ] job -> Unix.service_entry = "lwt_unix_getservbyport_result" +external getservbyport_free : [ `unix_getservbyport ] job -> unit = "lwt_unix_getservbyport_free" + +let getservbyport port x = + execute_job (getservbyport_job port x) getservbyport_result getservbyport_free + +#endif + +type addr_info = + Unix.addr_info = + { + ai_family : socket_domain; + ai_socktype : socket_type; + ai_protocol : int; + ai_addr : sockaddr; + ai_canonname : string; + } + +type getaddrinfo_option = + Unix.getaddrinfo_option = + | AI_FAMILY of socket_domain + | AI_SOCKTYPE of socket_type + | AI_PROTOCOL of int + | AI_NUMERICHOST + | AI_CANONNAME + | AI_PASSIVE + +#if windows + +let getaddrinfo host service opts = + return (Unix.getaddrinfo host service opts) + +#else + +external getaddrinfo_job : string -> string -> Unix.getaddrinfo_option list -> [ `unix_getaddrinfo ] job = "lwt_unix_getaddrinfo_job" +external getaddrinfo_result : [ `unix_getaddrinfo ] job -> Unix.addr_info list = "lwt_unix_getaddrinfo_result" +external getaddrinfo_free : [ `unix_getaddrinfo ] job -> unit = "lwt_unix_getaddrinfo_free" + +let getaddrinfo host service opts = + execute_job (getaddrinfo_job host service opts) getaddrinfo_result getaddrinfo_free + +#endif + +type name_info = + Unix.name_info = + { + ni_hostname : string; + ni_service : string; + } + +type getnameinfo_option = + Unix.getnameinfo_option = + | NI_NOFQDN + | NI_NUMERICHOST + | NI_NAMEREQD + | NI_NUMERICSERV + | NI_DGRAM + +#if windows + +let getnameinfo addr opts = + return (Unix.getnameinfo addr opts) + +#else + +external getnameinfo_job : Unix.sockaddr -> Unix.getnameinfo_option list -> [ `unix_getnameinfo ] job = "lwt_unix_getnameinfo_job" +external getnameinfo_result : [ `unix_getnameinfo ] job -> Unix.name_info = "lwt_unix_getnameinfo_result" +external getnameinfo_free : [ `unix_getnameinfo ] job -> unit = "lwt_unix_getnameinfo_free" + +let getnameinfo addr opts = + execute_job (getnameinfo_job addr opts) getnameinfo_result getnameinfo_free + +#endif + +(* +-----------------------------------------------------------------+ + | Terminal interface | + +-----------------------------------------------------------------+ *) + + +type terminal_io = + Unix.terminal_io = + { + mutable c_ignbrk : bool; + mutable c_brkint : bool; + mutable c_ignpar : bool; + mutable c_parmrk : bool; + mutable c_inpck : bool; + mutable c_istrip : bool; + mutable c_inlcr : bool; + mutable c_igncr : bool; + mutable c_icrnl : bool; + mutable c_ixon : bool; + mutable c_ixoff : bool; + mutable c_opost : bool; + mutable c_obaud : int; + mutable c_ibaud : int; + mutable c_csize : int; + mutable c_cstopb : int; + mutable c_cread : bool; + mutable c_parenb : bool; + mutable c_parodd : bool; + mutable c_hupcl : bool; + mutable c_clocal : bool; + mutable c_isig : bool; + mutable c_icanon : bool; + mutable c_noflsh : bool; + mutable c_echo : bool; + mutable c_echoe : bool; + mutable c_echok : bool; + mutable c_echonl : bool; + mutable c_vintr : char; + mutable c_vquit : char; + mutable c_verase : char; + mutable c_vkill : char; + mutable c_veof : char; + mutable c_veol : char; + mutable c_vmin : int; + mutable c_vtime : int; + mutable c_vstart : char; + mutable c_vstop : char; + } + +type setattr_when = + Unix.setattr_when = + | TCSANOW + | TCSADRAIN + | TCSAFLUSH + +type flush_queue = + Unix.flush_queue = + | TCIFLUSH + | TCOFLUSH + | TCIOFLUSH + +type flow_action = + Unix.flow_action = + | TCOOFF + | TCOON + | TCIOFF + | TCION + +#if windows + +let tcgetattr ch = + check_descriptor ch; + return (Unix.tcgetattr ch.fd) + +#else + +external tcgetattr_job : Unix.file_descr -> [ `unix_tcgetattr ] job = "lwt_unix_tcgetattr_job" +external tcgetattr_result : [ `unix_tcgetattr ] job -> Unix.terminal_io = "lwt_unix_tcgetattr_result" +external tcgetattr_free : [ `unix_tcgetattr ] job -> unit = "lwt_unix_tcgetattr_free" + +let tcgetattr ch = + check_descriptor ch; + execute_job (tcgetattr_job ch.fd) tcgetattr_result tcgetattr_free + +#endif + +#if windows + +let tcsetattr ch when_ attrs = + check_descriptor ch; + return (Unix.tcsetattr ch.fd when_ attrs) + +#else + +external tcsetattr_job : Unix.file_descr -> Unix.setattr_when -> Unix.terminal_io -> [ `unix_tcsetattr ] job = "lwt_unix_tcsetattr_job" +external tcsetattr_result : [ `unix_tcsetattr ] job -> unit = "lwt_unix_tcsetattr_result" +external tcsetattr_free : [ `unix_tcsetattr ] job -> unit = "lwt_unix_tcsetattr_free" + +let tcsetattr ch when_ attrs = + check_descriptor ch; + execute_job (tcsetattr_job ch.fd when_ attrs) tcsetattr_result tcsetattr_free + +#endif + +#if windows + +let tcsendbreak ch delay = + check_descriptor ch; + return (Unix.tcsendbreak ch.fd delay) + +#else + +external tcsendbreak_job : Unix.file_descr -> int -> [ `unix_tcsendbreak ] job = "lwt_unix_tcsendbreak_job" +external tcsendbreak_result : [ `unix_tcsendbreak ] job -> unit = "lwt_unix_tcsendbreak_result" +external tcsendbreak_free : [ `unix_tcsendbreak ] job -> unit = "lwt_unix_tcsendbreak_free" + +let tcsendbreak ch delay = + check_descriptor ch; + execute_job (tcsendbreak_job ch.fd delay) tcsendbreak_result tcsendbreak_free + +#endif + +#if windows + +let tcdrain ch = + check_descriptor ch; + return (Unix.tcdrain ch.fd) + +#else + +external tcdrain_job : Unix.file_descr -> [ `unix_tcdrain ] job = "lwt_unix_tcdrain_job" +external tcdrain_result : [ `unix_tcdrain ] job -> unit = "lwt_unix_tcdrain_result" +external tcdrain_free : [ `unix_tcdrain ] job -> unit = "lwt_unix_tcdrain_free" + +let tcdrain ch = + check_descriptor ch; + execute_job (tcdrain_job ch.fd) tcdrain_result tcdrain_free + +#endif + +#if windows + +let tcflush ch q = + check_descriptor ch; + return (Unix.tcflush ch.fd q) + +#else + +external tcflush_job : Unix.file_descr -> Unix.flush_queue -> [ `unix_tcflush ] job = "lwt_unix_tcflush_job" +external tcflush_result : [ `unix_tcflush ] job -> unit = "lwt_unix_tcflush_result" +external tcflush_free : [ `unix_tcflush ] job -> unit = "lwt_unix_tcflush_free" + +let tcflush ch q = + check_descriptor ch; + execute_job (tcflush_job ch.fd q) tcflush_result tcflush_free + +#endif + +#if windows + +let tcflow ch act = + check_descriptor ch; + return (Unix.tcflow ch.fd act) + +#else + +external tcflow_job : Unix.file_descr -> Unix.flow_action -> [ `unix_tcflow ] job = "lwt_unix_tcflow_job" +external tcflow_result : [ `unix_tcflow ] job -> unit = "lwt_unix_tcflow_result" +external tcflow_free : [ `unix_tcflow ] job -> unit = "lwt_unix_tcflow_free" + +let tcflow ch act = + check_descriptor ch; + execute_job (tcflow_job ch.fd act) tcflow_result tcflow_free + +#endif + +(* +-----------------------------------------------------------------+ + | Reading notifications | + +-----------------------------------------------------------------+ *) + +(* Buffer used to receive notifications: *) +let notification_buffer = String.create 4 + +external init_notification : unit -> Unix.file_descr = "lwt_unix_init_notification" +external send_notification : int -> unit = "lwt_unix_send_notification_stub" +external recv_notifications : unit -> int array = "lwt_unix_recv_notifications" + +let handle_notification id = + match try Some(Notifiers.find notifiers id) with Not_found -> None with + | Some notifier -> + if notifier.notify_once then + stop_notification id; + notifier.notify_handler () + | None -> + () + +let rec handle_notifications ev = + (* Process available notifications. *) + Array.iter handle_notification (recv_notifications ()) + +let event_notifications = ref (Lwt_engine.on_readable (init_notification ()) handle_notifications) + +(* +-----------------------------------------------------------------+ + | Signals | + +-----------------------------------------------------------------+ *) + +module Signal_map = Map.Make(struct type t = int let compare a b = a - b end) + +let signals = ref Signal_map.empty +let signal_count () = + Signal_map.fold + (fun signum (id, actions) len -> len + Lwt_sequence.length actions) + !signals + 0 + +type signal_handler_id = unit Lazy.t + +let on_signal signum handler = + let notification, actions = + try + Signal_map.find signum !signals + with Not_found -> + let actions = Lwt_sequence.create () in + let notification = make_notification (fun () -> Lwt_sequence.iter_l (fun f -> f signum) actions) in + (try + Sys.set_signal signum (Sys.Signal_handle (fun signum -> send_notification notification)) + with exn -> + stop_notification notification; + raise exn); + signals := Signal_map.add signum (notification, actions) !signals; + (notification, actions) + in + let node = Lwt_sequence.add_r handler actions in + lazy(Lwt_sequence.remove node; + if Lwt_sequence.is_empty actions then begin + signals := Signal_map.remove signum !signals; + stop_notification notification; + Sys.set_signal signum Sys.Signal_default + end) + +let disable_signal_handler = Lazy.force + +let reinstall_signal_handler signum = + match try Some (Signal_map.find signum !signals) with Not_found -> None with + | Some (notification, actions) -> + Sys.set_signal signum (Sys.Signal_handle (fun signum -> send_notification notification)) + | None -> + () + +(* +-----------------------------------------------------------------+ + | Processes | + +-----------------------------------------------------------------+ *) + +external reset_after_fork : unit -> unit = "lwt_unix_reset_after_fork" + +let fork () = + match Unix.fork () with + | 0 -> + (* Reset threading. *) + reset_after_fork (); + (* Stop the old event for notifications. *) + Lwt_engine.stop_event !event_notifications; + (* Reinitialise the notification system. *) + event_notifications := Lwt_engine.on_readable (init_notification ()) handle_notifications; + (* Collect all pending jobs. *) + let l = Lwt_sequence.fold_l (fun w l -> w :: l) jobs [] in + (* Remove them all. *) + Lwt_sequence.iter_node_l Lwt_sequence.remove jobs; + (* And cancel them all. We yield first so that if the program + do an exec just after, it won't be executed. *) + on_termination (Lwt_main.yield ()) (fun () -> List.iter cancel l); + 0 + | pid -> + pid + +type process_status = + Unix.process_status = + | WEXITED of int + | WSIGNALED of int + | WSTOPPED of int + +type wait_flag = + Unix.wait_flag = + | WNOHANG + | WUNTRACED + +let has_wait4 = not Lwt_sys.windows + +type resource_usage = { ru_utime : float; ru_stime : float } + +#if windows + +let stub_wait4 flags pid = + let pid, status = Unix.waitpid flags pid in + (pid, status, { ru_utime = 0.0; ru_stime = 0.0 }) + +#else + +external stub_wait4 : Unix.wait_flag list -> int -> int * Unix.process_status * resource_usage = "lwt_unix_wait4" + +#endif + +let wait_children = Lwt_sequence.create () +let wait_count () = Lwt_sequence.length wait_children + +#if not windows +let () = + ignore begin + on_signal Sys.sigchld + (fun _ -> + Lwt_sequence.iter_node_l begin fun node -> + let wakener, flags, pid = Lwt_sequence.get node in + try + let (pid', _, _) as v = stub_wait4 flags pid in + if pid' <> 0 then begin + Lwt_sequence.remove node; + Lwt.wakeup wakener v + end + with e -> + Lwt_sequence.remove node; + Lwt.wakeup_exn wakener e + end wait_children) + end +#endif + +let _waitpid flags pid = + try_lwt + return (Unix.waitpid flags pid) + +#if windows + +let waitpid = _waitpid + +#else + +let waitpid flags pid = + if List.mem Unix.WNOHANG flags then + _waitpid flags pid + else + let flags = Unix.WNOHANG :: flags in + lwt ((pid', _) as res) = _waitpid flags pid in + if pid' <> 0 then + return res + else begin + let (res, w) = Lwt.task () in + let node = Lwt_sequence.add_l (w, flags, pid) wait_children in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + lwt (pid, status, _) = res in + return (pid, status) + end + +#endif + +let _wait4 flags pid = + try_lwt + return (stub_wait4 flags pid) + +#if windows + +let wait4 = _wait4 + +#else + +let wait4 flags pid = + if List.mem Unix.WNOHANG flags then + _wait4 flags pid + else + let flags = Unix.WNOHANG :: flags in + lwt (pid', _, _) as res = _wait4 flags pid in + if pid' <> 0 then + return res + else begin + let (res, w) = Lwt.task () in + let node = Lwt_sequence.add_l (w, flags, pid) wait_children in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + res + end + +#endif + +let wait () = waitpid [] (-1) + +let system cmd = + match Unix.fork () with + | 0 -> + begin try + Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] + with _ -> + exit 127 + end + | id -> + waitpid [] id >|= snd + +(* +-----------------------------------------------------------------+ + | Misc | + +-----------------------------------------------------------------+ *) + +let run = Lwt_main.run + +let handle_unix_error f x = + try_lwt + f x + with exn -> + Unix.handle_unix_error (fun () -> raise exn) () + +(* +-----------------------------------------------------------------+ + | System thread pool | + +-----------------------------------------------------------------+ *) + +external pool_size : unit -> int = "lwt_unix_pool_size" "noalloc" +external set_pool_size : int -> unit = "lwt_unix_set_pool_size" "noalloc" +external thread_count : unit -> int = "lwt_unix_thread_count" "noalloc" +external thread_waiting_count : unit -> int = "lwt_unix_thread_waiting_count" "noalloc" + +(* +-----------------------------------------------------------------+ + | CPUs | + +-----------------------------------------------------------------+ *) + +#if HAVE_GETCPU +external get_cpu : unit -> int = "lwt_unix_get_cpu" +#else +let get_cpu () = raise (Lwt_sys.Not_available "get_cpu") +#endif + +#if HAVE_AFFINITY + +external stub_get_affinity : int -> int list = "lwt_unix_get_affinity" +external stub_set_affinity : int -> int list -> unit = "lwt_unix_set_affinity" + +let get_affinity ?(pid=0) () = stub_get_affinity pid +let set_affinity ?(pid=0) l = stub_set_affinity pid l + +#else + +let get_affinity ?pid () = raise (Lwt_sys.Not_available "get_affinity") +let set_affinity ?pid l = raise (Lwt_sys.Not_available "set_affinity") + +#endif + +(* +-----------------------------------------------------------------+ + | Error printing | + +-----------------------------------------------------------------+ *) + +let () = + Printexc.register_printer + (function + | Unix.Unix_error(error, func, arg) -> + let error = + match error with + | Unix.E2BIG -> "E2BIG" + | Unix.EACCES -> "EACCES" + | Unix.EAGAIN -> "EAGAIN" + | Unix.EBADF -> "EBADF" + | Unix.EBUSY -> "EBUSY" + | Unix.ECHILD -> "ECHILD" + | Unix.EDEADLK -> "EDEADLK" + | Unix.EDOM -> "EDOM" + | Unix.EEXIST -> "EEXIST" + | Unix.EFAULT -> "EFAULT" + | Unix.EFBIG -> "EFBIG" + | Unix.EINTR -> "EINTR" + | Unix.EINVAL -> "EINVAL" + | Unix.EIO -> "EIO" + | Unix.EISDIR -> "EISDIR" + | Unix.EMFILE -> "EMFILE" + | Unix.EMLINK -> "EMLINK" + | Unix.ENAMETOOLONG -> "ENAMETOOLONG" + | Unix.ENFILE -> "ENFILE" + | Unix.ENODEV -> "ENODEV" + | Unix.ENOENT -> "ENOENT" + | Unix.ENOEXEC -> "ENOEXEC" + | Unix.ENOLCK -> "ENOLCK" + | Unix.ENOMEM -> "ENOMEM" + | Unix.ENOSPC -> "ENOSPC" + | Unix.ENOSYS -> "ENOSYS" + | Unix.ENOTDIR -> "ENOTDIR" + | Unix.ENOTEMPTY -> "ENOTEMPTY" + | Unix.ENOTTY -> "ENOTTY" + | Unix.ENXIO -> "ENXIO" + | Unix.EPERM -> "EPERM" + | Unix.EPIPE -> "EPIPE" + | Unix.ERANGE -> "ERANGE" + | Unix.EROFS -> "EROFS" + | Unix.ESPIPE -> "ESPIPE" + | Unix.ESRCH -> "ESRCH" + | Unix.EXDEV -> "EXDEV" + | Unix.EWOULDBLOCK -> "EWOULDBLOCK" + | Unix.EINPROGRESS -> "EINPROGRESS" + | Unix.EALREADY -> "EALREADY" + | Unix.ENOTSOCK -> "ENOTSOCK" + | Unix.EDESTADDRREQ -> "EDESTADDRREQ" + | Unix.EMSGSIZE -> "EMSGSIZE" + | Unix.EPROTOTYPE -> "EPROTOTYPE" + | Unix.ENOPROTOOPT -> "ENOPROTOOPT" + | Unix.EPROTONOSUPPORT -> "EPROTONOSUPPORT" + | Unix.ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT" + | Unix.EOPNOTSUPP -> "EOPNOTSUPP" + | Unix.EPFNOSUPPORT -> "EPFNOSUPPORT" + | Unix.EAFNOSUPPORT -> "EAFNOSUPPORT" + | Unix.EADDRINUSE -> "EADDRINUSE" + | Unix.EADDRNOTAVAIL -> "EADDRNOTAVAIL" + | Unix.ENETDOWN -> "ENETDOWN" + | Unix.ENETUNREACH -> "ENETUNREACH" + | Unix.ENETRESET -> "ENETRESET" + | Unix.ECONNABORTED -> "ECONNABORTED" + | Unix.ECONNRESET -> "ECONNRESET" + | Unix.ENOBUFS -> "ENOBUFS" + | Unix.EISCONN -> "EISCONN" + | Unix.ENOTCONN -> "ENOTCONN" + | Unix.ESHUTDOWN -> "ESHUTDOWN" + | Unix.ETOOMANYREFS -> "ETOOMANYREFS" + | Unix.ETIMEDOUT -> "ETIMEDOUT" + | Unix.ECONNREFUSED -> "ECONNREFUSED" + | Unix.EHOSTDOWN -> "EHOSTDOWN" + | Unix.EHOSTUNREACH -> "EHOSTUNREACH" + | Unix.ELOOP -> "ELOOP" + | Unix.EOVERFLOW -> "EOVERFLOW" + | Unix.EUNKNOWNERR n -> Printf.sprintf "EUNKNOWNERR %d" n + in + Some(Printf.sprintf "Unix.Unix_error(Unix.%s, %S, %S)" error func arg) + | _ -> + None) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_unix.mli b/thirdparty/lwt-2.3.2/src/unix/lwt_unix.mli new file mode 100644 index 0000000..b657e18 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_unix.mli @@ -0,0 +1,1131 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Lwt_unix + * Copyright (C) 2005-2008 Jrme Vouillon + * Laboratoire PPS - CNRS Universit Paris Diderot + * 2009 Jrmie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Cooperative system calls *) + +(** This modules redefine system calls, as in the [Unix] module of the + standard library, but mapped into cooperative ones, which will not + block the program, letting other threads run. + + The semantic of all operations is the following: if the action + (for example reading from a {b file descriptor}) can be performed + immediatly, it is done and returns immediatly, otherwise it + returns a sleeping threads which is waked up when the operation + completes. + + Moreover all sleeping threads returned by function of this modules + are {b cancelable}, this means that you can cancel them with + {!Lwt.cancel}. For example if you want to read something from a {b + file descriptor} with a timeout, you can cancel the action after + the timeout and the reading will not be performed if not already + done. + + More precisely, assuming that you have two {b file descriptor} + [fd1] and [fd2] and you want to read something from [fd1] or + exclusively from [fd2], and fail with an exception if a timeout of + 1 second expires, without reading anything from [fd1] and [fd2], + even if they become readable in the future. + + Then you can do: + + {[ + Lwt.pick [Lwt_unix.timeout 1.0; read fd1 buf1 ofs1 len1; read fd2 buf2 ofs2 len2] + ]} + + In this case it is guaranteed that exactly one of the three + operations will completes, and other will just be cancelled. +*) + +val handle_unix_error : ('a -> 'b Lwt.t) -> 'a -> 'b Lwt.t + (** Same as [Unix.handle_unix_error] but catches lwt-level + exceptions *) + +(** {6 Configuration} *) + +(** For system calls that cannot be made asynchronously, Lwt uses one + of the following method: *) +type async_method = + | Async_none + (** System calls are made synchronously, and may block the + entire program. *) + | Async_detach + (** System calls are made in another system thread, thus without + blocking other Lwt threads. The drawback is that it may + degrade performances in some cases. + + This is the default. *) + | Async_switch + (** System calls are made in the main thread, and if one blocks + the execution continue in another system thread. This method + is the most efficint, also you will get better performances + if you force all threads to run on the same cpu. On linux + this can be done by using the command [taskset]. + + Note that this method is still experimental. *) + +val default_async_method : unit -> async_method + (** Returns the default async method. + + This can be initialized using the environment variable + ["LWT_ASYNC_METHOD"] with possible values ["none"], + ["detach"] and ["switch"]. *) + +val set_default_async_method : async_method -> unit + (** Sets the default async method. *) + +val async_method : unit -> async_method + (** [async_method ()] returns the async method used in the current + thread. *) + +val async_method_key : async_method Lwt.key + (** The key for storing the local async method. *) + +val with_async_none : (unit -> 'a) -> 'a + (** [with_async_none f] is a shorthand for: + + {[ + Lwt.with_value async_method_key (Some Async_none) f + ]} + *) + +val with_async_detach : (unit -> 'a) -> 'a + (** [with_async_none f] is a shorthand for: + + {[ + Lwt.with_value async_method_key (Some Async_detach) f + ]} + *) + +val with_async_switch : (unit -> 'a) -> 'a + (** [with_async_none f] is a shorthand for: + + {[ + Lwt.with_value async_method_key (Some Async_switch) f + ]} + *) + +(** {6 Sleeping} *) + +val sleep : float -> unit Lwt.t + (** [sleep d] is a threads which remain suspended for [d] seconds + and then terminates. *) + +val yield : unit -> unit Lwt.t + (** [yield ()] is a threads which suspends itself and then resumes + as soon as possible and terminates. *) + +val auto_yield : float -> (unit -> unit Lwt.t) + (** [auto_yield timeout] returns a function [f] which will yield + every [timeout] seconds. *) + +exception Timeout + (** Exception raised by timeout operations *) + +val timeout : float -> 'a Lwt.t + (** [timeout d] is a threads which remain suspended for [d] seconds + then fail with {!Timeout} *) + +val with_timeout : float -> (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [with_timeout d f] is a short-hand for: + + {[ + Lwt.pick [Lwt_unix.timeout d; f ()] + ]} + *) + +(** {6 Operation on file-descriptors} *) + +type file_descr + (** The abstract type for {b file descriptor}s. A Lwt {b file + descriptor} is a pair of a unix {b file descriptor} (of type + [Unix.file_descr]) and a {b state}. + + A {b file descriptor} may be: + + - {b opened}, in which case it is fully usable + - {b closed} or {b aborted}, in which case it is no longer + usable *) + +(** State of a {b file descriptor} *) +type state = + | Opened + (** The {b file descriptor} is opened *) + | Closed + (** The {b file descriptor} has been closed by {!close}. It must + not be used for any operation. *) + | Aborted of exn + (** The {b file descriptor} has been aborted, the only operation + possible is {!close}, all others will fail. *) + +val state : file_descr -> state + (** [state fd] returns the state of [fd] *) + +val unix_file_descr : file_descr -> Unix.file_descr + (** Returns the underlying unix {b file descriptor}. It always + succeed, even if the {b file descriptor}'s state is not + {!Open}. *) + +val of_unix_file_descr : ?blocking : bool -> ?set_flags : bool -> Unix.file_descr -> file_descr + (** Creates a lwt {b file descriptor} from a unix one. + + [blocking] is the blocking mode of the file-descriptor, it + describe how Lwt will use it. In non-blocking mode, read/write + on this file descriptor are made using non-blocking IO; in + blocking mode they are made using the current async method. If + [blocking] is not specified it is guessed according to the file + kind: socket and pipes are in non-blocking mode and others are + in blocking mode. + + If [set_flags] is [true] (the default) then the file flags are + modified according to the [blocking] argument, otherwise they + are left unchanged. + + Note that the blocking mode is less efficient than the + non-blocking one, so it should be used only for file descriptors + that does not support asynchronous operations, such as regular + files, or for shared descriptors such as {!stdout}, {!stderr} or + {!stdin}. *) + +val blocking : file_descr -> bool Lwt.t + (** [blocking fd] returns whether [fd] is used in blocking or + non-blocking mode. *) + +val set_blocking : ?set_flags : bool -> file_descr -> bool -> unit + (** [set_blocking fd b] puts [fd] in blocking or non-blocking + mode. If [set_flags] is [true] (the default) then the file flags + are modified, otherwise the modification is only done at the + application level. *) + +val abort : file_descr -> exn -> unit + (** [abort fd exn] makes all current and further uses of the file + descriptor fail with the given exception. This put the {b file + descriptor} into the {!Aborted} state. + + If the {b file descrptor} is closed, this does nothing, if it is + aborted, this replace the abort exception by [exn]. + + Note that this only works for reading and writing operations on + file descriptors supporting non-blocking mode. *) + +(** {6 Process handling} *) + +val fork : unit -> int + (** [fork ()] does the same as [Unix.fork]. You must use this + function instead of [Unix.fork] when you want to use Lwt in the + child process. + + Notes: + - in the child process all pending jobs are canceled, + - if you are going to use Lwt in the parent and the child, it is + a good idea to call {!Lwt_io.flush_all} before callling + {!fork} to avoid double-flush. *) + +type process_status = + Unix.process_status = + | WEXITED of int + | WSIGNALED of int + | WSTOPPED of int + +type wait_flag = + Unix.wait_flag = + | WNOHANG + | WUNTRACED + +val wait : unit -> (int * process_status) Lwt.t + (** Wrapper for [Unix.wait] *) + +val waitpid : wait_flag list -> int -> (int * process_status) Lwt.t + (** Wrapper for [Unix.waitpid] *) + +(** Resource usages *) +type resource_usage = { + ru_utime : float; + (** User time used *) + + ru_stime : float; + (** System time used *) +} + +val wait4 : wait_flag list -> int -> (int * process_status * resource_usage) Lwt.t + (** [wait4 flags pid] returns [(pid, status, rusage)] where [(pid, + status)] is the same result as [Unix.waitpid flags pid], and + [rusage] contains accounting information about the child. + + On windows it will always returns [{ utime = 0.0; stime = 0.0 }]. *) + +val wait_count : unit -> int + (** Returns the number of threads waiting for a child to + terminate. *) + +val system : string -> process_status Lwt.t + (** Wrapper for [Unix.system] *) + +(** {6 Basic file input/output} *) + +val stdin : file_descr + (** The standard {b file descriptor} for input. This one is usually + a terminal is the program is started from a terminal. *) + +val stdout : file_descr + (** The standard {b file descriptor} for output *) + +val stderr : file_descr + (** The standard {b file descriptor} for printing error messages *) + +type file_perm = Unix.file_perm + +type open_flag = + Unix.open_flag = + | O_RDONLY + | O_WRONLY + | O_RDWR + | O_NONBLOCK + | O_APPEND + | O_CREAT + | O_TRUNC + | O_EXCL + | O_NOCTTY + | O_DSYNC + | O_SYNC + | O_RSYNC + +val openfile : string -> open_flag list -> file_perm -> file_descr Lwt.t + (** Wrapper for [Unix.openfile]. *) + +val close : file_descr -> unit Lwt.t + (** Close a {b file descriptor}. This close the underlying unix {b + file descriptor} and set its state to {!Closed} *) + +val read : file_descr -> string -> int -> int -> int Lwt.t + (** [read fd buf ofs len] has the same semantic as [Unix.read], but + is cooperative *) + +val write : file_descr -> string -> int -> int -> int Lwt.t + (** [read fd buf ofs len] has the same semantic as [Unix.write], but + is cooperative *) + +val readable : file_descr -> bool + (** Returns whether the given file descriptor is currently + readable. *) + +val writable : file_descr -> bool + (** Returns whether the given file descriptor is currently + writable. *) + +val wait_read : file_descr -> unit Lwt.t + (** waits (without blocking other threads) until there is something + to read on the file descriptor *) + +val wait_write : file_descr -> unit Lwt.t + (** waits (without blocking other threads) until it is possible to + write on the file descriptor *) + +(** {6 Seeking and truncating} *) + +type seek_command = + Unix.seek_command = + | SEEK_SET + | SEEK_CUR + | SEEK_END + +val lseek : file_descr -> int -> seek_command -> int Lwt.t + (** Wrapper for [Unix.lseek] *) + +val truncate : string -> int -> unit Lwt.t + (** Wrapper for [Unix.truncate] *) + +val ftruncate : file_descr -> int -> unit Lwt.t + (** Wrapper for [Unix.ftruncate] *) + +(** {6 Syncing} *) + +val fsync : file_descr -> unit Lwt.t + (** Synchronise all data and metadata of the file descriptor with + the disk. On Windows it uses [FlushFileBuffers]. *) + +val fdatasync : file_descr -> unit Lwt.t + (** Synchronise all data (but not metadata) of the file descriptor + with the disk. + + Note that [fdatasync] is not available on all platforms. *) + +(** {6 File status} *) + +type file_kind = + Unix.file_kind = + | S_REG + | S_DIR + | S_CHR + | S_BLK + | S_LNK + | S_FIFO + | S_SOCK + +type stats = + Unix.stats = + { + st_dev : int; + st_ino : int; + st_kind : file_kind; + st_perm : file_perm; + st_nlink : int; + st_uid : int; + st_gid : int; + st_rdev : int; + st_size : int; + st_atime : float; + st_mtime : float; + st_ctime : float; + } + +val stat : string -> stats Lwt.t + (** Wrapper for [Unix.stat] *) + +val lstat : string -> stats Lwt.t + (** Wrapper for [Unix.lstat] *) + +val fstat : file_descr -> stats Lwt.t + (** Wrapper for [Unix.fstat] *) + +val isatty : file_descr -> bool Lwt.t + (** Wrapper for [Unix.isatty] *) + +(** {6 File operations on large files} *) + +module LargeFile : sig + val lseek : file_descr -> int64 -> seek_command -> int64 Lwt.t + (** Wrapper for [Unix.LargeFile.lseek] *) + + val truncate : string -> int64 -> unit Lwt.t + (** Wrapper for [Unix.LargeFile.truncate] *) + + val ftruncate : file_descr -> int64 -> unit Lwt.t + (** Wrapper for [Unix.LargeFile.ftruncate] *) + + type stats = + Unix.LargeFile.stats = + { + st_dev : int; + st_ino : int; + st_kind : file_kind; + st_perm : file_perm; + st_nlink : int; + st_uid : int; + st_gid : int; + st_rdev : int; + st_size : int64; + st_atime : float; + st_mtime : float; + st_ctime : float; + } + + val stat : string -> stats Lwt.t + (** Wrapper for [Unix.LargeFile.stat] *) + + val lstat : string -> stats Lwt.t + (** Wrapper for [Unix.LargeFile.lstat] *) + + val fstat : file_descr -> stats Lwt.t + (** Wrapper for [Unix.LargeFile.fstat] *) +end + +(** {6 Operations on file names} *) + +val unlink : string -> unit Lwt.t + (** Wrapper for [Unix.unlink] *) + +val rename : string -> string -> unit Lwt.t + (** Wrapper for [Unix.rename] *) + +val link : string -> string -> unit Lwt.t + (** Wrapper for [Unix.link] *) + +(** {6 File permissions and ownership} *) + +val chmod : string -> file_perm -> unit Lwt.t + (** Wrapper for [Unix.chmod] *) + +val fchmod : file_descr -> file_perm -> unit Lwt.t + (** Wrapper for [Unix.fchmod] *) + +val chown : string -> int -> int -> unit Lwt.t + (** Wrapper for [Unix.chown] *) + +val fchown : file_descr -> int -> int -> unit Lwt.t + (** Wrapper for [Unix.fchown] *) + +type access_permission = + Unix.access_permission = + | R_OK + | W_OK + | X_OK + | F_OK + +val access : string -> access_permission list -> unit Lwt.t + (** Wrapper for [Unix.access] *) + +(** {6 Operations on file descriptors} *) + +val dup : file_descr -> file_descr + (** Wrapper for [Unix.dup] *) + +val dup2 : file_descr -> file_descr -> unit + (** Wrapper for [Unix.dup2] *) + +val set_close_on_exec : file_descr -> unit + (** Wrapper for [Unix.set_close_on_exec] *) + +val clear_close_on_exec : file_descr -> unit + (** Wrapper for [Unix.clear_close_on_exec] *) + +(** {6 Directories} *) + +val mkdir : string -> file_perm -> unit Lwt.t + (** Wrapper for [Unix.mkdir] *) + +val rmdir : string -> unit Lwt.t + (** Wrapper for [Unix.rmdir] *) + +val chdir : string -> unit Lwt.t + (** Wrapper for [Unix.chdir] *) + +val chroot : string -> unit Lwt.t + (** Wrapper for [Unix.chroot] *) + +type dir_handle = Unix.dir_handle + +val opendir : string -> dir_handle Lwt.t + (** Wrapper for [Unix.opendir] *) + +val readdir : dir_handle -> string Lwt.t + (** Wrapper for [Unix.dir] *) + +val readdir_n : dir_handle -> int -> string array Lwt.t + (** [readdir_n handle count] reads at most [count] entry from the + given directory. It is more efficient that callling [count] + times [readdir]. If the length of the returned array is smaller + than [count], this means that the end of the directory has been + reached. *) + +val rewinddir : dir_handle -> unit Lwt.t + (** Wrapper for [Unix.rewinddir] *) + +val closedir : dir_handle -> unit Lwt.t + (** Wrapper for [Unix.closedir] *) + +val files_of_directory : string -> string Lwt_stream.t + (** [files_of_directory dir] returns the stream of all files of + [dir]. *) + +(** {6 Pipes and redirections} *) + +val pipe : unit -> file_descr * file_descr + (** [pipe ()] creates pipe using [Unix.pipe] and returns two lwt {b + file descriptor}s created from unix {b file_descriptor} *) + +val pipe_in : unit -> file_descr * Unix.file_descr + (** [pipe_in ()] is the same as {!pipe} but maps only the unix {b + file descriptor} for reading into a lwt one. The second is not + put into non-blocking mode. You usually want to use this before + forking to receive data from the child process. *) + +val pipe_out : unit -> Unix.file_descr * file_descr + (** [pipe_out ()] is the inverse of {!pipe_in}. You usually want to + use this before forking to send data to the child process *) + +val mkfifo : string -> file_perm -> unit Lwt.t + (** Wrapper for [Unix.mkfifo] *) + +(** {6 Symbolic links} *) + +val symlink : string -> string -> unit Lwt.t + (** Wrapper for [Unix.symlink] *) + +val readlink : string -> string Lwt.t + (** Wrapper for [Unix.readlink] *) + +(** {6 Locking} *) + +type lock_command = + Unix.lock_command = + | F_ULOCK + | F_LOCK + | F_TLOCK + | F_TEST + | F_RLOCK + | F_TRLOCK + +val lockf : file_descr -> lock_command -> int -> unit Lwt.t + (** Wrapper for [Unix.lockf] *) + +(** {6 User id, group id} *) + +type passwd_entry = + Unix.passwd_entry = + { + pw_name : string; + pw_passwd : string; + pw_uid : int; + pw_gid : int; + pw_gecos : string; + pw_dir : string; + pw_shell : string + } + +type group_entry = + Unix.group_entry = + { + gr_name : string; + gr_passwd : string; + gr_gid : int; + gr_mem : string array + } + +val getlogin : unit -> string Lwt.t + (** Wrapper for [Unix.getlogin] *) + +val getpwnam : string -> passwd_entry Lwt.t + (** Wrapper for [Unix.getpwnam] *) + +val getgrnam : string -> group_entry Lwt.t + (** Wrapper for [Unix.getgrnam] *) + +val getpwuid : int -> passwd_entry Lwt.t + (** Wrapper for [Unix.getpwuid] *) + +val getgrgid : int -> group_entry Lwt.t + (** Wrapper for [Unix.getgrgid] *) + +(** {6 Signals} *) + +type signal_handler_id + (** Id of a signal handler, used to cancel it *) + +val on_signal : int -> (int -> unit) -> signal_handler_id + (** [on_signal signum f] calls [f] each time the signal with numnber + [signum] is received by the process. It returns a signal handler + identifier which can be used to stop monitoring [signum]. *) + +val disable_signal_handler : signal_handler_id -> unit + (** Stops receiving this signal *) + +val signal_count : unit -> int + (** Returns the number of registered signal handler. *) + +val reinstall_signal_handler : int -> unit + (** [reinstall_signal_handler signum] if any signal handler is + registered for this signal with {!on_signal}, it reinstall the + signal handler (with [Sys.set_signal]). This is usefull in case + another part of the program install another signal handler. *) + +(** {6 Sockets} *) + +type inet_addr = Unix.inet_addr + +type socket_domain = + Unix.socket_domain = + | PF_UNIX + | PF_INET + | PF_INET6 + +type socket_type = + Unix.socket_type = + | SOCK_STREAM + | SOCK_DGRAM + | SOCK_RAW + | SOCK_SEQPACKET + +type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int + +val socket : socket_domain -> socket_type -> int -> file_descr + (** [socket domain type proto] is the same as [Unix.socket] but maps + the result into a lwt {b file descriptor} *) + +val socketpair : socket_domain -> socket_type -> int -> file_descr * file_descr + (** Wrapper for [Unix.socketpair] *) + +val bind : file_descr -> sockaddr -> unit + (** Wrapper for [Unix.bind] *) + +val listen : file_descr -> int -> unit + (** Wrapper for [Unix.listen] *) + +val accept : file_descr -> (file_descr * sockaddr) Lwt.t + (** Wrapper for [Unix.accept] *) + +val accept_n : file_descr -> int -> ((file_descr * sockaddr) list * exn option) Lwt.t + (** [accept_n fd count] accepts up to [count] connection in one time. + + - if no connection is available right now, it returns a sleeping + thread + + - if more that 1 and less than [count] are available, it returns + all of them + + - if more that [count] are available, it returns the next + [count] of them + + - if an error happen, it returns the connections that have been + successfully accepted so far and the error + + [accept_n] has the advantage of improving performances. If you + want a more detailed description, you can have a look at: + + {{:http://portal.acm.org/citation.cfm?id=1247435}Acceptable strategies for improving web server performance} *) + +val connect : file_descr -> sockaddr -> unit Lwt.t + (** Wrapper for [Unix.connect] *) + +type shutdown_command = + Unix.shutdown_command = + | SHUTDOWN_RECEIVE + | SHUTDOWN_SEND + | SHUTDOWN_ALL + +val shutdown : file_descr -> shutdown_command -> unit + (** Wrapper for [Unix.shutdown] *) + +val getsockname : file_descr -> sockaddr + (** Wrapper for [Unix.getsockname] *) + +val getpeername : file_descr -> sockaddr + (** Wrapper for [Unix.getpeername] *) + +type msg_flag = + Unix.msg_flag = + | MSG_OOB + | MSG_DONTROUTE + | MSG_PEEK + +val recv : file_descr -> string -> int -> int -> msg_flag list -> int Lwt.t + (** Wrapper for [Unix.recv] *) + +val recvfrom : file_descr -> string -> int -> int -> msg_flag list -> (int * sockaddr) Lwt.t + (** Wrapper for [Unix.recvfrom] *) + +val send : file_descr -> string -> int -> int -> msg_flag list -> int Lwt.t + (** Wrapper for [Unix.send] *) + +val sendto : file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int Lwt.t + (** Wrapper for [Unix.sendto] *) + +(** An io-vector. Used by {!recv_msg} and {!send_msg}. *) +type io_vector = { + iov_buffer : string; + iov_offset : int; + iov_length : int; +} + +val io_vector : buffer : string -> offset : int -> length : int -> io_vector + (** Creates an io-vector *) + +val recv_msg : socket : file_descr -> io_vectors : io_vector list -> (int * Unix.file_descr list) Lwt.t + (** [recv_msg ~socket ~io_vectors] receives data into a list of + io-vectors, plus any file-descriptors that may accompany the + message. + + This call is not available on windows. *) + +val send_msg : socket : file_descr -> io_vectors : io_vector list -> fds : Unix.file_descr list -> int Lwt.t + (** [send_msg ~socket ~io_vectors ~fds] sends data from a list of + io-vectors, accompanied with a list of file-descriptor. If + fd-passing is not possible on the current system and [fds] is + not empty, it raises [Lwt_sys.Not_available "fd_passing"]. + + This call is not available on windows. *) + +type credentials = { + cred_pid : int; + cred_uid : int; + cred_gid : int; +} + +val get_credentials : file_descr -> credentials + (** [get_credentials fd] returns credential informations from the + given socket. *) + +(** {8 Socket options} *) + +type socket_bool_option = + Unix.socket_bool_option = + | SO_DEBUG + | SO_BROADCAST + | SO_REUSEADDR + | SO_KEEPALIVE + | SO_DONTROUTE + | SO_OOBINLINE + | SO_ACCEPTCONN + | TCP_NODELAY + | IPV6_ONLY + +type socket_int_option = + Unix.socket_int_option = + | SO_SNDBUF + | SO_RCVBUF + | SO_ERROR + | SO_TYPE + | SO_RCVLOWAT + | SO_SNDLOWAT + +type socket_optint_option = Unix.socket_optint_option = SO_LINGER + +type socket_float_option = + Unix.socket_float_option = + | SO_RCVTIMEO + | SO_SNDTIMEO + +val getsockopt : file_descr -> socket_bool_option -> bool + (** Wrapper for [Unix.getsockopt] *) + +val setsockopt : file_descr -> socket_bool_option -> bool -> unit + (** Wrapper for [Unix.setsockopt] *) + +val getsockopt_int : file_descr -> socket_int_option -> int + (** Wrapper for [Unix.getsockopt_int] *) + +val setsockopt_int : file_descr -> socket_int_option -> int -> unit + (** Wrapper for [Unix.setsockopt_int] *) + +val getsockopt_optint : file_descr -> socket_optint_option -> int option + (** Wrapper for [Unix.getsockopt_optint] *) + +val setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit + (** Wrapper for [Unix.setsockopt_optint] *) + +val getsockopt_float : file_descr -> socket_float_option -> float + (** Wrapper for [Unix.getsockopt_float] *) + +val setsockopt_float : file_descr -> socket_float_option -> float -> unit + (** Wrapper for [Unix.setsockopt_float] *) + +val getsockopt_error : file_descr -> Unix.error option + (** Wrapper for [Unix.getsockopt_error] *) + +(** {6 Host and protocol databases} *) + +type host_entry = + Unix.host_entry = + { + h_name : string; + h_aliases : string array; + h_addrtype : socket_domain; + h_addr_list : inet_addr array + } + +type protocol_entry = + Unix.protocol_entry = + { + p_name : string; + p_aliases : string array; + p_proto : int + } + +type service_entry = + Unix.service_entry = + { + s_name : string; + s_aliases : string array; + s_port : int; + s_proto : string + } + +val gethostname : unit -> string Lwt.t + (** Wrapper for [Unix.gethostname] *) + +val gethostbyname : string -> host_entry Lwt.t + (** Wrapper for [Unix.gethostbyname] *) + +val gethostbyaddr : inet_addr -> host_entry Lwt.t + (** Wrapper for [Unix.gethostbyaddr] *) + +val getprotobyname : string -> protocol_entry Lwt.t + (** Wrapper for [Unix.getprotobyname] *) + +val getprotobynumber : int -> protocol_entry Lwt.t + (** Wrapper for [Unix.getprotobynumber] *) + +val getservbyname : string -> string -> service_entry Lwt.t + (** Wrapper for [Unix.getservbyname] *) + +val getservbyport : int -> string -> service_entry Lwt.t + (** Wrapper for [Unix.getservbyport] *) + +type addr_info = + Unix.addr_info = + { + ai_family : socket_domain; + ai_socktype : socket_type; + ai_protocol : int; + ai_addr : sockaddr; + ai_canonname : string; + } + +type getaddrinfo_option = + Unix.getaddrinfo_option = + | AI_FAMILY of socket_domain + | AI_SOCKTYPE of socket_type + | AI_PROTOCOL of int + | AI_NUMERICHOST + | AI_CANONNAME + | AI_PASSIVE + +val getaddrinfo : string -> string -> getaddrinfo_option list -> addr_info list Lwt.t + (** Wrapper for [Unix.getaddrinfo] *) + +type name_info = + Unix.name_info = + { + ni_hostname : string; + ni_service : string; + } + +type getnameinfo_option = + Unix.getnameinfo_option = + | NI_NOFQDN + | NI_NUMERICHOST + | NI_NAMEREQD + | NI_NUMERICSERV + | NI_DGRAM + +val getnameinfo : sockaddr -> getnameinfo_option list -> name_info Lwt.t + (** Wrapper for [Unix.getnameinfo] *) + +(** {6 Terminal interface} *) + +type terminal_io = + Unix.terminal_io = + { + mutable c_ignbrk : bool; + mutable c_brkint : bool; + mutable c_ignpar : bool; + mutable c_parmrk : bool; + mutable c_inpck : bool; + mutable c_istrip : bool; + mutable c_inlcr : bool; + mutable c_igncr : bool; + mutable c_icrnl : bool; + mutable c_ixon : bool; + mutable c_ixoff : bool; + mutable c_opost : bool; + mutable c_obaud : int; + mutable c_ibaud : int; + mutable c_csize : int; + mutable c_cstopb : int; + mutable c_cread : bool; + mutable c_parenb : bool; + mutable c_parodd : bool; + mutable c_hupcl : bool; + mutable c_clocal : bool; + mutable c_isig : bool; + mutable c_icanon : bool; + mutable c_noflsh : bool; + mutable c_echo : bool; + mutable c_echoe : bool; + mutable c_echok : bool; + mutable c_echonl : bool; + mutable c_vintr : char; + mutable c_vquit : char; + mutable c_verase : char; + mutable c_vkill : char; + mutable c_veof : char; + mutable c_veol : char; + mutable c_vmin : int; + mutable c_vtime : int; + mutable c_vstart : char; + mutable c_vstop : char; + } + +val tcgetattr : file_descr -> terminal_io Lwt.t + (** Wrapper for [Unix.tcgetattr] *) + +type setattr_when = + Unix.setattr_when = + | TCSANOW + | TCSADRAIN + | TCSAFLUSH + +val tcsetattr : file_descr -> setattr_when -> terminal_io -> unit Lwt.t + (** Wrapper for [Unix.tcsetattr] *) + +val tcsendbreak : file_descr -> int -> unit Lwt.t + (** Wrapper for [Unix.tcsendbreak] *) + +val tcdrain : file_descr -> unit Lwt.t + (** Wrapper for [Unix.tcdrain] *) + +type flush_queue = + Unix.flush_queue = + | TCIFLUSH + | TCOFLUSH + | TCIOFLUSH + +val tcflush : file_descr -> flush_queue -> unit Lwt.t + (** Wrapper for [Unix.tcflush] *) + +type flow_action = + Unix.flow_action = + | TCOOFF + | TCOON + | TCIOFF + | TCION + +val tcflow : file_descr -> flow_action -> unit Lwt.t + (** Wrapper for [Unix.tcflow] *) + +(** {6 Low-level interaction} *) + +exception Retry + (** If an action raises {!Retry}, it will be requeued until the {b + file descriptor} becomes readable/writable again. *) + +exception Retry_read + (** If an action raises {!Retry_read}, it will be requeued until the + {b file descriptor} becomes readable. *) + +exception Retry_write + (** If an action raises {!Retry_read}, it will be requeued until the + {b file descriptor} becomes writables. *) + +type io_event = Read | Write + +val wrap_syscall : io_event -> file_descr -> (unit -> 'a) -> 'a Lwt.t + (** [wrap_syscall set fd action] wrap an action on a {b file + descriptor}. It tries to execture action, and if it can not be + performed immediately without blocking, it is registered for + latter. + + In the latter case, if the thread is canceled, [action] is + removed from [set]. *) + +val check_descriptor : file_descr -> unit + (** [check_descriptor fd] raise an exception if [fd] is not in the + state {!Open} *) + +val register_action : io_event -> file_descr -> (unit -> 'a) -> 'a Lwt.t + (** [register_action set fd action] registers [action] on [fd]. When + [fd] becomes [readable]/[writable] [action] is called. + + Note: + + - you must call [check_descriptor fd] before calling + [register_action] + + - you should prefer using {!wrap_syscall} + *) + +type 'a job + (** Type of jobs that run: + + - on another thread if the current async method is [Async_thread] + - on the main thread if the current async method is [Async_none]. *) + +val execute_job : + ?async_method : async_method -> + job : 'a job -> + result : ('a job -> 'b) -> + free : ('a job -> unit) -> 'b Lwt.t + (** [execute_job ?async_method ~job ~get ~free] starts + [job] and wait for its termination. + + [async_method] is how the job will be executed. It defaults to + the async method of the current thread. [result] is used to get + the result of the job, and [free] to free its associated + resources. *) + +val cancel_jobs : unit -> unit + (** [cancel_jobs ()] make all pending jobs to fail with + {!Lwt.Canceled}. *) + +val wait_for_jobs : unit -> unit Lwt.t + (** Wait for all pending jobs to terminate. *) + +(** {6 Notifications} *) + +(** Lwt internally use a pipe to send notification to the main + thread. The following functions allow to use this pipe. *) + +val make_notification : ?once : bool -> (unit -> unit) -> int + (** [new_notifier ?once f] registers a new notifier. It returns the + id of the notifier. Each time a notification with this id is + received, [f] is called. + + if [once] is specified, then the notification is stopped after + the first time it is received. It defaults to [false]. *) + +val send_notification : int -> unit + (** [send_notification id] sends a notification. + + This function is thread-safe. *) + +val stop_notification : int -> unit + (** Stop the given notification. Note that you should not reuse the + id after the notification has been stopped, the result is + unspecified if you do so. *) + +val set_notification : int -> (unit -> unit) -> unit + (** [set_notification id f] replace the function associated to the + notification by [f]. It raises [Not_found] if the given + notification is not found. *) + +(** {6 System threads pool} *) + +(** If the program is using the async method {!Async_detach} or + {!Async_switch}, Lwt will launch system threads to execute + blocking system calls asynchronously. *) + +val pool_size : unit -> int + (** Maximum number of system threads that can be started. If this + limit is reached, jobs will be executed synchronously. *) + +val set_pool_size : int -> unit + (** Change the size of the pool. *) + +val thread_count : unit -> int + (** The number of system threads running (excluding this one). *) + +val thread_waiting_count : unit -> int + (** The number threads waiting for a job. *) + +(** {6 CPUs} *) + +val get_cpu : unit -> int + (** [get_cpu ()] returns the number of the CPU the current thread is + running on. *) + +val get_affinity : ?pid : int -> unit -> int list + (** [get_affinity ?pid ()] returns the list of CPUs the process with + pid [pid] is allowed to run on. If [pid] is not specified then + the affinity of the current process is returned. *) + +val set_affinity : ?pid : int -> int list -> unit + (** [set_affinity ?pid cpus] sets the list of CPUs the given process + is allowed to run on. *) + +(**/**) + +val run : 'a Lwt.t -> 'a + (* Same as {!Lwt_main.run} *) + +val has_wait4 : bool + (* Deprecated, use [Lwt_sys.have `wait4]. *) diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_unix_stubs.c b/thirdparty/lwt-2.3.2/src/unix/lwt_unix_stubs.c new file mode 100644 index 0000000..7571649 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_unix_stubs.c @@ -0,0 +1,1377 @@ +/* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_unix_stubs + * Copyright (C) 2009-2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + */ + +#if defined(_WIN32) || defined(_WIN64) +# include +# include +#endif + +#define _GNU_SOURCE +#define _POSIX_PTHREAD_SEMANTICS + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +#include "lwt_config.h" +#include "lwt_unix.h" + +#if !defined(LWT_ON_WINDOWS) +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +# include +#endif + +#if defined(HAVE_EVENTFD) +# include +#endif + +//#define DEBUG_MODE + +#if defined(DEBUG_MODE) +# include +# define DEBUG(fmt, ...) { fprintf(stderr, "lwt-debug[%d]: %s: " fmt "\n", (pid_t)syscall(SYS_gettid), __FUNCTION__, ##__VA_ARGS__); fflush(stderr); } +#else +# define DEBUG(fmt, ...) +#endif + +/* +-----------------------------------------------------------------+ + | OS-dependent functions | + +-----------------------------------------------------------------+ */ + +#if defined(LWT_ON_WINDOWS) +# include "lwt_unix_windows.c" +#else +# include "lwt_unix_unix.c" +#endif + +/* +-----------------------------------------------------------------+ + | Utils | + +-----------------------------------------------------------------+ */ + +void *lwt_unix_malloc(size_t size) +{ + void *ptr = malloc(size); + if (ptr == NULL) { + perror("cannot allocate memory"); + abort(); + } + return ptr; +} + +char *lwt_unix_strdup(char *str) +{ + char *new_str = strdup(str); + if (new_str == NULL) { + perror("cannot allocate memory"); + abort(); + } + return new_str; +} + +void lwt_unix_not_available(char const *feature) +{ + caml_raise_with_arg(*caml_named_value("lwt:not-available"), caml_copy_string(feature)); +} + +/* +-----------------------------------------------------------------+ + | Operation on bigarrays | + +-----------------------------------------------------------------+ */ + +CAMLprim value lwt_unix_blit_bytes_bytes(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) +{ + memmove((char*)Caml_ba_data_val(val_buf2) + Long_val(val_ofs2), + (char*)Caml_ba_data_val(val_buf1) + Long_val(val_ofs1), + Long_val(val_len)); + return Val_unit; +} + +CAMLprim value lwt_unix_blit_string_bytes(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) +{ + memcpy((char*)Caml_ba_data_val(val_buf2) + Long_val(val_ofs2), + String_val(val_buf1) + Long_val(val_ofs1), + Long_val(val_len)); + return Val_unit; +} + +CAMLprim value lwt_unix_blit_bytes_string(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) +{ + memcpy(String_val(val_buf2) + Long_val(val_ofs2), + (char*)Caml_ba_data_val(val_buf1) + Long_val(val_ofs1), + Long_val(val_len)); + return Val_unit; +} + +CAMLprim value lwt_unix_fill_bytes(value val_buf, value val_ofs, value val_len, value val_char) +{ + memset((char*)Caml_ba_data_val(val_buf) + Long_val(val_ofs), Int_val(val_char), Long_val(val_len)); + return Val_unit; +} + +CAMLprim value lwt_unix_mapped(value v_bstr) +{ + return Val_bool(Caml_ba_array_val(v_bstr)->flags & CAML_BA_MAPPED_FILE); +} + +/* +-----------------------------------------------------------------+ + | Byte order | + +-----------------------------------------------------------------+ */ + +value lwt_unix_system_byte_order() +{ +#ifdef ARCH_BIG_ENDIAN + return Val_int(1); +#else + return Val_int(0); +#endif +} + +/* +-----------------------------------------------------------------+ + | Threading | + +-----------------------------------------------------------------+ */ + +#if defined(LWT_ON_WINDOWS) + +void lwt_unix_launch_thread(void* (*start)(void*), void* data) +{ + HANDLE handle = CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start, data, 0, NULL); + if (handle) CloseHandle(handle); +} + +lwt_unix_thread lwt_unix_thread_self() +{ + return GetCurrentThreadId(); +} + +int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2) +{ + return thread1 == thread2; +} + +void lwt_unix_mutex_init(lwt_unix_mutex *mutex) +{ + InitializeCriticalSection(mutex); +} + +void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex) +{ + DeleteCriticalSection(mutex); +} + +void lwt_unix_mutex_lock(lwt_unix_mutex *mutex) +{ + EnterCriticalSection(mutex); +} + +void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex) +{ + LeaveCriticalSection(mutex); +} + +struct wait_list { + HANDLE event; + struct wait_list *next; +}; + +struct lwt_unix_condition { + CRITICAL_SECTION mutex; + struct wait_list *waiters; +}; + +void lwt_unix_condition_init(lwt_unix_condition *condition) +{ + InitializeCriticalSection(&condition->mutex); + condition->waiters = NULL; +} + +void lwt_unix_condition_destroy(lwt_unix_condition *condition) +{ + DeleteCriticalSection(&condition->mutex); +} + +void lwt_unix_condition_signal(lwt_unix_condition *condition) +{ + struct wait_list *node; + EnterCriticalSection(&condition->mutex); + + node = condition->waiters; + if (node) { + condition->waiters = node->next; + SetEvent(node->event); + } + LeaveCriticalSection(&condition->mutex); +} + +void lwt_unix_condition_broadcast(lwt_unix_condition *condition) +{ + struct wait_list *node; + EnterCriticalSection(&condition->mutex); + for (node = condition->waiters; node; node = node->next) + SetEvent(node->event); + condition->waiters = NULL; + LeaveCriticalSection(&condition->mutex); +} + +void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex) +{ + HANDLE event; + struct wait_list node; + + /* Create the event for the notification. */ + node.event = CreateEvent(NULL, FALSE, FALSE, NULL); + + /* Add the node to the condition. */ + EnterCriticalSection(&condition->mutex); + node.next = condition->waiters; + condition->waiters = &node; + LeaveCriticalSection(&condition->mutex); + + /* Release the mutex. */ + LeaveCriticalSection(mutex); + + /* Wait for a signal. */ + WaitForSingleObject(node.event, INFINITE); + + /* Re-acquire the mutex. */ + EnterCriticalSection(mutex); +} + +#else + +void lwt_unix_launch_thread(void* (*start)(void*), void* data) +{ + pthread_t thread; + pthread_attr_t attr; + int result; + + pthread_attr_init(&attr); + + /* The thread is created in detached state so we do not have to join + it when it terminates: */ + pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); + + result = pthread_create(&thread, &attr, start, data); + + if (result) unix_error(result, "launch_thread", Nothing); + + pthread_attr_destroy (&attr); +} + +lwt_unix_thread lwt_unix_thread_self() +{ + return pthread_self(); +} + +int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2) +{ + return pthread_equal(thread1, thread2); +} + +void lwt_unix_mutex_init(lwt_unix_mutex *mutex) +{ + pthread_mutex_init(mutex, NULL); +} + +void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex) +{ + pthread_mutex_destroy(mutex); +} + +void lwt_unix_mutex_lock(lwt_unix_mutex *mutex) +{ + pthread_mutex_lock(mutex); +} + +void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex) +{ + pthread_mutex_unlock(mutex); +} + +void lwt_unix_condition_init(lwt_unix_condition *condition) +{ + pthread_cond_init(condition, NULL); +} + +void lwt_unix_condition_destroy(lwt_unix_condition *condition) +{ + pthread_cond_destroy(condition); +} + +void lwt_unix_condition_signal(lwt_unix_condition *condition) +{ + pthread_cond_signal(condition); +} + +void lwt_unix_condition_broadcast(lwt_unix_condition *condition) +{ + pthread_cond_broadcast(condition); +} + +void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex) +{ + pthread_cond_wait(condition, mutex); +} + +#endif + +/* +-----------------------------------------------------------------+ + | Notifications | + +-----------------------------------------------------------------+ */ + +/* The mutex used to send and receive notifications. */ +static lwt_unix_mutex notification_mutex; + +/* All pending notifications. */ +static long *notifications = NULL; + +/* The size of the notification buffer. */ +static long notification_count = 0; + +/* The index to the next available cell in the notification buffer. */ +static long notification_index = 0; + +/* The mode currently used for notifications. */ +enum notification_mode { + /* Not yet initialized. */ + NOTIFICATION_MODE_NOT_INITIALIZED, + + /* Initialized but no mode defined. */ + NOTIFICATION_MODE_NONE, + + /* Using an eventfd. */ + NOTIFICATION_MODE_EVENTFD, + + /* Using a pipe. */ + NOTIFICATION_MODE_PIPE, + + /* Using a pair of sockets (only on windows). */ + NOTIFICATION_MODE_WINDOWS +}; + +/* The current notification mode. */ +static enum notification_mode notification_mode = NOTIFICATION_MODE_NOT_INITIALIZED; + +/* Send one notification. */ +static int (*notification_send)(); + +/* Read one notification. */ +static int (*notification_recv)(); + +static void init_notifications() +{ + lwt_unix_mutex_init(¬ification_mutex); + notification_count = 4096; + notifications = (long*)lwt_unix_malloc(notification_count * sizeof(long)); +} + +static void resize_notifications() +{ + long new_notification_count = notification_count * 2; + long *new_notifications = (long*)lwt_unix_malloc(new_notification_count * sizeof(long)); + memcpy((void*)new_notifications, (void*)notifications, notification_count * sizeof(long)); + free(notifications); + notifications = new_notifications; + notification_count = new_notification_count; +} + +void lwt_unix_send_notification(int id) +{ + int ret; + lwt_unix_mutex_lock(¬ification_mutex); + if (notification_index > 0) { + /* There is already a pending notification in the buffer, no + need to signal the main thread. */ + if (notification_index == notification_count) resize_notifications(); + notifications[notification_index++] = id; + } else { + /* There is none, notify the main thread. */ + notifications[notification_index++] = id; +#if defined(LWT_ON_WINDOWS) + ret = notification_send(); + if (ret == SOCKET_ERROR) { + lwt_unix_mutex_unlock(¬ification_mutex); + win32_maperr(WSAGetLastError()); + uerror("send_notification", Nothing); + } +#else + for (;;) { + ret = notification_send(); + if (ret < 0) { + if (errno != EINTR) { + lwt_unix_mutex_unlock(¬ification_mutex); + uerror("send_notification", Nothing); + } + } else + break; + } +#endif + } + lwt_unix_mutex_unlock(¬ification_mutex); +} + +value lwt_unix_send_notification_stub(value id) +{ + lwt_unix_send_notification(Long_val(id)); + return Val_unit; +} + +value lwt_unix_recv_notifications() +{ + int ret, i; + value result; + lwt_unix_mutex_lock(¬ification_mutex); + /* Receive the signal. */ +#if defined(LWT_ON_WINDOWS) + ret = notification_recv(); + if (ret == SOCKET_ERROR) { + lwt_unix_mutex_unlock(¬ification_mutex); + win32_maperr(WSAGetLastError()); + uerror("recv_notifications", Nothing); + } +#else + for (;;) { + ret = notification_recv(); + if (ret < 0) { + if (errno != EINTR) { + lwt_unix_mutex_unlock(¬ification_mutex); + uerror("recv_notifications", Nothing); + } + } else + break; + } +#endif + /* Read all pending notifications. */ + result = caml_alloc_tuple(notification_index); + for (i = 0; i < notification_index; i++) + Field(result, i) = Val_long(notifications[i]); + /* Reset the index. */ + notification_index = 0; + lwt_unix_mutex_unlock(¬ification_mutex); + return result; +} + +#if defined(LWT_ON_WINDOWS) + +static SOCKET set_close_on_exec(SOCKET socket) +{ + SOCKET new_socket; + if (!DuplicateHandle(GetCurrentProcess(), (HANDLE)socket, + GetCurrentProcess(), (HANDLE*)&new_socket, + 0L, FALSE, DUPLICATE_SAME_ACCESS)) { + win32_maperr(GetLastError()); + uerror("set_close_on_exec", Nothing); + } + closesocket(socket); + return new_socket; +} + +static SOCKET socket_r, socket_w; + +static int windows_notification_send() +{ + char buf; + return send(socket_w, &buf, 1, 0); +} + +static int windows_notification_recv() +{ + char buf; + return recv(socket_r, &buf, 1, 0); +} + +value lwt_unix_init_notification() +{ + union { + struct sockaddr_in inaddr; + struct sockaddr addr; + } a; + SOCKET listener; + int e; + int addrlen = sizeof(a.inaddr); + int reuse = 1; + DWORD err; + + switch (notification_mode) { + case NOTIFICATION_MODE_NOT_INITIALIZED: + notification_mode = NOTIFICATION_MODE_NONE; + init_notifications(); + break; + case NOTIFICATION_MODE_WINDOWS: + notification_mode = NOTIFICATION_MODE_NONE; + closesocket(socket_r); + closesocket(socket_w); + break; + case NOTIFICATION_MODE_NONE: + break; + default: + caml_failwith("notification system in unknown state"); + } + + /* Since pipes do not works with select, we need to use a pair of + sockets. The following code simulate the socketpair call of + unix. */ + + socket_r = INVALID_SOCKET; + socket_w = INVALID_SOCKET; + + listener = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); + if (listener == INVALID_SOCKET) + goto failure; + + memset(&a, 0, sizeof(a)); + a.inaddr.sin_family = AF_INET; + a.inaddr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); + a.inaddr.sin_port = 0; + + if (setsockopt(listener, SOL_SOCKET, SO_REUSEADDR, (char*) &reuse, sizeof(reuse)) == -1) + goto failure; + + if (bind(listener, &a.addr, sizeof(a.inaddr)) == SOCKET_ERROR) + goto failure; + + memset(&a, 0, sizeof(a)); + if (getsockname(listener, &a.addr, &addrlen) == SOCKET_ERROR) + goto failure; + + a.inaddr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); + a.inaddr.sin_family = AF_INET; + + if (listen(listener, 1) == SOCKET_ERROR) + goto failure; + + socket_r = WSASocket(AF_INET, SOCK_STREAM, 0, NULL, 0, WSA_FLAG_OVERLAPPED); + if (socket_r == INVALID_SOCKET) + goto failure; + + if (connect(socket_r, &a.addr, sizeof(a.inaddr)) == SOCKET_ERROR) + goto failure; + + socket_w = accept(listener, NULL, NULL); + if (socket_w == INVALID_SOCKET) + goto failure; + + closesocket(listener); + + socket_r = set_close_on_exec(socket_r); + socket_w = set_close_on_exec(socket_w); + notification_mode = NOTIFICATION_MODE_WINDOWS; + notification_send = windows_notification_send; + notification_recv = windows_notification_recv; + return win_alloc_socket(socket_r); + + failure: + err = WSAGetLastError(); + closesocket(listener); + closesocket(socket_r); + closesocket(socket_w); + win32_maperr(err); + uerror("init_notification", Nothing); + /* Just to make the compiler happy. */ + return Val_unit; +} + +#else /* defined(LWT_ON_WINDOWS) */ + +static void set_close_on_exec(int fd) +{ + int flags = fcntl(fd, F_GETFD, 0); + if (flags == -1 || fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1) + uerror("set_close_on_exec", Nothing); +} + +#if defined(HAVE_EVENTFD) + +static int notification_fd; + +static int eventfd_notification_send() +{ + uint64_t buf = 1; + return write(notification_fd, (char*)&buf, 8); +} + +static int eventfd_notification_recv() +{ + uint64_t buf; + return read(notification_fd, (char*)&buf, 8); +} + +#endif /* defined(HAVE_EVENTFD) */ + +static int notification_fds[2]; + +static int pipe_notification_send() +{ + char buf; + return write(notification_fds[1], &buf, 1); +} + +static int pipe_notification_recv() +{ + char buf; + return read(notification_fds[0], &buf, 1); +} + +value lwt_unix_init_notification() +{ + switch (notification_mode) { +#if defined(HAVE_EVENTFD) + case NOTIFICATION_MODE_EVENTFD: + notification_mode = NOTIFICATION_MODE_NONE; + if (close(notification_fd) == -1) uerror("close", Nothing); + break; +#endif + case NOTIFICATION_MODE_PIPE: + notification_mode = NOTIFICATION_MODE_NONE; + if (close(notification_fds[0]) == -1) uerror("close", Nothing); + if (close(notification_fds[1]) == -1) uerror("close", Nothing); + break; + case NOTIFICATION_MODE_NOT_INITIALIZED: + notification_mode = NOTIFICATION_MODE_NONE; + init_notifications(); + break; + case NOTIFICATION_MODE_NONE: + break; + default: + caml_failwith("notification system in unknown state"); + } + +#if defined(HAVE_EVENTFD) + notification_fd = eventfd(0, 0); + if (notification_fd != -1) { + notification_mode = NOTIFICATION_MODE_EVENTFD; + notification_send = eventfd_notification_send; + notification_recv = eventfd_notification_recv; + set_close_on_exec(notification_fd); + return Val_int(notification_fd); + } +#endif + + if (pipe(notification_fds) == -1) uerror("pipe", Nothing); + set_close_on_exec(notification_fds[0]); + set_close_on_exec(notification_fds[1]); + notification_mode = NOTIFICATION_MODE_PIPE; + notification_send = pipe_notification_send; + notification_recv = pipe_notification_recv; + return Val_int(notification_fds[0]); +} + +#endif /* defined(LWT_ON_WINDOWS) */ + +/* +-----------------------------------------------------------------+ + | Job execution | + +-----------------------------------------------------------------+ */ + +/* Execute the given job. */ +static void execute_job(lwt_unix_job job) +{ + DEBUG("executing the job"); + + lwt_unix_mutex_lock(&job->mutex); + + /* If the job has been canceled, do nothing. */ + if (job->state == LWT_UNIX_JOB_STATE_CANCELED) { + lwt_unix_mutex_unlock(&job->mutex); + return; + } + + /* Mark the job as running. */ + job->state = LWT_UNIX_JOB_STATE_RUNNING; + + /* Set the thread of the job. */ + job->thread = lwt_unix_thread_self(); + + lwt_unix_mutex_unlock(&job->mutex); + + /* Execute the job. */ + job->worker(job); + + DEBUG("job done"); + + lwt_unix_mutex_lock(&job->mutex); + + DEBUG("marking the job has done"); + + /* Job is done. If the main thread stopped until now, asynchronous + notification is not necessary. */ + job->state = LWT_UNIX_JOB_STATE_DONE; + + /* Send a notification if the main thread continued its execution + before the job terminated. */ + if (job->fast == 0) { + lwt_unix_mutex_unlock(&job->mutex); + DEBUG("notifying the main thread"); + lwt_unix_send_notification(job->notification_id); + } else { + lwt_unix_mutex_unlock(&job->mutex); + DEBUG("not notifying the main thread"); + } +} + +/* +-----------------------------------------------------------------+ + | Config | + +-----------------------------------------------------------------+ */ + +/* The signal used to allocate new stack. */ +static int signal_alloc_stack = -1; + +/* The signal used to kill a thread. */ +static int signal_kill_thread = -1; + +/* +-----------------------------------------------------------------+ + | Thread pool | + +-----------------------------------------------------------------+ */ + +/* Number of thread waiting for a job in the pool. */ +static int thread_waiting_count = 0; + +/* Number of started threads. */ +static int thread_count = 0; + +/* Maximum number of system threads that can be started. */ +static int pool_size = 1000; + +/* Condition on which pool threads are waiting. */ +static lwt_unix_condition pool_condition; + +/* Queue of pending jobs. It points to the last enqueued job. */ +static lwt_unix_job pool_queue = NULL; + +/* The mutex which protect access to [pool_queue], [pool_condition] + and [thread_waiting_count]. */ +static lwt_unix_mutex pool_mutex; + +/* +-----------------------------------------------------------------+ + | Thread switching | + +-----------------------------------------------------------------+ */ + +/* Possible states of the main thread (i.e. the one executing the + ocaml code). */ +enum main_state { + /* The main thread is running. */ + STATE_RUNNING, + + /* The main thread is doing a blocking call that has not yet + terminated. */ + STATE_BLOCKED, +}; + +/* State of the main thread. */ +static enum main_state main_state = STATE_RUNNING; + +/* The main thread. */ +static lwt_unix_thread main_thread; + +/* A node in a list of stack frames. */ +struct stack_frame { + /* The stack frame itself. */ + jmp_buf checkpoint; + + /* The next available one. */ + struct stack_frame *next; +}; + +/* Stack frames available to do a blocking call. */ +static struct stack_frame *blocking_call_enter = NULL; + +/* Mutex to protect access to [blocking_call_enter]. */ +static lwt_unix_mutex blocking_call_enter_mutex; + +/* Where to go when the blocking call is done, or when it get + scheduled. */ +static jmp_buf blocking_call_leave; + +/* Where to go to become a worjer */ +static struct stack_frame *become_worker = NULL; + +/* Value returned to the main thread when a blocking call terminates + without being scheduled. */ +#define CALL_SUCCEEDED 1 + +/* Value returned to the old main thread whan a blocking call + terminates but has been scheduled. */ +#define CALL_SCHEDULED 2 + +/* The job to be executed on the first available alternative stack. */ +static lwt_unix_job blocking_call = NULL; + +/* The stack frame used for the current blocking call. */ +static struct stack_frame *blocking_call_frame = NULL; + +/* Flag which become [1] once the stack has been allocated. */ +static int stack_allocated; + +/* Function executed on an alternative stack. */ +static void altstack_worker() +{ + struct stack_frame *node; + jmp_buf buf; + + if (stack_allocated == 1) return; + stack_allocated = 1; + + /* The first passage is to register a new stack frame. */ + node = lwt_unix_new(struct stack_frame); + + if (setjmp(node->checkpoint) == 0) { + + /* Add it to the list of available stack frames. */ + lwt_unix_mutex_lock(&blocking_call_enter_mutex); + node->next = blocking_call_enter; + blocking_call_enter = node; + lwt_unix_mutex_unlock(&blocking_call_enter_mutex); + + } else { + + /* Save the job to execute and the current stack frame before + another thread can become the main thread. */ + lwt_unix_job job = blocking_call; + struct stack_frame *frame = blocking_call_frame; + + /* Mark the main thread as blocked. */ + main_state = STATE_BLOCKED; + + DEBUG("signaling the pool condition variable"); + + /* Maybe wakeup a worker so it can become the main thread. */ + lwt_unix_mutex_lock(&pool_mutex); + lwt_unix_condition_signal(&pool_condition); + lwt_unix_mutex_unlock(&pool_mutex); + + DEBUG("executing the blocking call"); + + /* Execute the blocking call. */ + execute_job(job); + + DEBUG("blocking call done"); + + lwt_unix_mutex_lock(&pool_mutex); + + if (lwt_unix_thread_equal(main_thread, lwt_unix_thread_self())) { + /* We stayed the main thread, continue the execution + normally. */ + main_state = STATE_RUNNING; + + lwt_unix_mutex_unlock(&pool_mutex); + + DEBUG("blocing call terminated without blocking, resuming"); + + /* Leave the blocking call. */ + longjmp(blocking_call_leave, CALL_SUCCEEDED); + } else { + /* We did not stayed the main thread, we now become a worker. */ + + assert(become_worker != NULL); + + /* Take and remove the first worker checkpoint. */ + node = become_worker; + become_worker = node->next; + + lwt_unix_mutex_unlock(&pool_mutex); + + DEBUG("blocking call terminated after blocking, becoming a worker"); + + /* Add the stack frame used for this call to the list of + available ones. */ + lwt_unix_mutex_lock(&blocking_call_enter_mutex); + frame->next = blocking_call_enter; + blocking_call_enter = frame; + /* Release the mutex only after the jump. */ + + memcpy(&buf, &(node->checkpoint), sizeof(jmp_buf)); + free(node); + longjmp(buf, 1); + } + } +} + +#define STACK_SIZE (256 * 1024) + +/* Allocate a new stack for doing blocking calls. */ +void alloc_new_stack() +{ +#if !defined(LWT_ON_WINDOWS) + DEBUG("allocate a new stack"); + + stack_t old_stack, new_stack; + struct sigaction old_sa, new_sa; + + /* Create the new stack. */ + new_stack.ss_flags = 0; + new_stack.ss_size = STACK_SIZE; + new_stack.ss_sp = lwt_unix_malloc(STACK_SIZE); + + /* Change the stack used for signals. */ + sigaltstack(&new_stack, &old_stack); + + stack_allocated = 0; + + /* Set up the custom signal handler. */ + new_sa.sa_handler = altstack_worker; + new_sa.sa_flags = SA_ONSTACK; + sigemptyset(&new_sa.sa_mask); + sigaction(signal_alloc_stack, &new_sa, &old_sa); + + /* Save the stack frame. */ + raise(signal_alloc_stack); + + /* Restore the old signal handler. */ + sigaction(signal_alloc_stack, &old_sa, NULL); + + /* Restore the old alternative stack. */ + sigaltstack(&old_stack, NULL); +#endif +} + +/* +-----------------------------------------------------------------+ + | Threading stuff initialization | + +-----------------------------------------------------------------+ */ + +/* Whether threading has been initialized. */ +static int threading_initialized = 0; + +static void nop() {} + +#if !defined(SIGRTMIN) || !defined(SIGRTMAX) +# define SIGRTMIN 0 +# define SIGRTMAX 0 +#endif + +/* Initialize the pool of thread. */ +void initialize_threading() +{ + if (threading_initialized == 0) { + lwt_unix_mutex_init(&pool_mutex); + lwt_unix_condition_init(&pool_condition); + lwt_unix_mutex_init(&blocking_call_enter_mutex); + + main_thread = lwt_unix_thread_self(); + +#if !defined(LWT_ON_WINDOWS) + if (SIGRTMIN < SIGRTMAX) { + signal_alloc_stack = SIGRTMIN; + if (SIGRTMIN + 1 < SIGRTMAX) + signal_kill_thread = SIGRTMIN + 1; + else + signal_kill_thread = SIGUSR1; + } else { + signal_alloc_stack = SIGUSR1; + signal_kill_thread = SIGUSR2; + } + + /* Define a handler for the signal used for killing threads to be + sure system calls get interrupted. */ + struct sigaction sa; + sa.sa_handler = nop; + sa.sa_flags = 0; + sigemptyset(&sa.sa_mask); + sigaction(signal_kill_thread, &sa, NULL); +#endif + + threading_initialized = 1; + } +} + +/* +-----------------------------------------------------------------+ + | Worker loop | + +-----------------------------------------------------------------+ */ + +/* Function executed by threads of the pool. */ +static void* worker_loop(void *data) +{ + lwt_unix_job job = (lwt_unix_job)data; + struct stack_frame *node; + + /* Execute the initial job if any. */ + if (job != NULL) execute_job(job); + + while (1) { + DEBUG("entering waiting section"); + + lwt_unix_mutex_lock(&pool_mutex); + + /* One more thread is waiting for work. */ + thread_waiting_count++; + + DEBUG("waiting for something to do"); + + /* Wait for something to do. */ + while (pool_queue == NULL && main_state == STATE_RUNNING) + lwt_unix_condition_wait(&pool_condition, &pool_mutex); + + DEBUG("received something to do"); + + /* This thread is busy. */ + thread_waiting_count--; + + if (main_state == STATE_BLOCKED) { + DEBUG("main thread is blocked"); + DEBUG("\e[1;31mswitching\e[0m"); + + /* If the main thread is blocked, we become the main thread. */ + main_thread = lwt_unix_thread_self(); + + /* The new main thread is running again. */ + main_state = STATE_RUNNING; + + node = lwt_unix_new(struct stack_frame); + + /* Save the stack frame so the old main thread can become a + worker when the blocking call terminates. */ + if (setjmp(node->checkpoint) == 0) { + DEBUG("checkpoint for future worker done"); + + /* Save the stack frame in the list of worker checkpoints. */ + node->next = become_worker; + become_worker = node; + + DEBUG("going back to the ocaml code"); + + /* Go to before the blocking call. */ + longjmp(blocking_call_leave, CALL_SCHEDULED); + } + + DEBUG("transformation to worker done"); + + /* This thread is not running caml code anymore. */ + //caml_c_thread_unregister(); + + /* Release this mutex. It was locked before the jump. */ + lwt_unix_mutex_unlock(&blocking_call_enter_mutex); + + } else { + DEBUG("taking a job to execute"); + + /* Take the first queued job. */ + job = pool_queue->next; + + /* Remove it from the queue. */ + if (job->next == job) + pool_queue = NULL; + else + pool_queue->next = job->next; + + lwt_unix_mutex_unlock(&pool_mutex); + + /* Execute the job. */ + execute_job(job); + } + } + + return NULL; +} + +/* +-----------------------------------------------------------------+ + | Jobs | + +-----------------------------------------------------------------+ */ + +/* Description of jobs. */ +struct custom_operations job_ops = { + "lwt.unix.job", + custom_finalize_default, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +/* Get the job structure contained in a custom value. */ +#define Job_val(v) *(lwt_unix_job*)Data_custom_val(v) + +value lwt_unix_alloc_job(lwt_unix_job job) +{ + value val_job = caml_alloc_custom(&job_ops, sizeof(lwt_unix_job), 0, 1); + Job_val(val_job) = job; + return val_job; +} + +void lwt_unix_free_job(lwt_unix_job job) +{ + if (job->async_method != LWT_UNIX_ASYNC_METHOD_NONE) + lwt_unix_mutex_destroy(&job->mutex); + free(job); +} + +CAMLprim value lwt_unix_start_job(value val_job, value val_async_method) +{ + lwt_unix_job job = Job_val(val_job); + struct stack_frame *node; + lwt_unix_async_method async_method = Int_val(val_async_method); + + /* Fallback to synchronous call if there is no worker available and + we can not launch more threads. */ + if (async_method != LWT_UNIX_ASYNC_METHOD_NONE && thread_waiting_count == 0 && thread_count >= pool_size) + async_method = LWT_UNIX_ASYNC_METHOD_NONE; + + /* Initialises job parameters. */ + job->state = LWT_UNIX_JOB_STATE_PENDING; + job->fast = 1; + job->async_method = async_method; + + switch (async_method) { + + case LWT_UNIX_ASYNC_METHOD_NONE: + /* Execute the job synchronously. */ + caml_enter_blocking_section(); + job->worker(job); + caml_leave_blocking_section(); + return Val_true; + + case LWT_UNIX_ASYNC_METHOD_DETACH: + if (threading_initialized == 0) initialize_threading(); + + lwt_unix_mutex_init(&job->mutex); + + lwt_unix_mutex_lock(&pool_mutex); + if (thread_waiting_count == 0) { + /* Launch a new worker. */ + thread_count++; + lwt_unix_mutex_unlock(&pool_mutex); + lwt_unix_launch_thread(worker_loop, (void*)job); + } else { + /* Add the job at the end of the queue. */ + if (pool_queue == NULL) { + pool_queue = job; + job->next = job; + } else { + job->next = pool_queue->next; + pool_queue->next = job; + pool_queue = job; + } + /* Wakeup one worker. */ + lwt_unix_condition_signal(&pool_condition); + lwt_unix_mutex_unlock(&pool_mutex); + } + return Val_bool(job->state == LWT_UNIX_JOB_STATE_DONE); + + case LWT_UNIX_ASYNC_METHOD_SWITCH: +#if defined(LWT_ON_WINDOWS) + caml_invalid_argument("the switch method is not implemented on windows"); +#endif + + if (threading_initialized == 0) initialize_threading(); + + lwt_unix_mutex_init(&job->mutex); + job->thread = main_thread; + + /* Ensures there is at least one thread that can become the main + thread. */ + if (thread_waiting_count == 0) { + thread_count++; + lwt_unix_launch_thread(worker_loop, NULL); + } + + if (blocking_call_enter == NULL) alloc_new_stack(); + + DEBUG("taking a stack frame for doing a blocking call"); + + /* Take and remove the first available stack frame for system + calls. */ + lwt_unix_mutex_lock(&blocking_call_enter_mutex); + assert(blocking_call_enter != NULL); + node = blocking_call_enter; + blocking_call_enter = node->next; + lwt_unix_mutex_unlock(&blocking_call_enter_mutex); + + /* Save the stack frame to leave the blocking call. */ + switch (setjmp(blocking_call_leave)) { + case 0: + /* Save the job to do. */ + blocking_call = job; + + /* Save the stack frame that will be used for this call in case + it get scheduled. */ + blocking_call_frame = node; + + DEBUG("jumping to do a blocking call"); + + /* Jump to an alternative stack and do the call. */ + longjmp(node->checkpoint, 1); + + case CALL_SUCCEEDED: + DEBUG("resuming without being scheduled"); + + /* Re-add the stack frame used for the call to the list of + available ones. */ + lwt_unix_mutex_lock(&blocking_call_enter_mutex); + node->next = blocking_call_enter; + blocking_call_enter = node; + lwt_unix_mutex_unlock(&blocking_call_enter_mutex); + return Val_true; + + case CALL_SCHEDULED: + DEBUG("resuming after being scheduled"); + + /* This mutex was locked before we did the jump. */ + lwt_unix_mutex_unlock(&pool_mutex); + + /* This thread is now running caml code. */ + //caml_c_thread_register(); + return Val_bool(job->state == LWT_UNIX_JOB_STATE_DONE); + } + } + + return Val_false; +} + +CAMLprim value lwt_unix_check_job(value val_job, value val_notification_id) +{ + lwt_unix_job job = Job_val(val_job); + value result; + + DEBUG("checking job"); + + switch (job->async_method) { + + case LWT_UNIX_ASYNC_METHOD_NONE: + return Val_int(1); + + case LWT_UNIX_ASYNC_METHOD_DETACH: + case LWT_UNIX_ASYNC_METHOD_SWITCH: + lwt_unix_mutex_lock(&job->mutex); + /* We are not waiting anymore. */ + job->fast = 0; + /* Set the notification id for asynchronous wakeup. */ + job->notification_id = Int_val(val_notification_id); + result = Val_bool(job->state == LWT_UNIX_JOB_STATE_DONE); + lwt_unix_mutex_unlock(&job->mutex); + + DEBUG("job done: %d", Int_val(result)); + + return result; + } + + return Val_int(0); +} + +CAMLprim value lwt_unix_cancel_job(value val_job) +{ + struct lwt_unix_job *job = Job_val(val_job); + + DEBUG("cancelling job"); + + switch (job->async_method) { + + case LWT_UNIX_ASYNC_METHOD_NONE: + break; + + case LWT_UNIX_ASYNC_METHOD_DETACH: + case LWT_UNIX_ASYNC_METHOD_SWITCH: + lwt_unix_mutex_lock(&job->mutex); + switch (job->state) { + case LWT_UNIX_JOB_STATE_PENDING: + /* The job has not yet started, mark it as canceled. */ + job->state = LWT_UNIX_JOB_STATE_CANCELED; + break; + + case LWT_UNIX_JOB_STATE_RUNNING: +#if !defined(LWT_ON_WINDOWS) + /* The job is running, kill it. */ + if (signal_kill_thread >= 0) + pthread_kill(job->thread, signal_kill_thread); +#endif + break; + + case LWT_UNIX_JOB_STATE_DONE: + /* The job is done, do nothing. */ + break; + + case LWT_UNIX_JOB_STATE_CANCELED: + /* Not possible. */ + break; + } + lwt_unix_mutex_unlock(&job->mutex); + break; + } + + return Val_unit; +} + +CAMLprim value lwt_unix_reset_after_fork() +{ + if (threading_initialized) { + /* Reset the main thread. */ + main_thread = lwt_unix_thread_self (); + + /* There is no more waiting threads. */ + thread_waiting_count = 0; + + /* There is no more threads. */ + thread_count = 0; + + /* Empty the queue. */ + pool_queue = NULL; + } + + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | Statistics and control | + +-----------------------------------------------------------------+ */ + +CAMLprim value lwt_unix_pool_size() +{ + return Val_int(pool_size); +} + +CAMLprim value lwt_unix_set_pool_size(value val_size) +{ + pool_size = Int_val(val_size); + return Val_unit; +} + +CAMLprim value lwt_unix_thread_count() +{ + return Val_int(thread_count); +} + +CAMLprim value lwt_unix_thread_waiting_count() +{ + return Val_int(thread_waiting_count); +} diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_unix_unix.c b/thirdparty/lwt-2.3.2/src/unix/lwt_unix_unix.c new file mode 100644 index 0000000..4dccc6a --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_unix_unix.c @@ -0,0 +1,3864 @@ +/* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_unix_unix + * Copyright (C) 2009-2010 Jérémie Dimino + * 2009 Mauricio Fernandez + * 2010 Pierre Chambart + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + */ + +/* Unix (non windows) version of stubs. */ + +/* +-----------------------------------------------------------------+ + | Test for readability/writability | + +-----------------------------------------------------------------+ */ + +#include + +CAMLprim value lwt_unix_readable(value fd) +{ + struct pollfd pollfd; + pollfd.fd = Int_val(fd); + pollfd.events = POLLIN; + pollfd.revents = 0; + if (poll(&pollfd, 1, 0) < 0) + uerror("readable", Nothing); + return (Val_bool(pollfd.revents & POLLIN)); +} + +CAMLprim value lwt_unix_writable(value fd) +{ + struct pollfd pollfd; + pollfd.fd = Int_val(fd); + pollfd.events = POLLOUT; + pollfd.revents = 0; + if (poll(&pollfd, 1, 0) < 0) + uerror("readable", Nothing); + return (Val_bool(pollfd.revents & POLLOUT)); +} + +/* +-----------------------------------------------------------------+ + | Memory mapped files | + +-----------------------------------------------------------------+ */ + +static int advise_table[] = { + MADV_NORMAL, + MADV_RANDOM, + MADV_SEQUENTIAL, + MADV_WILLNEED, + MADV_DONTNEED, +}; + +CAMLprim value lwt_unix_madvise (value val_buffer, value val_offset, value val_length, value val_advice) +{ + int ret = madvise((char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset), + Long_val(val_length), + advise_table[Int_val(val_advice)]); + if (ret == -1) uerror("madvise", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_get_page_size() +{ + long page_size = sysconf(_SC_PAGESIZE); + if (page_size < 0) page_size = 4096; + return Val_long(page_size); +} + +CAMLprim value lwt_unix_mincore(value val_buffer, value val_offset, value val_length, value val_states) +{ + long len = Wosize_val(val_states); + unsigned char vec[len]; + mincore((char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset), Long_val(val_length), vec); + long i; + for (i = 0; i < len; i++) + Field(val_states, i) = Val_bool(vec[i] & 1); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | read/write | + +-----------------------------------------------------------------+ */ + +CAMLprim value lwt_unix_read(value val_fd, value val_buf, value val_ofs, value val_len) +{ + int ret; + ret = read(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len)); + if (ret == -1) uerror("read", Nothing); + return Val_int(ret); +} + +CAMLprim value lwt_unix_bytes_read(value val_fd, value val_buf, value val_ofs, value val_len) +{ + int ret; + ret = read(Int_val(val_fd), (char*)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs), Long_val(val_len)); + if (ret == -1) uerror("read", Nothing); + return Val_int(ret); +} + +CAMLprim value lwt_unix_write(value val_fd, value val_buf, value val_ofs, value val_len) +{ + int ret; + ret = write(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len)); + if (ret == -1) uerror("write", Nothing); + return Val_int(ret); +} + +CAMLprim value lwt_unix_bytes_write(value val_fd, value val_buf, value val_ofs, value val_len) +{ + int ret; + ret = write(Int_val(val_fd), (char*)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs), Long_val(val_len)); + if (ret == -1) uerror("write", Nothing); + return Val_int(ret); +} + +/* +-----------------------------------------------------------------+ + | recv/send | + +-----------------------------------------------------------------+ */ + +static int msg_flag_table[] = { + MSG_OOB, MSG_DONTROUTE, MSG_PEEK +}; + +value lwt_unix_recv(value fd, value buf, value ofs, value len, value flags) +{ + int ret; + ret = recv(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), + convert_flag_list(flags, msg_flag_table)); + if (ret == -1) uerror("recv", Nothing); + return Val_int(ret); +} + +value lwt_unix_bytes_recv(value fd, value buf, value ofs, value len, value flags) +{ + int ret; + ret = recv(Int_val(fd), (char*)Caml_ba_array_val(buf)->data + Long_val(ofs), Long_val(len), + convert_flag_list(flags, msg_flag_table)); + if (ret == -1) uerror("recv", Nothing); + return Val_int(ret); +} + +value lwt_unix_send(value fd, value buf, value ofs, value len, value flags) +{ + int ret; + ret = send(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), + convert_flag_list(flags, msg_flag_table)); + if (ret == -1) uerror("send", Nothing); + return Val_int(ret); +} + +value lwt_unix_bytes_send(value fd, value buf, value ofs, value len, value flags) +{ + int ret; + ret = send(Int_val(fd), (char*)Caml_ba_array_val(buf)->data + Long_val(ofs), Long_val(len), + convert_flag_list(flags, msg_flag_table)); + if (ret == -1) uerror("send", Nothing); + return Val_int(ret); +} + +/* +-----------------------------------------------------------------+ + | recvfrom/sendto | + +-----------------------------------------------------------------+ */ + +extern int socket_domain_table[]; +extern int socket_type_table[]; + +union sock_addr_union { + struct sockaddr s_gen; + struct sockaddr_un s_unix; + struct sockaddr_in s_inet; + struct sockaddr_in6 s_inet6; +}; + +CAMLexport value alloc_sockaddr (union sock_addr_union * addr /*in*/, + socklen_t addr_len, int close_on_error); + +value lwt_unix_recvfrom(value fd, value buf, value ofs, value len, value flags) +{ + CAMLparam5(fd, buf, ofs, len, flags); + CAMLlocal2(result, address); + int ret; + union sock_addr_union addr; + socklen_t addr_len; + addr_len = sizeof(addr); + ret = recvfrom(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), + convert_flag_list(flags, msg_flag_table), + &addr.s_gen, &addr_len); + if (ret == -1) uerror("recvfrom", Nothing); + address = alloc_sockaddr(&addr, addr_len, -1); + result = caml_alloc_tuple(2); + Field(result, 0) = Val_int(ret); + Field(result, 1) = address; + CAMLreturn(result); +} + +value lwt_unix_bytes_recvfrom(value fd, value buf, value ofs, value len, value flags) +{ + CAMLparam5(fd, buf, ofs, len, flags); + CAMLlocal2(result, address); + int ret; + union sock_addr_union addr; + socklen_t addr_len; + addr_len = sizeof(addr); + ret = recvfrom(Int_val(fd), (char*)Caml_ba_data_val(buf) + Long_val(ofs), Long_val(len), + convert_flag_list(flags, msg_flag_table), + &addr.s_gen, &addr_len); + if (ret == -1) uerror("recvfrom", Nothing); + address = alloc_sockaddr(&addr, addr_len, -1); + result = caml_alloc_tuple(2); + Field(result, 0) = Val_int(ret); + Field(result, 1) = address; + CAMLreturn(result); +} + +extern void get_sockaddr (value mladdr, + union sock_addr_union * addr /*out*/, + socklen_t * addr_len /*out*/); + +value lwt_unix_sendto(value fd, value buf, value ofs, value len, value flags, value dest) +{ + union sock_addr_union addr; + socklen_t addr_len; + int ret; + get_sockaddr(dest, &addr, &addr_len); + ret = sendto(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), + convert_flag_list(flags, msg_flag_table), + &addr.s_gen, addr_len); + if (ret == -1) uerror("send", Nothing); + return Val_int(ret); +} + +CAMLprim value lwt_unix_sendto_byte(value *argv, int argc) +{ + return lwt_unix_sendto(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value lwt_unix_bytes_sendto(value fd, value buf, value ofs, value len, value flags, value dest) +{ + union sock_addr_union addr; + socklen_t addr_len; + int ret; + get_sockaddr(dest, &addr, &addr_len); + ret = sendto(Int_val(fd), (char*)Caml_ba_data_val(buf) + Long_val(ofs), Long_val(len), + convert_flag_list(flags, msg_flag_table), + &addr.s_gen, addr_len); + if (ret == -1) uerror("send", Nothing); + return Val_int(ret); +} + +CAMLprim value lwt_unix_bytes_sendto_byte(value *argv, int argc) +{ + return lwt_unix_bytes_sendto(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +/* +-----------------------------------------------------------------+ + | {recv/send}_msg | + +-----------------------------------------------------------------+ */ + +/* Convert a caml list of io-vectors into a C array io io-vector + structures */ +static void store_iovs(struct iovec *iovs, value iovs_val) +{ + CAMLparam0(); + CAMLlocal2(list, x); + for(list = iovs_val; Is_block(list); list = Field(list, 1), iovs++) { + x = Field(list, 0); + iovs->iov_base = &Byte(String_val(Field(x, 0)), Long_val(Field(x, 1))); + iovs->iov_len = Long_val(Field(x, 2)); + } + CAMLreturn0; +} + +static void bytes_store_iovs(struct iovec *iovs, value iovs_val) +{ + CAMLparam0(); + CAMLlocal2(list, x); + for(list = iovs_val; Is_block(list); list = Field(list, 1), iovs++) { + x = Field(list, 0); + iovs->iov_base = (char*)Caml_ba_data_val(Field(x, 0)) + Long_val(Field(x, 1)); + iovs->iov_len = Long_val(Field(x, 2)); + } + CAMLreturn0; +} + +static value wrapper_recv_msg(int fd, int n_iovs, struct iovec *iovs) +{ + CAMLparam0(); + CAMLlocal3(list, result, x); + + struct msghdr msg; + memset(&msg, 0, sizeof(msg)); + msg.msg_iov = iovs; + msg.msg_iovlen = n_iovs; +#if defined(HAVE_FD_PASSING) + msg.msg_controllen = CMSG_SPACE(256 * sizeof(int)); + msg.msg_control = alloca(msg.msg_controllen); + memset(msg.msg_control, 0, msg.msg_controllen); +#endif + + int ret = recvmsg(fd, &msg, 0); + if (ret == -1) uerror("recv_msg", Nothing); + + list = Val_int(0); +#if defined(HAVE_FD_PASSING) + struct cmsghdr *cm; + for (cm = CMSG_FIRSTHDR(&msg); cm; cm = CMSG_NXTHDR(&msg, cm)) + if (cm->cmsg_level == SOL_SOCKET && cm->cmsg_type == SCM_RIGHTS) { + int *fds = (int*)CMSG_DATA(cm); + int nfds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int); + int i; + for(i = nfds - 1; i >= 0; i--) { + x = caml_alloc_tuple(2); + Store_field(x, 0, Val_int(fds[i])); + Store_field(x, 1, list); + list = x; + }; + break; + }; +#endif + + result = caml_alloc_tuple(2); + Store_field(result, 0, Val_int(ret)); + Store_field(result, 1, list); + CAMLreturn(result); +} + +CAMLprim value lwt_unix_recv_msg(value val_fd, value val_n_iovs, value val_iovs) +{ + int n_iovs = Int_val(val_n_iovs); + struct iovec iovs[n_iovs]; + store_iovs(iovs, val_iovs); + return wrapper_recv_msg(Int_val(val_fd), n_iovs, iovs); +} + +CAMLprim value lwt_unix_bytes_recv_msg(value val_fd, value val_n_iovs, value val_iovs) +{ + int n_iovs = Int_val(val_n_iovs); + struct iovec iovs[n_iovs]; + bytes_store_iovs(iovs, val_iovs); + return wrapper_recv_msg(Int_val(val_fd), n_iovs, iovs); +} + +static value wrapper_send_msg(int fd, int n_iovs, struct iovec *iovs, value val_n_fds, value val_fds) +{ + CAMLparam2(val_n_fds, val_fds); + + struct msghdr msg; + memset(&msg, 0, sizeof(msg)); + msg.msg_iov = iovs; + msg.msg_iovlen = n_iovs; + + int n_fds = Int_val(val_n_fds); +#if defined(HAVE_FD_PASSING) + if (n_fds > 0) { + msg.msg_controllen = CMSG_SPACE(n_fds * sizeof(int)); + msg.msg_control = alloca(msg.msg_controllen); + memset(msg.msg_control, 0, msg.msg_controllen); + + struct cmsghdr *cm; + cm = CMSG_FIRSTHDR(&msg); + cm->cmsg_level = SOL_SOCKET; + cm->cmsg_type = SCM_RIGHTS; + cm->cmsg_len = CMSG_LEN(n_fds * sizeof(int)); + + int *fds = (int*)CMSG_DATA(cm); + for(; Is_block(val_fds); val_fds = Field(val_fds, 1), fds++) + *fds = Int_val(Field(val_fds, 0)); + }; +#else + if (n_fds > 0) lwt_unix_not_available("fd_passing"); +#endif + + int ret = sendmsg(fd, &msg, 0); + if (ret == -1) uerror("send_msg", Nothing); + CAMLreturn(Val_int(ret)); +} + +CAMLprim value lwt_unix_send_msg(value val_fd, value val_n_iovs, value val_iovs, value val_n_fds, value val_fds) +{ + int n_iovs = Int_val(val_n_iovs); + struct iovec iovs[n_iovs]; + store_iovs(iovs, val_iovs); + return wrapper_send_msg(Int_val(val_fd), n_iovs, iovs, val_n_fds, val_fds); +} + +CAMLprim value lwt_unix_bytes_send_msg(value val_fd, value val_n_iovs, value val_iovs, value val_n_fds, value val_fds) +{ + int n_iovs = Int_val(val_n_iovs); + struct iovec iovs[n_iovs]; + bytes_store_iovs(iovs, val_iovs); + return wrapper_send_msg(Int_val(val_fd), n_iovs, iovs, val_n_fds, val_fds); +} + +/* +-----------------------------------------------------------------+ + | Credentials | + +-----------------------------------------------------------------+ */ + +#if defined(HAVE_GET_CREDENTIALS) + +#include + +CAMLprim value lwt_unix_get_credentials(value fd) +{ + CAMLparam1(fd); + CAMLlocal1(res); + struct ucred cred; + socklen_t cred_len = sizeof(cred); + + if (getsockopt(Int_val(fd), SOL_SOCKET, SO_PEERCRED, &cred, &cred_len) == -1) + uerror("get_credentials", Nothing); + + res = caml_alloc_tuple(3); + Store_field(res, 0, Val_int(cred.pid)); + Store_field(res, 1, Val_int(cred.uid)); + Store_field(res, 2, Val_int(cred.gid)); + CAMLreturn(res); +} + +#endif + +/* +-----------------------------------------------------------------+ + | wait4 | + +-----------------------------------------------------------------+ */ + +/* Some code duplicated from OCaml's otherlibs/unix/wait.c */ + +#include +#include +#include + +CAMLextern int caml_convert_signal_number (int); +CAMLextern int caml_rev_convert_signal_number (int); + +#if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \ + defined(WSTOPSIG) && defined(WTERMSIG)) +/* Assume old-style V7 status word */ +#define WIFEXITED(status) (((status) & 0xFF) == 0) +#define WEXITSTATUS(status) (((status) >> 8) & 0xFF) +#define WIFSTOPPED(status) (((status) & 0xFF) == 0xFF) +#define WSTOPSIG(status) (((status) >> 8) & 0xFF) +#define WTERMSIG(status) ((status) & 0x3F) +#endif + +#define TAG_WEXITED 0 +#define TAG_WSIGNALED 1 +#define TAG_WSTOPPED 2 + +static value alloc_process_status(int status) +{ + value st; + + if (WIFEXITED(status)) { + st = alloc_small(1, TAG_WEXITED); + Field(st, 0) = Val_int(WEXITSTATUS(status)); + } + else if (WIFSTOPPED(status)) { + st = alloc_small(1, TAG_WSTOPPED); + Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status))); + } + else { + st = alloc_small(1, TAG_WSIGNALED); + Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status))); + } + return st; +} + +static int wait_flag_table[] = { + WNOHANG, WUNTRACED +}; + +value lwt_unix_wait4(value flags, value pid_req) +{ + CAMLparam1(flags); + CAMLlocal2(times, res); + + int pid, status, cv_flags; + cv_flags = caml_convert_flag_list(flags, wait_flag_table); + + struct rusage ru; + + caml_enter_blocking_section(); + pid = wait4(Int_val(pid_req), &status, cv_flags, &ru); + caml_leave_blocking_section(); + if (pid == -1) uerror("wait4", Nothing); + + times = alloc_small(2 * Double_wosize, Double_array_tag); + Store_double_field(times, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6); + Store_double_field(times, 1, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6); + + res = caml_alloc_tuple(3); + Store_field(res, 0, Val_int(pid)); + Store_field(res, 1, alloc_process_status(status)); + Store_field(res, 2, times); + CAMLreturn(res); +} + +value lwt_unix_has_wait4(value unit) +{ + return Val_int(1); +} + +/* +-----------------------------------------------------------------+ + | CPUs | + +-----------------------------------------------------------------+ */ + +#if defined(HAVE_GETCPU) + +CAMLprim value lwt_unix_get_cpu() +{ + int cpu = sched_getcpu(); + if (cpu < 0) uerror("sched_getcpu", Nothing); + return Val_int(cpu); +} + +#endif + +#if defined(HAVE_AFFINITY) + +CAMLprim value lwt_unix_get_affinity(value val_pid) +{ + CAMLparam1(val_pid); + CAMLlocal2(list, node); + cpu_set_t cpus; + if (sched_getaffinity(Int_val(val_pid), sizeof(cpu_set_t), &cpus) < 0) + uerror("sched_getaffinity", Nothing); + int i; + list = Val_int(0); + for (i = sizeof(cpu_set_t) * 8 - 1; i >= 0; i--) { + if (CPU_ISSET(i, &cpus)) { + node = caml_alloc_tuple(2); + Field(node, 0) = Val_int(i); + Field(node, 1) = list; + list = node; + } + } + CAMLreturn(list); +} + +CAMLprim value lwt_unix_set_affinity(value val_pid, value val_cpus) +{ + cpu_set_t cpus; + CPU_ZERO(&cpus); + for (; Is_block(val_cpus); val_cpus = Field(val_cpus, 1)) + CPU_SET(Int_val(Field(val_cpus, 0)), &cpus); + if (sched_setaffinity(Int_val(val_pid), sizeof(cpu_set_t), &cpus) < 0) + uerror("sched_setaffinity", Nothing); + return Val_unit; +} + +#endif + +/* +-----------------------------------------------------------------+ + | JOB: guess_blocking | + +-----------------------------------------------------------------+ */ + +struct job_guess_blocking { + struct lwt_unix_job job; + int fd; + int result; +}; + +#define Job_guess_blocking_val(v) *(struct job_guess_blocking**)Data_custom_val(v) + +static void worker_guess_blocking(struct job_guess_blocking *job) +{ + struct stat stat; + if (fstat(job->fd, &stat) == 0) + job->result = !(S_ISFIFO(stat.st_mode) || S_ISSOCK(stat.st_mode)); + else + job->result = 1; +} + +CAMLprim value lwt_unix_guess_blocking_job(value val_fd) +{ + struct job_guess_blocking *job = lwt_unix_new(struct job_guess_blocking); + job->job.worker = (lwt_unix_job_worker)worker_guess_blocking; + job->fd = Int_val(val_fd); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_guess_blocking_result(value val_job) +{ + struct job_guess_blocking *job = Job_guess_blocking_val(val_job); + return Bool_val(job->result); +} + +CAMLprim value lwt_unix_guess_blocking_free(value val_job) +{ + struct job_guess_blocking *job = Job_guess_blocking_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: wait_mincore | + +-----------------------------------------------------------------+ */ + +struct job_wait_mincore { + struct lwt_unix_job job; + char *ptr; +}; + +#define Job_wait_mincore_val(v) *(struct job_wait_mincore**)Data_custom_val(v) + +static void worker_wait_mincore(struct job_wait_mincore *job) +{ + /* Read the byte to force the kernel to fetch the page: */ + char dummy; + memcpy(&dummy, job->ptr, 1); +} + +CAMLprim value lwt_unix_wait_mincore_job(value val_buffer, value val_offset) +{ + struct job_wait_mincore *job = lwt_unix_new(struct job_wait_mincore); + job->job.worker = (lwt_unix_job_worker)worker_wait_mincore; + job->ptr = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_wait_mincore_free(value val_job) +{ + struct job_wait_mincore *job = Job_wait_mincore_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: open | + +-----------------------------------------------------------------+ */ + +#ifndef O_NONBLOCK +#define O_NONBLOCK O_NDELAY +#endif +#ifndef O_DSYNC +#define O_DSYNC 0 +#endif +#ifndef O_SYNC +#define O_SYNC 0 +#endif +#ifndef O_RSYNC +#define O_RSYNC 0 +#endif + +static int open_flag_table[] = { + O_RDONLY, + O_WRONLY, + O_RDWR, + O_NONBLOCK, + O_APPEND, + O_CREAT, + O_TRUNC, + O_EXCL, + O_NOCTTY, + O_DSYNC, + O_SYNC, + O_RSYNC +}; + +struct job_open { + struct lwt_unix_job job; + char *path; + int flags; + int perms; + int fd; + int blocking; + int error_code; +}; + +#define Job_open_val(v) *(struct job_open**)Data_custom_val(v) + +static void worker_open(struct job_open *job) +{ + int fd; + fd = open(job->path, job->flags, job->perms); + job->fd = fd; + job->error_code = errno; + if (fd >= 0) { + struct stat stat; + if (fstat(fd, &stat) < 0) + job->blocking = 1; + else + job->blocking = !(S_ISFIFO(stat.st_mode) || S_ISSOCK(stat.st_mode)); + } +} + +CAMLprim value lwt_unix_open_job(value val_path, value val_flags, value val_perms) +{ + struct job_open *job = lwt_unix_new(struct job_open); + job->job.worker = (lwt_unix_job_worker)worker_open; + job->path = lwt_unix_strdup(String_val(val_path)); + job->flags = convert_flag_list(val_flags, open_flag_table); + job->perms = Int_val(val_perms); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_open_result(value val_job) +{ + struct job_open *job = Job_open_val(val_job); + int fd = job->fd; + if (fd < 0) unix_error(job->error_code, "open", Nothing); + value result = caml_alloc_tuple(2); + Field(result, 0) = Val_int(fd); + Field(result, 1) = Val_bool(job->blocking); + return result; +} + +CAMLprim value lwt_unix_open_free(value val_job) +{ + struct job_open *job = Job_open_val(val_job); + free(job->path); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: close | + +-----------------------------------------------------------------+ */ + +struct job_close { + struct lwt_unix_job job; + int fd; + int result; + int error_code; +}; + +#define Job_close_val(v) *(struct job_close**)Data_custom_val(v) + +static void worker_close(struct job_close *job) +{ + job->result = close(job->fd); + job->error_code = errno; +} + +CAMLprim value lwt_unix_close_job(value val_fd) +{ + struct job_close *job = lwt_unix_new(struct job_close); + job->job.worker = (lwt_unix_job_worker)worker_close; + job->fd = Int_val(val_fd); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_close_result(value val_job) +{ + struct job_close *job = Job_close_val(val_job); + if (job->result < 0) unix_error(job->error_code, "close", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_close_free(value val_job) +{ + lwt_unix_free_job(&(Job_close_val(val_job))->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: read | + +-----------------------------------------------------------------+ */ + +struct job_read { + struct lwt_unix_job job; + int fd; + char *buffer; + int length; + int result; + int error_code; +}; + +#define Job_read_val(v) *(struct job_read**)Data_custom_val(v) + +static void worker_read(struct job_read *job) +{ + job->result = read(job->fd, job->buffer, job->length); + job->error_code = errno; +} + +CAMLprim value lwt_unix_read_job(value val_fd, value val_length) +{ + struct job_read *job = lwt_unix_new(struct job_read); + long length = Long_val(val_length); + job->job.worker = (lwt_unix_job_worker)worker_read; + job->fd = Int_val(val_fd); + job->buffer = (char*)lwt_unix_malloc(length); + job->length = length; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_read_result(value val_job, value val_string, value val_offset) +{ + struct job_read *job = Job_read_val(val_job); + int result = job->result; + if (result < 0) unix_error(job->error_code, "read", Nothing); + memcpy(String_val(val_string) + Long_val(val_offset), job->buffer, result); + return Val_long(result); +} + +CAMLprim value lwt_unix_read_free(value val_job) +{ + struct job_read *job = Job_read_val(val_job); + free(job->buffer); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: bytes_read | + +-----------------------------------------------------------------+ */ + +struct job_bytes_read { + struct lwt_unix_job job; + int fd; + char *buffer; + int length; + int result; + int error_code; +}; + +#define Job_bytes_read_val(v) *(struct job_bytes_read**)Data_custom_val(v) + +static void worker_bytes_read(struct job_bytes_read *job) +{ + job->result = read(job->fd, job->buffer, job->length); + job->error_code = errno; +} + +CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buf, value val_ofs, value val_len) +{ + struct job_bytes_read *job = lwt_unix_new(struct job_bytes_read); + job->job.worker = (lwt_unix_job_worker)worker_bytes_read; + job->fd = Int_val(val_fd); + job->buffer = (char*)Caml_ba_data_val(val_buf) + Long_val(val_ofs); + job->length = Long_val(val_len); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_bytes_read_result(value val_job) +{ + struct job_bytes_read *job = Job_bytes_read_val(val_job); + int result = job->result; + if (result < 0) unix_error(job->error_code, "read", Nothing); + return Val_long(result); +} + +CAMLprim value lwt_unix_bytes_read_free(value val_job) +{ + struct job_bytes_read *job = Job_bytes_read_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: write | + +-----------------------------------------------------------------+ */ + +struct job_write { + struct lwt_unix_job job; + int fd; + char *buffer; + int length; + int result; + int error_code; +}; + +#define Job_write_val(v) *(struct job_write**)Data_custom_val(v) + +static void worker_write(struct job_write *job) +{ + job->result = write(job->fd, job->buffer, job->length); + job->error_code = errno; +} + +CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length) +{ + struct job_write *job = lwt_unix_new(struct job_write); + long length = Long_val(val_length); + job->job.worker = (lwt_unix_job_worker)worker_write; + job->fd = Int_val(val_fd); + job->buffer = (char*)lwt_unix_malloc(length); + memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length); + job->length = length; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_write_result(value val_job) +{ + struct job_write *job = Job_write_val(val_job); + int result = job->result; + if (result < 0) unix_error(job->error_code, "write", Nothing); + return Val_long(result); +} + +CAMLprim value lwt_unix_write_free(value val_job) +{ + struct job_write *job = Job_write_val(val_job); + free(job->buffer); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: bytes_write | + +-----------------------------------------------------------------+ */ + +struct job_bytes_write { + struct lwt_unix_job job; + int fd; + char *buffer; + int length; + int result; + int error_code; +}; + +#define Job_bytes_write_val(v) *(struct job_bytes_write**)Data_custom_val(v) + +static void worker_bytes_write(struct job_bytes_write *job) +{ + job->result = write(job->fd, job->buffer, job->length); + job->error_code = errno; +} + +CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length) +{ + struct job_bytes_write *job = lwt_unix_new(struct job_bytes_write); + job->job.worker = (lwt_unix_job_worker)worker_bytes_write; + job->fd = Int_val(val_fd); + job->buffer = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); + job->length = Long_val(val_length); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_bytes_write_result(value val_job) +{ + struct job_bytes_write *job = Job_bytes_write_val(val_job); + int result = job->result; + if (result < 0) unix_error(job->error_code, "write", Nothing); + return Val_long(result); +} + +CAMLprim value lwt_unix_bytes_write_free(value val_job) +{ + struct job_bytes_write *job = Job_bytes_write_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: lseek | + +-----------------------------------------------------------------+ */ + +struct job_lseek { + struct lwt_unix_job job; + int fd; + off_t offset; + int command; + off_t result; + int error_code; +}; + +#define Job_lseek_val(v) *(struct job_lseek**)Data_custom_val(v) + +static int seek_command_table[] = { + SEEK_SET, SEEK_CUR, SEEK_END +}; + +static void worker_lseek(struct job_lseek *job) +{ + job->result = lseek(job->fd, job->offset, job->command); + job->error_code = errno; +} + +CAMLprim value lwt_unix_lseek_job(value val_fd, value val_offset, value val_command) +{ + struct job_lseek *job = lwt_unix_new(struct job_lseek); + job->job.worker = (lwt_unix_job_worker)worker_lseek; + job->fd = Int_val(val_fd); + job->offset = Long_val(val_offset); + job->command = seek_command_table[Int_val(val_command)]; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_lseek_result(value val_job) +{ + struct job_lseek *job = Job_lseek_val(val_job); + off_t result = job->result; + if (result < 0) unix_error(job->error_code, "lseek", Nothing); + return Val_long(result); +} + +CAMLprim value lwt_unix_lseek_free(value val_job) +{ + struct job_lseek *job = Job_lseek_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +CAMLprim value lwt_unix_lseek_64_job(value val_fd, value val_offset, value val_command) +{ + struct job_lseek *job = lwt_unix_new(struct job_lseek); + job->job.worker = (lwt_unix_job_worker)worker_lseek; + job->fd = Int_val(val_fd); + job->offset = Int64_val(val_offset); + job->command = seek_command_table[Int_val(val_command)]; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_lseek_64_result(value val_job) +{ + struct job_lseek *job = Job_lseek_val(val_job); + off_t result = job->result; + if (result < 0) unix_error(job->error_code, "lseek", Nothing); + return caml_copy_int64(result); +} + +CAMLprim value lwt_unix_lseek_64_free(value val_job) +{ + struct job_lseek *job = Job_lseek_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: truncate | + +-----------------------------------------------------------------+ */ + +struct job_truncate { + struct lwt_unix_job job; + char *name; + off_t offset; + int result; + int error_code; +}; + +#define Job_truncate_val(v) *(struct job_truncate**)Data_custom_val(v) + +static void worker_truncate(struct job_truncate *job) +{ + job->result = truncate(job->name, job->offset); + job->error_code = errno; +} + +CAMLprim value lwt_unix_truncate_job(value val_name, value val_offset) +{ + struct job_truncate *job = lwt_unix_new(struct job_truncate); + job->job.worker = (lwt_unix_job_worker)worker_truncate; + job->name = lwt_unix_strdup(String_val(val_name)); + job->offset = Long_val(val_offset); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_truncate_result(value val_job) +{ + struct job_truncate *job = Job_truncate_val(val_job); + if (job->result < 0) unix_error(job->error_code, "truncate", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_truncate_free(value val_job) +{ + struct job_truncate *job = Job_truncate_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +CAMLprim value lwt_unix_truncate_64_job(value val_name, value val_offset) +{ + struct job_truncate *job = lwt_unix_new(struct job_truncate); + job->job.worker = (lwt_unix_job_worker)worker_truncate; + job->name = lwt_unix_strdup(String_val(val_name)); + job->offset = Int64_val(val_offset); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_truncate_64_result(value val_job) +{ + struct job_truncate *job = Job_truncate_val(val_job); + if (job->result < 0) unix_error(job->error_code, "truncate", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_truncate_64_free(value val_job) +{ + struct job_truncate *job = Job_truncate_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: ftruncate | + +-----------------------------------------------------------------+ */ + +struct job_ftruncate { + struct lwt_unix_job job; + int fd; + off_t offset; + int result; + int error_code; +}; + +#define Job_ftruncate_val(v) *(struct job_ftruncate**)Data_custom_val(v) + +static void worker_ftruncate(struct job_ftruncate *job) +{ + job->result = ftruncate(job->fd, job->offset); + job->error_code = errno; +} + +CAMLprim value lwt_unix_ftruncate_job(value val_fd, value val_offset) +{ + struct job_ftruncate *job = lwt_unix_new(struct job_ftruncate); + job->job.worker = (lwt_unix_job_worker)worker_ftruncate; + job->fd = Int_val(val_fd); + job->offset = Long_val(val_offset); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_ftruncate_result(value val_job) +{ + struct job_ftruncate *job = Job_ftruncate_val(val_job); + if (job->result < 0) unix_error(job->error_code, "ftruncate", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_ftruncate_free(value val_job) +{ + struct job_ftruncate *job = Job_ftruncate_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +CAMLprim value lwt_unix_ftruncate_64_job(value val_fd, value val_offset) +{ + struct job_ftruncate *job = lwt_unix_new(struct job_ftruncate); + job->job.worker = (lwt_unix_job_worker)worker_ftruncate; + job->fd = Int_val(val_fd); + job->offset = Int64_val(val_offset); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_ftruncate_64_result(value val_job) +{ + struct job_ftruncate *job = Job_ftruncate_val(val_job); + if (job->result < 0) unix_error(job->error_code, "ftruncate", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_ftruncate_64_free(value val_job) +{ + struct job_ftruncate *job = Job_ftruncate_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: fsync | + +-----------------------------------------------------------------+ */ + +struct job_fsync { + struct lwt_unix_job job; + int fd; + int result; + int error_code; +}; + +#define Job_fsync_val(v) *(struct job_fsync**)Data_custom_val(v) + +static void worker_fsync(struct job_fsync *job) +{ + job->result = fsync(job->fd); + job->error_code = errno; +} + +CAMLprim value lwt_unix_fsync_job(value val_fd) +{ + struct job_fsync *job = lwt_unix_new(struct job_fsync); + job->job.worker = (lwt_unix_job_worker)worker_fsync; + job->fd = Int_val(val_fd); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_fsync_result(value val_job) +{ + struct job_fsync *job = Job_fsync_val(val_job); + if (job->result < 0) unix_error(job->error_code, "fsync", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_fsync_free(value val_job) +{ + struct job_fsync *job = Job_fsync_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +#if defined(HAVE_FDATASYNC) + +/* +-----------------------------------------------------------------+ + | JOB: fdatasync | + +-----------------------------------------------------------------+ */ + +struct job_fdatasync { + struct lwt_unix_job job; + int fd; + int result; + int error_code; +}; + +#define Job_fdatasync_val(v) *(struct job_fdatasync**)Data_custom_val(v) + +static void worker_fdatasync(struct job_fdatasync *job) +{ + job->result = fdatasync(job->fd); + job->error_code = errno; +} + +CAMLprim value lwt_unix_fdatasync_job(value val_fd) +{ + struct job_fdatasync *job = lwt_unix_new(struct job_fdatasync); + job->job.worker = (lwt_unix_job_worker)worker_fdatasync; + job->fd = Int_val(val_fd); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_fdatasync_result(value val_job) +{ + struct job_fdatasync *job = Job_fdatasync_val(val_job); + if (job->result < 0) unix_error(job->error_code, "fdatasync", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_fdatasync_free(value val_job) +{ + struct job_fdatasync *job = Job_fdatasync_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +#endif + +/* +-----------------------------------------------------------------+ + | JOB: stat | + +-----------------------------------------------------------------+ */ + +struct job_stat { + struct lwt_unix_job job; + char *name; + struct stat stat; + int result; + int error_code; +}; + +#define Job_stat_val(v) *(struct job_stat**)Data_custom_val(v) + +static value copy_stat(int use_64, struct stat *buf) +{ + CAMLparam0(); + CAMLlocal5(atime, mtime, ctime, offset, v); + + atime = copy_double((double) buf->st_atime); + mtime = copy_double((double) buf->st_mtime); + ctime = copy_double((double) buf->st_ctime); + offset = use_64 ? caml_copy_int64(buf->st_size) : Val_int(buf->st_size); + v = alloc_small(12, 0); + Field(v, 0) = Val_int (buf->st_dev); + Field(v, 1) = Val_int (buf->st_ino); + switch (buf->st_mode & S_IFMT) { + case S_IFREG: + Field(v, 2) = Val_int(0); + break; + case S_IFDIR: + Field(v, 2) = Val_int(1); + break; + case S_IFCHR: + Field(v, 2) = Val_int(2); + break; + case S_IFBLK: + Field(v, 2) = Val_int(3); + break; + case S_IFLNK: + Field(v, 2) = Val_int(4); + break; + case S_IFIFO: + Field(v, 2) = Val_int(5); + break; + case S_IFSOCK: + Field(v, 2) = Val_int(6); + break; + default: + Field(v, 2) = Val_int(0); + break; + } + Field(v, 3) = Val_int(buf->st_mode & 07777); + Field(v, 4) = Val_int(buf->st_nlink); + Field(v, 5) = Val_int(buf->st_uid); + Field(v, 6) = Val_int(buf->st_gid); + Field(v, 7) = Val_int(buf->st_rdev); + Field(v, 8) = offset; + Field(v, 9) = atime; + Field(v, 10) = mtime; + Field(v, 11) = ctime; + CAMLreturn(v); +} + +static void worker_stat(struct job_stat *job) +{ + job->result = stat(job->name, &(job->stat)); + job->error_code = errno; +} + +CAMLprim value lwt_unix_stat_job(value val_name) +{ + struct job_stat *job = lwt_unix_new(struct job_stat); + job->job.worker = (lwt_unix_job_worker)worker_stat; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_stat_result(value val_job) +{ + struct job_stat *job = Job_stat_val(val_job); + if (job->result < 0) unix_error(job->error_code, "stat", Nothing); + return copy_stat(0, &(job->stat)); +} + +CAMLprim value lwt_unix_stat_free(value val_job) +{ + struct job_stat *job = Job_stat_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +CAMLprim value lwt_unix_stat_64_job(value val_name) +{ + struct job_stat *job = lwt_unix_new(struct job_stat); + job->job.worker = (lwt_unix_job_worker)worker_stat; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_stat_64_result(value val_job) +{ + struct job_stat *job = Job_stat_val(val_job); + if (job->result < 0) unix_error(job->error_code, "stat", Nothing); + return copy_stat(1, &(job->stat)); +} + +CAMLprim value lwt_unix_stat_64_free(value val_job) +{ + struct job_stat *job = Job_stat_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: lstat | + +-----------------------------------------------------------------+ */ + +struct job_lstat { + struct lwt_unix_job job; + char *name; + struct stat lstat; + int result; + int error_code; +}; + +#define Job_lstat_val(v) *(struct job_lstat**)Data_custom_val(v) + +static void worker_lstat(struct job_lstat *job) +{ + job->result = lstat(job->name, &(job->lstat)); + job->error_code = errno; +} + +CAMLprim value lwt_unix_lstat_job(value val_name) +{ + struct job_lstat *job = lwt_unix_new(struct job_lstat); + job->job.worker = (lwt_unix_job_worker)worker_lstat; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_lstat_result(value val_job) +{ + struct job_lstat *job = Job_lstat_val(val_job); + if (job->result < 0) unix_error(job->error_code, "lstat", Nothing); + return copy_stat(0, &(job->lstat)); +} + +CAMLprim value lwt_unix_lstat_free(value val_job) +{ + struct job_lstat *job = Job_lstat_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +CAMLprim value lwt_unix_lstat_64_job(value val_name) +{ + struct job_lstat *job = lwt_unix_new(struct job_lstat); + job->job.worker = (lwt_unix_job_worker)worker_lstat; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_lstat_64_result(value val_job) +{ + struct job_lstat *job = Job_lstat_val(val_job); + if (job->result < 0) unix_error(job->error_code, "lstat", Nothing); + return copy_stat(1, &(job->lstat)); +} + +CAMLprim value lwt_unix_lstat_64_free(value val_job) +{ + struct job_lstat *job = Job_lstat_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: fstat | + +-----------------------------------------------------------------+ */ + +struct job_fstat { + struct lwt_unix_job job; + int fd; + struct stat fstat; + int result; + int error_code; +}; + +#define Job_fstat_val(v) *(struct job_fstat**)Data_custom_val(v) + +static void worker_fstat(struct job_fstat *job) +{ + job->result = fstat(job->fd, &(job->fstat)); + job->error_code = errno; +} + +CAMLprim value lwt_unix_fstat_job(value val_fd) +{ + struct job_fstat *job = lwt_unix_new(struct job_fstat); + job->job.worker = (lwt_unix_job_worker)worker_fstat; + job->fd = Int_val(val_fd); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_fstat_result(value val_job) +{ + struct job_fstat *job = Job_fstat_val(val_job); + if (job->result < 0) unix_error(job->error_code, "fstat", Nothing); + return copy_stat(0, &(job->fstat)); +} + +CAMLprim value lwt_unix_fstat_free(value val_job) +{ + struct job_fstat *job = Job_fstat_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +CAMLprim value lwt_unix_fstat_64_job(value val_fd) +{ + struct job_fstat *job = lwt_unix_new(struct job_fstat); + job->job.worker = (lwt_unix_job_worker)worker_fstat; + job->fd = Int_val(val_fd); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_fstat_64_result(value val_job) +{ + struct job_fstat *job = Job_fstat_val(val_job); + if (job->result < 0) unix_error(job->error_code, "fstat", Nothing); + return copy_stat(1, &(job->fstat)); +} + +CAMLprim value lwt_unix_fstat_64_free(value val_job) +{ + struct job_fstat *job = Job_fstat_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: isatty | + +-----------------------------------------------------------------+ */ + +struct job_isatty { + struct lwt_unix_job job; + int fd; + int result; +}; + +#define Job_isatty_val(v) *(struct job_isatty**)Data_custom_val(v) + +static void worker_isatty(struct job_isatty *job) +{ + job->result = isatty(job->fd); +} + +CAMLprim value lwt_unix_isatty_job(value val_fd) +{ + struct job_isatty *job = lwt_unix_new(struct job_isatty); + job->job.worker = (lwt_unix_job_worker)worker_isatty; + job->fd = Int_val(val_fd); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_isatty_result(value val_job) +{ + struct job_isatty *job = Job_isatty_val(val_job); + return Val_bool(job->result); +} + +CAMLprim value lwt_unix_isatty_free(value val_job) +{ + struct job_isatty *job = Job_isatty_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: unlink | + +-----------------------------------------------------------------+ */ + +struct job_unlink { + struct lwt_unix_job job; + char *name; + int result; + int error_code; +}; + +#define Job_unlink_val(v) *(struct job_unlink**)Data_custom_val(v) + +static void worker_unlink(struct job_unlink *job) +{ + job->result = unlink(job->name); + job->error_code = errno; +} + +CAMLprim value lwt_unix_unlink_job(value val_name) +{ + struct job_unlink *job = lwt_unix_new(struct job_unlink); + job->job.worker = (lwt_unix_job_worker)worker_unlink; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_unlink_result(value val_job) +{ + struct job_unlink *job = Job_unlink_val(val_job); + if (job->result < 0) unix_error(job->error_code, "unlink", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_unlink_free(value val_job) +{ + struct job_unlink *job = Job_unlink_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: rename | + +-----------------------------------------------------------------+ */ + +struct job_rename { + struct lwt_unix_job job; + char *name1; + char *name2; + int result; + int error_code; +}; + +#define Job_rename_val(v) *(struct job_rename**)Data_custom_val(v) + +static void worker_rename(struct job_rename *job) +{ + job->result = rename(job->name1, job->name2); + job->error_code = errno; +} + +CAMLprim value lwt_unix_rename_job(value val_name1, value val_name2) +{ + struct job_rename *job = lwt_unix_new(struct job_rename); + job->job.worker = (lwt_unix_job_worker)worker_rename; + job->name1 = lwt_unix_strdup(String_val(val_name1)); + job->name2 = lwt_unix_strdup(String_val(val_name2)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_rename_result(value val_job) +{ + struct job_rename *job = Job_rename_val(val_job); + if (job->result < 0) unix_error(job->error_code, "rename", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_rename_free(value val_job) +{ + struct job_rename *job = Job_rename_val(val_job); + free(job->name1); + free(job->name2); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: link | + +-----------------------------------------------------------------+ */ + +struct job_link { + struct lwt_unix_job job; + char *name1; + char *name2; + int result; + int error_code; +}; + +#define Job_link_val(v) *(struct job_link**)Data_custom_val(v) + +static void worker_link(struct job_link *job) +{ + job->result = link(job->name1, job->name2); + job->error_code = errno; +} + +CAMLprim value lwt_unix_link_job(value val_name1, value val_name2) +{ + struct job_link *job = lwt_unix_new(struct job_link); + job->job.worker = (lwt_unix_job_worker)worker_link; + job->name1 = lwt_unix_strdup(String_val(val_name1)); + job->name2 = lwt_unix_strdup(String_val(val_name2)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_link_result(value val_job) +{ + struct job_link *job = Job_link_val(val_job); + if (job->result < 0) unix_error(job->error_code, "link", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_link_free(value val_job) +{ + struct job_link *job = Job_link_val(val_job); + free(job->name1); + free(job->name2); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: chmod | + +-----------------------------------------------------------------+ */ + +struct job_chmod { + struct lwt_unix_job job; + char *name; + int perms; + int result; + int error_code; +}; + +#define Job_chmod_val(v) *(struct job_chmod**)Data_custom_val(v) + +static void worker_chmod(struct job_chmod *job) +{ + job->result = chmod(job->name, job->perms); + job->error_code = errno; +} + +CAMLprim value lwt_unix_chmod_job(value val_name, value val_perms) +{ + struct job_chmod *job = lwt_unix_new(struct job_chmod); + job->job.worker = (lwt_unix_job_worker)worker_chmod; + job->name = lwt_unix_strdup(String_val(val_name)); + job->perms = Int_val(val_perms); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_chmod_result(value val_job) +{ + struct job_chmod *job = Job_chmod_val(val_job); + if (job->result < 0) unix_error(job->error_code, "chmod", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_chmod_free(value val_job) +{ + struct job_chmod *job = Job_chmod_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: fchmod | + +-----------------------------------------------------------------+ */ + +struct job_fchmod { + struct lwt_unix_job job; + int fd; + int perms; + int result; + int error_code; +}; + +#define Job_fchmod_val(v) *(struct job_fchmod**)Data_custom_val(v) + +static void worker_fchmod(struct job_fchmod *job) +{ + job->result = fchmod(job->fd, job->perms); + job->error_code = errno; +} + +CAMLprim value lwt_unix_fchmod_job(value val_fd, value val_perms) +{ + struct job_fchmod *job = lwt_unix_new(struct job_fchmod); + job->job.worker = (lwt_unix_job_worker)worker_fchmod; + job->fd = Int_val(val_fd); + job->perms = Int_val(val_perms); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_fchmod_result(value val_job) +{ + struct job_fchmod *job = Job_fchmod_val(val_job); + if (job->result < 0) unix_error(job->error_code, "fchmod", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_fchmod_free(value val_job) +{ + struct job_fchmod *job = Job_fchmod_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: chown | + +-----------------------------------------------------------------+ */ + +struct job_chown { + struct lwt_unix_job job; + char *name; + int uid; + int gid; + int result; + int error_code; +}; + +#define Job_chown_val(v) *(struct job_chown**)Data_custom_val(v) + +static void worker_chown(struct job_chown *job) +{ + job->result = chown(job->name, job->uid, job->gid); + job->error_code = errno; +} + +CAMLprim value lwt_unix_chown_job(value val_name, value val_uid, value val_gid) +{ + struct job_chown *job = lwt_unix_new(struct job_chown); + job->job.worker = (lwt_unix_job_worker)worker_chown; + job->name = lwt_unix_strdup(String_val(val_name)); + job->uid = Int_val(val_uid); + job->gid = Int_val(val_gid); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_chown_result(value val_job) +{ + struct job_chown *job = Job_chown_val(val_job); + if (job->result < 0) unix_error(job->error_code, "chown", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_chown_free(value val_job) +{ + struct job_chown *job = Job_chown_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: fchown | + +-----------------------------------------------------------------+ */ + +struct job_fchown { + struct lwt_unix_job job; + int fd; + int uid; + int gid; + int result; + int error_code; +}; + +#define Job_fchown_val(v) *(struct job_fchown**)Data_custom_val(v) + +static void worker_fchown(struct job_fchown *job) +{ + job->result = fchown(job->fd, job->uid, job->gid); + job->error_code = errno; +} + +CAMLprim value lwt_unix_fchown_job(value val_fd, value val_uid, value val_gid) +{ + struct job_fchown *job = lwt_unix_new(struct job_fchown); + job->job.worker = (lwt_unix_job_worker)worker_fchown; + job->fd = Int_val(val_fd); + job->uid = Int_val(val_uid); + job->gid = Int_val(val_gid); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_fchown_result(value val_job) +{ + struct job_fchown *job = Job_fchown_val(val_job); + if (job->result < 0) unix_error(job->error_code, "fchown", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_fchown_free(value val_job) +{ + struct job_fchown *job = Job_fchown_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: access | + +-----------------------------------------------------------------+ */ + +struct job_access { + struct lwt_unix_job job; + char *name; + int mode; + int result; + int error_code; +}; + +#define Job_access_val(v) *(struct job_access**)Data_custom_val(v) + +static int access_permission_table[] = { + R_OK, W_OK, X_OK, F_OK +}; + +static void worker_access(struct job_access *job) +{ + job->result = access(job->name, job->mode); + job->error_code = errno; +} + +CAMLprim value lwt_unix_access_job(value val_name, value val_perms) +{ + struct job_access *job = lwt_unix_new(struct job_access); + job->job.worker = (lwt_unix_job_worker)worker_access; + job->name = lwt_unix_strdup(String_val(val_name)); + job->mode = convert_flag_list(val_perms, access_permission_table); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_access_result(value val_job) +{ + struct job_access *job = Job_access_val(val_job); + if (job->result < 0) unix_error(job->error_code, "access", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_access_free(value val_job) +{ + struct job_access *job = Job_access_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: mkdir | + +-----------------------------------------------------------------+ */ + +struct job_mkdir { + struct lwt_unix_job job; + char *name; + int perms; + int result; + int error_code; +}; + +#define Job_mkdir_val(v) *(struct job_mkdir**)Data_custom_val(v) + +static void worker_mkdir(struct job_mkdir *job) +{ + job->result = mkdir(job->name, job->perms); + job->error_code = errno; +} + +CAMLprim value lwt_unix_mkdir_job(value val_name, value val_perms) +{ + struct job_mkdir *job = lwt_unix_new(struct job_mkdir); + job->job.worker = (lwt_unix_job_worker)worker_mkdir; + job->name = lwt_unix_strdup(String_val(val_name)); + job->perms = Int_val(val_perms); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_mkdir_result(value val_job) +{ + struct job_mkdir *job = Job_mkdir_val(val_job); + if (job->result < 0) unix_error(job->error_code, "mkdir", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_mkdir_free(value val_job) +{ + struct job_mkdir *job = Job_mkdir_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: rmdir | + +-----------------------------------------------------------------+ */ + +struct job_rmdir { + struct lwt_unix_job job; + char *name; + int result; + int error_code; +}; + +#define Job_rmdir_val(v) *(struct job_rmdir**)Data_custom_val(v) + +static void worker_rmdir(struct job_rmdir *job) +{ + job->result = rmdir(job->name); + job->error_code = errno; +} + +CAMLprim value lwt_unix_rmdir_job(value val_name) +{ + struct job_rmdir *job = lwt_unix_new(struct job_rmdir); + job->job.worker = (lwt_unix_job_worker)worker_rmdir; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_rmdir_result(value val_job) +{ + struct job_rmdir *job = Job_rmdir_val(val_job); + if (job->result < 0) unix_error(job->error_code, "rmdir", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_rmdir_free(value val_job) +{ + struct job_rmdir *job = Job_rmdir_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: chdir | + +-----------------------------------------------------------------+ */ + +struct job_chdir { + struct lwt_unix_job job; + char *name; + int result; + int error_code; +}; + +#define Job_chdir_val(v) *(struct job_chdir**)Data_custom_val(v) + +static void worker_chdir(struct job_chdir *job) +{ + job->result = chdir(job->name); + job->error_code = errno; +} + +CAMLprim value lwt_unix_chdir_job(value val_name) +{ + struct job_chdir *job = lwt_unix_new(struct job_chdir); + job->job.worker = (lwt_unix_job_worker)worker_chdir; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_chdir_result(value val_job) +{ + struct job_chdir *job = Job_chdir_val(val_job); + if (job->result < 0) unix_error(job->error_code, "chdir", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_chdir_free(value val_job) +{ + struct job_chdir *job = Job_chdir_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: chroot | + +-----------------------------------------------------------------+ */ + +struct job_chroot { + struct lwt_unix_job job; + char *name; + int result; + int error_code; +}; + +#define Job_chroot_val(v) *(struct job_chroot**)Data_custom_val(v) + +static void worker_chroot(struct job_chroot *job) +{ + job->result = chroot(job->name); + job->error_code = errno; +} + +CAMLprim value lwt_unix_chroot_job(value val_name) +{ + struct job_chroot *job = lwt_unix_new(struct job_chroot); + job->job.worker = (lwt_unix_job_worker)worker_chroot; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_chroot_result(value val_job) +{ + struct job_chroot *job = Job_chroot_val(val_job); + if (job->result < 0) unix_error(job->error_code, "chroot", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_chroot_free(value val_job) +{ + struct job_chroot *job = Job_chroot_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: opendir | + +-----------------------------------------------------------------+ */ + +struct job_opendir { + struct lwt_unix_job job; + char *name; + DIR *result; + int error_code; +}; + +#define Job_opendir_val(v) *(struct job_opendir**)Data_custom_val(v) + +static void worker_opendir(struct job_opendir *job) +{ + job->result = opendir(job->name); + job->error_code = errno; +} + +CAMLprim value lwt_unix_opendir_job(value val_name) +{ + struct job_opendir *job = lwt_unix_new(struct job_opendir); + job->job.worker = (lwt_unix_job_worker)worker_opendir; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_opendir_result(value val_job) +{ + struct job_opendir *job = Job_opendir_val(val_job); + if (job->result == NULL) unix_error(job->error_code, "opendir", Nothing); + value result = alloc_small(1, Abstract_tag); + DIR_Val(result) = job->result; + return result; +} + +CAMLprim value lwt_unix_opendir_free(value val_job) +{ + struct job_opendir *job = Job_opendir_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: readdir | + +-----------------------------------------------------------------+ */ + +struct job_readdir { + struct lwt_unix_job job; + DIR *dir; + struct dirent *entry; + struct dirent *ptr; + int result; +}; + +#define Job_readdir_val(v) *(struct job_readdir**)Data_custom_val(v) + +static void worker_readdir(struct job_readdir *job) +{ + job->entry = lwt_unix_malloc(offsetof(struct dirent, d_name) + fpathconf(dirfd(job->dir), _PC_NAME_MAX) + 1); + job->result = readdir_r(job->dir, job->entry, &(job->ptr)); +} + +CAMLprim value lwt_unix_readdir_job(value val_dir) +{ + struct job_readdir *job = lwt_unix_new(struct job_readdir); + job->job.worker = (lwt_unix_job_worker)worker_readdir; + job->dir = DIR_Val(val_dir); + job->entry = NULL; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_readdir_result(value val_job) +{ + struct job_readdir *job = Job_readdir_val(val_job); + if (job->result != 0) unix_error(job->result, "readdir", Nothing); + if (job->ptr == NULL) caml_raise_end_of_file(); + return caml_copy_string(job->entry->d_name); +} + +CAMLprim value lwt_unix_readdir_free(value val_job) +{ + struct job_readdir *job = Job_readdir_val(val_job); + if (job->entry != NULL) free(job->entry); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: readdir_n | + +-----------------------------------------------------------------+ */ + +struct job_readdir_n { + struct lwt_unix_job job; + DIR *dir; + int count; + int error_code; + struct dirent *entries[]; +}; + +#define Job_readdir_n_val(v) *(struct job_readdir_n**)Data_custom_val(v) + +static void worker_readdir_n(struct job_readdir_n *job) +{ + size_t size = offsetof(struct dirent, d_name) + fpathconf(dirfd(job->dir), _PC_NAME_MAX) + 1; + int i; + for(i = 0; i < job->count; i++) { + struct dirent *ptr; + struct dirent *entry = (struct dirent *)lwt_unix_malloc(size); + + int result = readdir_r(job->dir, entry, &ptr); + + /* An error happened. */ + if (result != 0) { + /* Free already read entries. */ + free(entry); + int j; + for(j = 0; j < i; j++) free(job->entries[j]); + /* Return an error. */ + job->error_code = result; + return; + } + + /* End of directory reached */ + if (ptr == NULL) { + free(entry); + break; + } + + job->entries[i] = entry; + } + + job->count = i; + job->error_code = 0; +} + +CAMLprim value lwt_unix_readdir_n_job(value val_dir, value val_count) +{ + int count = Int_val(val_count); + struct job_readdir_n *job = (struct job_readdir_n *)lwt_unix_malloc(sizeof(struct job_readdir_n) + sizeof(struct dirent*) * count); + job->job.worker = (lwt_unix_job_worker)worker_readdir_n; + job->dir = DIR_Val(val_dir); + job->count = count; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_readdir_n_result(value val_job) +{ + CAMLparam1(val_job); + CAMLlocal1(result); + struct job_readdir_n *job = Job_readdir_n_val(val_job); + if (job->error_code != 0) unix_error(job->error_code, "readdir_n", Nothing); + + result = caml_alloc(job->count, 0); + int i; + for(i = 0; i < job->count; i++) { + Store_field(result, i, caml_copy_string(job->entries[i]->d_name)); + free(job->entries[i]); + job->entries[i] = NULL; + } + job->count = 0; + CAMLreturn(result); +} + +CAMLprim value lwt_unix_readdir_n_free(value val_job) +{ + struct job_readdir_n *job = Job_readdir_n_val(val_job); + if (job->error_code == 0) { + int i; + for(i = 0; i < job->count; i++) + if (job->entries[i] != NULL) free(job->entries[i]); + } + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: rewinddir | + +-----------------------------------------------------------------+ */ + +struct job_rewinddir { + struct lwt_unix_job job; + DIR *dir; +}; + +#define Job_rewinddir_val(v) *(struct job_rewinddir**)Data_custom_val(v) + +static void worker_rewinddir(struct job_rewinddir *job) +{ + rewinddir(job->dir); +} + +CAMLprim value lwt_unix_rewinddir_job(value val_dir) +{ + struct job_rewinddir *job = lwt_unix_new(struct job_rewinddir); + job->job.worker = (lwt_unix_job_worker)worker_rewinddir; + job->dir = DIR_Val(val_dir); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_rewinddir_result(value val_job) +{ + return Val_unit; +} + +CAMLprim value lwt_unix_rewinddir_free(value val_job) +{ + struct job_rewinddir *job = Job_rewinddir_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: closedir | + +-----------------------------------------------------------------+ */ + +struct job_closedir { + struct lwt_unix_job job; + DIR *dir; + int result; + int error_code; +}; + +#define Job_closedir_val(v) *(struct job_closedir**)Data_custom_val(v) + +static void worker_closedir(struct job_closedir *job) +{ + job->result = closedir(job->dir); + job->error_code = errno; +} + +CAMLprim value lwt_unix_closedir_job(value val_dir) +{ + struct job_closedir *job = lwt_unix_new(struct job_closedir); + job->job.worker = (lwt_unix_job_worker)worker_closedir; + job->dir = DIR_Val(val_dir); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_closedir_result(value val_job) +{ + struct job_closedir *job = Job_closedir_val(val_job); + if (job->result < 0) unix_error(job->error_code, "closedir", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_closedir_free(value val_job) +{ + struct job_closedir *job = Job_closedir_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: mkfifo | + +-----------------------------------------------------------------+ */ + +struct job_mkfifo { + struct lwt_unix_job job; + char *name; + int perms; + int result; + int error_code; +}; + +#define Job_mkfifo_val(v) *(struct job_mkfifo**)Data_custom_val(v) + +static void worker_mkfifo(struct job_mkfifo *job) +{ + job->result = mkfifo(job->name, job->perms); + job->error_code = errno; +} + +CAMLprim value lwt_unix_mkfifo_job(value val_name, value val_perms) +{ + struct job_mkfifo *job = lwt_unix_new(struct job_mkfifo); + job->job.worker = (lwt_unix_job_worker)worker_mkfifo; + job->name = lwt_unix_strdup(String_val(val_name)); + job->perms = Int_val(val_perms); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_mkfifo_result(value val_job) +{ + struct job_mkfifo *job = Job_mkfifo_val(val_job); + if (job->result < 0) unix_error(job->error_code, "mkfifo", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_mkfifo_free(value val_job) +{ + struct job_mkfifo *job = Job_mkfifo_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: symlink | + +-----------------------------------------------------------------+ */ + +struct job_symlink { + struct lwt_unix_job job; + char *name1; + char *name2; + int result; + int error_code; +}; + +#define Job_symlink_val(v) *(struct job_symlink**)Data_custom_val(v) + +static void worker_symlink(struct job_symlink *job) +{ + job->result = symlink(job->name1, job->name2); + job->error_code = errno; +} + +CAMLprim value lwt_unix_symlink_job(value val_name1, value val_name2) +{ + struct job_symlink *job = lwt_unix_new(struct job_symlink); + job->job.worker = (lwt_unix_job_worker)worker_symlink; + job->name1 = lwt_unix_strdup(String_val(val_name1)); + job->name2 = lwt_unix_strdup(String_val(val_name2)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_symlink_result(value val_job) +{ + struct job_symlink *job = Job_symlink_val(val_job); + if (job->result < 0) unix_error(job->error_code, "symlink", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_symlink_free(value val_job) +{ + struct job_symlink *job = Job_symlink_val(val_job); + free(job->name1); + free(job->name2); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: readlink | + +-----------------------------------------------------------------+ */ + +struct job_readlink { + struct lwt_unix_job job; + char *name; + char *buffer; + ssize_t result; + int error_code; +}; + +#define Job_readlink_val(v) *(struct job_readlink**)Data_custom_val(v) + +static void worker_readlink(struct job_readlink *job) +{ + + ssize_t buffer_size = 1024; + ssize_t link_length; + + for (;;) { + + job->buffer = lwt_unix_malloc(buffer_size); + + link_length = readlink(job->name, job->buffer, buffer_size); + + if (link_length < buffer_size) { + if (link_length >= 0) { + job->buffer = realloc(job->buffer, link_length + 1); + job->buffer[link_length] = '\0'; + } else { + free (job->buffer); + job->buffer = NULL; + } + job->result = link_length; + job->error_code = errno; + break; + } else { + free(job->buffer); + buffer_size *= 2; + } + } +} + +CAMLprim value lwt_unix_readlink_job(value val_name) +{ + struct job_readlink *job = lwt_unix_new(struct job_readlink); + job->job.worker = (lwt_unix_job_worker)worker_readlink; + job->name = lwt_unix_strdup(String_val(val_name)); + job->buffer = NULL; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_readlink_result(value val_job) +{ + struct job_readlink *job = Job_readlink_val(val_job); + if (job->result < 0) unix_error(job->error_code, "readlink", Nothing); + return caml_copy_string(job->buffer); +} + +CAMLprim value lwt_unix_readlink_free(value val_job) +{ + struct job_readlink *job = Job_readlink_val(val_job); + free(job->name); + free(job->buffer); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: lockf | + +-----------------------------------------------------------------+ */ + +struct job_lockf { + struct lwt_unix_job job; + int fd; + int command; + off_t length; + int result; + int error_code; +}; + +#define Job_lockf_val(v) *(struct job_lockf**)Data_custom_val(v) + +static int lock_command_table[] = { + F_ULOCK, F_LOCK, F_TLOCK, F_TEST, F_LOCK, F_TLOCK +}; + +static void worker_lockf(struct job_lockf *job) +{ + job->result = lockf(job->fd, job->command, job->length); + job->error_code = errno; +} + +CAMLprim value lwt_unix_lockf_job(value val_fd, value val_command, value val_length) +{ + struct job_lockf *job = lwt_unix_new(struct job_lockf); + job->job.worker = (lwt_unix_job_worker)worker_lockf; + job->fd = Int_val(val_fd); + job->command = lock_command_table[Int_val(val_command)]; + job->length = Long_val(val_length); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_lockf_result(value val_job) +{ + struct job_lockf *job = Job_lockf_val(val_job); + if (job->result < 0) unix_error(job->error_code, "lockf", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_lockf_free(value val_job) +{ + struct job_lockf *job = Job_lockf_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getlogin | + +-----------------------------------------------------------------+ */ + +struct job_getlogin { + struct lwt_unix_job job; + char buffer[1024]; + int result; +}; + +#define Job_getlogin_val(v) *(struct job_getlogin**)Data_custom_val(v) + +static void worker_getlogin(struct job_getlogin *job) +{ + job->result = getlogin_r(job->buffer, 1024); +} + +CAMLprim value lwt_unix_getlogin_job() +{ + struct job_getlogin *job = lwt_unix_new(struct job_getlogin); + job->job.worker = (lwt_unix_job_worker)worker_getlogin; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getlogin_result(value val_job) +{ + struct job_getlogin *job = Job_getlogin_val(val_job); + if (job->result != 0) unix_error(job->result, "getlogin", Nothing); + return caml_copy_string(job->buffer); +} + +CAMLprim value lwt_unix_getlogin_free(value val_job) +{ + struct job_getlogin *job = Job_getlogin_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getpwnam | + +-----------------------------------------------------------------+ */ + +struct job_getpwnam { + struct lwt_unix_job job; + char *name; + struct passwd pwd; + struct passwd *ptr; + char *buffer; + int result; +}; + +#define Job_getpwnam_val(v) *(struct job_getpwnam**)Data_custom_val(v) + +static value alloc_passwd_entry(struct passwd *entry) +{ + value res; + value name = Val_unit, passwd = Val_unit, gecos = Val_unit; + value dir = Val_unit, shell = Val_unit; + + Begin_roots5 (name, passwd, gecos, dir, shell); + name = copy_string(entry->pw_name); + passwd = copy_string(entry->pw_passwd); +#ifndef __BEOS__ + gecos = copy_string(entry->pw_gecos); +#else + gecos = copy_string(""); +#endif + dir = copy_string(entry->pw_dir); + shell = copy_string(entry->pw_shell); + res = alloc_small(7, 0); + Field(res, 0) = name; + Field(res, 1) = passwd; + Field(res, 2) = Val_int(entry->pw_uid); + Field(res, 3) = Val_int(entry->pw_gid); + Field(res, 4) = gecos; + Field(res, 5) = dir; + Field(res, 6) = shell; + End_roots(); + return res; +} + +static void worker_getpwnam(struct job_getpwnam *job) +{ + size_t buffer_size = sysconf(_SC_GETPW_R_SIZE_MAX); + if (buffer_size == (size_t) -1) buffer_size = 16384; + job->buffer = (char*)lwt_unix_malloc(buffer_size); + job->result = getpwnam_r(job->name, &(job->pwd), job->buffer, buffer_size, &(job->ptr)); +} + +CAMLprim value lwt_unix_getpwnam_job(value val_name) +{ + struct job_getpwnam *job = lwt_unix_new(struct job_getpwnam); + job->job.worker = (lwt_unix_job_worker)worker_getpwnam; + job->name = lwt_unix_strdup(String_val(val_name)); + job->buffer = NULL; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getpwnam_result(value val_job) +{ + struct job_getpwnam *job = Job_getpwnam_val(val_job); + if (job->result != 0) unix_error(job->result, "getpwnam", Nothing); + if (job->ptr == NULL) caml_raise_not_found(); + return alloc_passwd_entry(&(job->pwd)); +} + +CAMLprim value lwt_unix_getpwnam_free(value val_job) +{ + struct job_getpwnam *job = Job_getpwnam_val(val_job); + free(job->name); + if (job->buffer != NULL) free(job->buffer); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getgrnam | + +-----------------------------------------------------------------+ */ + +struct job_getgrnam { + struct lwt_unix_job job; + char *name; + struct group grp; + struct group *ptr; + char *buffer; + int result; +}; + +#define Job_getgrnam_val(v) *(struct job_getgrnam**)Data_custom_val(v) + +static value alloc_group_entry(struct group *entry) +{ + value res; + value name = Val_unit, pass = Val_unit, mem = Val_unit; + + Begin_roots3 (name, pass, mem); + name = copy_string(entry->gr_name); + pass = copy_string(entry->gr_passwd); + mem = copy_string_array((const char**)entry->gr_mem); + res = alloc_small(4, 0); + Field(res, 0) = name; + Field(res, 1) = pass; + Field(res, 2) = Val_int(entry->gr_gid); + Field(res, 3) = mem; + End_roots(); + return res; +} + +static void worker_getgrnam(struct job_getgrnam *job) +{ + size_t buffer_size = sysconf(_SC_GETGR_R_SIZE_MAX); + if (buffer_size == (size_t) -1) buffer_size = 16384; + job->buffer = (char*)lwt_unix_malloc(buffer_size); + job->result = getgrnam_r(job->name, &(job->grp), job->buffer, buffer_size, &(job->ptr)); +} + +CAMLprim value lwt_unix_getgrnam_job(value val_name) +{ + struct job_getgrnam *job = lwt_unix_new(struct job_getgrnam); + job->job.worker = (lwt_unix_job_worker)worker_getgrnam; + job->name = lwt_unix_strdup(String_val(val_name)); + job->buffer = NULL; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getgrnam_result(value val_job) +{ + struct job_getgrnam *job = Job_getgrnam_val(val_job); + if (job->result != 0) unix_error(job->result, "getgrnam", Nothing); + if (job->ptr == NULL) caml_raise_not_found(); + return alloc_group_entry(&(job->grp)); +} + +CAMLprim value lwt_unix_getgrnam_free(value val_job) +{ + struct job_getgrnam *job = Job_getgrnam_val(val_job); + free(job->name); + if (job->buffer != NULL) free(job->buffer); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getpwuid | + +-----------------------------------------------------------------+ */ + +struct job_getpwuid { + struct lwt_unix_job job; + int uid; + struct passwd pwd; + struct passwd *ptr; + char *buffer; + int result; +}; + +#define Job_getpwuid_val(v) *(struct job_getpwuid**)Data_custom_val(v) + +static void worker_getpwuid(struct job_getpwuid *job) +{ + size_t buffer_size = sysconf(_SC_GETPW_R_SIZE_MAX); + if (buffer_size == (size_t) -1) buffer_size = 16384; + job->buffer = (char*)lwt_unix_malloc(buffer_size); + job->result = getpwuid_r(job->uid, &(job->pwd), job->buffer, buffer_size, &(job->ptr)); +} + +CAMLprim value lwt_unix_getpwuid_job(value val_uid) +{ + struct job_getpwuid *job = lwt_unix_new(struct job_getpwuid); + job->job.worker = (lwt_unix_job_worker)worker_getpwuid; + job->uid = Int_val(val_uid); + job->buffer = NULL; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getpwuid_result(value val_job) +{ + struct job_getpwuid *job = Job_getpwuid_val(val_job); + if (job->result != 0) unix_error(job->result, "getpwuid", Nothing); + if (job->ptr == NULL) caml_raise_not_found(); + return alloc_passwd_entry(&(job->pwd)); +} + +CAMLprim value lwt_unix_getpwuid_free(value val_job) +{ + struct job_getpwuid *job = Job_getpwuid_val(val_job); + if (job->buffer != NULL) free(job->buffer); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getgrgid | + +-----------------------------------------------------------------+ */ + +struct job_getgrgid { + struct lwt_unix_job job; + int gid; + struct group grp; + struct group *ptr; + char *buffer; + int result; +}; + +#define Job_getgrgid_val(v) *(struct job_getgrgid**)Data_custom_val(v) + +static void worker_getgrgid(struct job_getgrgid *job) +{ + size_t buffer_size = sysconf(_SC_GETGR_R_SIZE_MAX); + if (buffer_size == (size_t) -1) buffer_size = 16384; + job->buffer = (char*)lwt_unix_malloc(buffer_size); + job->result = getgrgid_r(job->gid, &(job->grp), job->buffer, buffer_size, &(job->ptr)); +} + +CAMLprim value lwt_unix_getgrgid_job(value val_gid) +{ + struct job_getgrgid *job = lwt_unix_new(struct job_getgrgid); + job->job.worker = (lwt_unix_job_worker)worker_getgrgid; + job->gid = Int_val(val_gid); + job->buffer = NULL; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getgrgid_result(value val_job) +{ + struct job_getgrgid *job = Job_getgrgid_val(val_job); + if (job->result != 0) unix_error(job->result, "getgrgid", Nothing); + if (job->ptr == NULL) caml_raise_not_found(); + return alloc_group_entry(&(job->grp)); +} + +CAMLprim value lwt_unix_getgrgid_free(value val_job) +{ + struct job_getgrgid *job = Job_getgrgid_val(val_job); + if (job->buffer != NULL) free(job->buffer); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: gethostname | + +-----------------------------------------------------------------+ */ + +struct job_gethostname { + struct lwt_unix_job job; + char *buffer; + int result; + int error_code; +}; + +#define Job_gethostname_val(v) *(struct job_gethostname**)Data_custom_val(v) + +static void worker_gethostname(struct job_gethostname *job) +{ + int buffer_size = 64; + int err; + + for (;;) { + + job->buffer = lwt_unix_malloc(buffer_size + 1); + + err = gethostname(job->buffer, buffer_size); + + if (err == -1 && errno == ENAMETOOLONG) { + free(job->buffer); + buffer_size *= 2; + } else { + job->buffer[buffer_size] = '\0'; + job->result = err; + job->error_code = errno; + break; + } + } +} + +CAMLprim value lwt_unix_gethostname_job() +{ + struct job_gethostname *job = lwt_unix_new(struct job_gethostname); + job->job.worker = (lwt_unix_job_worker)worker_gethostname; + job->buffer = NULL; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_gethostname_result(value val_job) +{ + struct job_gethostname *job = Job_gethostname_val(val_job); + if (job->result < 0) unix_error(job->error_code, "gethostname", Nothing); + return caml_copy_string(job->buffer); +} + +CAMLprim value lwt_unix_gethostname_free(value val_job) +{ + struct job_gethostname *job = Job_gethostname_val(val_job); + free(job->buffer); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: gethostbyname | + +-----------------------------------------------------------------+ */ + +#define NETDB_BUFFER_SIZE 10000 + +struct job_gethostbyname { + struct lwt_unix_job job; + char *name; + struct hostent entry; + struct hostent *ptr; + char buffer[NETDB_BUFFER_SIZE]; +}; + +#define Job_gethostbyname_val(v) *(struct job_gethostbyname**)Data_custom_val(v) + +CAMLexport value alloc_inet_addr (struct in_addr * inaddr); +#define GET_INET_ADDR(v) (*((struct in_addr *) (v))) + +CAMLexport value alloc_inet6_addr (struct in6_addr * inaddr); +#define GET_INET6_ADDR(v) (*((struct in6_addr *) (v))) + +static value alloc_one_addr(char const *a) +{ + struct in_addr addr; + memmove (&addr, a, 4); + return alloc_inet_addr(&addr); +} + +static value alloc_one_addr6(char const *a) +{ + struct in6_addr addr; + memmove(&addr, a, 16); + return alloc_inet6_addr(&addr); +} + +static value alloc_host_entry(struct hostent *entry) +{ + value res; + value name = Val_unit, aliases = Val_unit; + value addr_list = Val_unit, adr = Val_unit; + + Begin_roots4 (name, aliases, addr_list, adr); + name = copy_string((char *)(entry->h_name)); + /* PR#4043: protect against buggy implementations of gethostbynamee() + that return a NULL pointer in h_aliases */ + if (entry->h_aliases) + aliases = copy_string_array((const char**)entry->h_aliases); + else + aliases = Atom(0); + if (entry->h_length == 16) + addr_list = alloc_array(alloc_one_addr6, (const char**)entry->h_addr_list); + else + addr_list = alloc_array(alloc_one_addr, (const char**)entry->h_addr_list); + res = alloc_small(4, 0); + Field(res, 0) = name; + Field(res, 1) = aliases; + switch (entry->h_addrtype) { + case PF_UNIX: Field(res, 2) = Val_int(0); break; + case PF_INET: Field(res, 2) = Val_int(1); break; + default: /*PF_INET6 */ Field(res, 2) = Val_int(2); break; + } + Field(res, 3) = addr_list; + End_roots(); + return res; +} + +static void worker_gethostbyname(struct job_gethostbyname *job) +{ + int h_errno; +#if HAS_GETHOSTBYNAME_R == 5 + job->ptr = gethostbyname_r(job->name, &(job->entry), job->buffer, NETDB_BUFFER_SIZE, &h_errno); +#elif HAS_GETHOSTBYNAME_R == 6 + if (gethostbyname_r(job->name, &(job->entry), job->buffer, NETDB_BUFFER_SIZE, &(job->ptr), &h_errno) != 0) + job->ptr = NULL; +#else + job->ptr = NULL; +#endif +} + +CAMLprim value lwt_unix_gethostbyname_job(value val_name) +{ + struct job_gethostbyname *job = lwt_unix_new(struct job_gethostbyname); + job->job.worker = (lwt_unix_job_worker)worker_gethostbyname; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_gethostbyname_result(value val_job) +{ + struct job_gethostbyname *job = Job_gethostbyname_val(val_job); + if (job->ptr == NULL) caml_raise_not_found(); + return alloc_host_entry(&(job->entry)); +} + +CAMLprim value lwt_unix_gethostbyname_free(value val_job) +{ + struct job_gethostbyname *job = Job_gethostbyname_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: gethostbyaddr | + +-----------------------------------------------------------------+ */ + +struct job_gethostbyaddr { + struct lwt_unix_job job; + struct in_addr addr; + struct hostent entry; + struct hostent *ptr; + char buffer[NETDB_BUFFER_SIZE]; +}; + +#define Job_gethostbyaddr_val(v) *(struct job_gethostbyaddr**)Data_custom_val(v) + +static void worker_gethostbyaddr(struct job_gethostbyaddr *job) +{ + int h_errno; +#if HAS_GETHOSTBYADDR_R == 7 + job->ptr = gethostbyaddr_r(&(job->addr), 4, AF_INET, &(job->entry), job->buffer, NETDB_BUFFER_SIZE, &h_errno); +#elif HAS_GETHOSTBYADDR_R == 8 + if (gethostbyaddr_r(&(job->addr), 4, AF_INET, &(job->entry), job->buffer, NETDB_BUFFER_SIZE, &(job->ptr), &h_errno) != 0) + job->ptr = NULL; +#else + job->ptr = NULL; +#endif +} + +CAMLprim value lwt_unix_gethostbyaddr_job(value val_addr) +{ + struct job_gethostbyaddr *job = lwt_unix_new(struct job_gethostbyaddr); + job->job.worker = (lwt_unix_job_worker)worker_gethostbyaddr; + job->addr = GET_INET_ADDR(val_addr); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_gethostbyaddr_result(value val_job) +{ + struct job_gethostbyaddr *job = Job_gethostbyaddr_val(val_job); + if (job->ptr == NULL) caml_raise_not_found(); + return alloc_host_entry(&(job->entry)); +} + +CAMLprim value lwt_unix_gethostbyaddr_free(value val_job) +{ + struct job_gethostbyaddr *job = Job_gethostbyaddr_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getprotobyname | + +-----------------------------------------------------------------+ */ + +struct job_getprotobyname { + struct lwt_unix_job job; + char *name; + struct protoent *result; +}; + +#define Job_getprotobyname_val(v) *(struct job_getprotobyname**)Data_custom_val(v) + +static value alloc_proto_entry(struct protoent *entry) +{ + value res; + value name = Val_unit, aliases = Val_unit; + + Begin_roots2 (name, aliases); + name = copy_string(entry->p_name); + aliases = copy_string_array((const char**)entry->p_aliases); + res = alloc_small(3, 0); + Field(res,0) = name; + Field(res,1) = aliases; + Field(res,2) = Val_int(entry->p_proto); + End_roots(); + return res; +} + +static void worker_getprotobyname(struct job_getprotobyname *job) +{ + job->result = getprotobyname(job->name); +} + +CAMLprim value lwt_unix_getprotobyname_job(value val_name) +{ + struct job_getprotobyname *job = lwt_unix_new(struct job_getprotobyname); + job->job.worker = (lwt_unix_job_worker)worker_getprotobyname; + job->name = lwt_unix_strdup(String_val(val_name)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getprotobyname_result(value val_job) +{ + struct job_getprotobyname *job = Job_getprotobyname_val(val_job); + if (job->result == NULL) caml_raise_not_found(); + return alloc_proto_entry(job->result); +} + +CAMLprim value lwt_unix_getprotobyname_free(value val_job) +{ + struct job_getprotobyname *job = Job_getprotobyname_val(val_job); + free(job->name); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getprotobynumber | + +-----------------------------------------------------------------+ */ + +struct job_getprotobynumber { + struct lwt_unix_job job; + int number; + struct protoent *result; +}; + +#define Job_getprotobynumber_val(v) *(struct job_getprotobynumber**)Data_custom_val(v) + +static void worker_getprotobynumber(struct job_getprotobynumber *job) +{ + job->result = getprotobynumber(job->number); +} + +CAMLprim value lwt_unix_getprotobynumber_job(value val_number) +{ + struct job_getprotobynumber *job = lwt_unix_new(struct job_getprotobynumber); + job->job.worker = (lwt_unix_job_worker)worker_getprotobynumber; + job->number = Int_val(val_number); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getprotobynumber_result(value val_job) +{ + struct job_getprotobynumber *job = Job_getprotobynumber_val(val_job); + if (job->result == NULL) caml_raise_not_found(); + return alloc_proto_entry(job->result); +} + +CAMLprim value lwt_unix_getprotobynumber_free(value val_job) +{ + struct job_getprotobynumber *job = Job_getprotobynumber_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getservbyname | + +-----------------------------------------------------------------+ */ + +struct job_getservbyname { + struct lwt_unix_job job; + char *name; + char *proto; + struct servent *result; +}; + +#define Job_getservbyname_val(v) *(struct job_getservbyname**)Data_custom_val(v) + +static value alloc_service_entry(struct servent *entry) +{ + value res; + value name = Val_unit, aliases = Val_unit, proto = Val_unit; + + Begin_roots3 (name, aliases, proto); + name = copy_string(entry->s_name); + aliases = copy_string_array((const char**)entry->s_aliases); + proto = copy_string(entry->s_proto); + res = alloc_small(4, 0); + Field(res,0) = name; + Field(res,1) = aliases; + Field(res,2) = Val_int(ntohs(entry->s_port)); + Field(res,3) = proto; + End_roots(); + return res; +} + +static void worker_getservbyname(struct job_getservbyname *job) +{ + job->result = getservbyname(job->name, job->proto); +} + +CAMLprim value lwt_unix_getservbyname_job(value val_name, value val_proto) +{ + struct job_getservbyname *job = lwt_unix_new(struct job_getservbyname); + job->job.worker = (lwt_unix_job_worker)worker_getservbyname; + job->name = lwt_unix_strdup(String_val(val_name)); + job->proto = lwt_unix_strdup(String_val(val_proto)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getservbyname_result(value val_job) +{ + struct job_getservbyname *job = Job_getservbyname_val(val_job); + if (job->result == NULL) caml_raise_not_found(); + return alloc_service_entry(job->result); +} + +CAMLprim value lwt_unix_getservbyname_free(value val_job) +{ + struct job_getservbyname *job = Job_getservbyname_val(val_job); + free(job->name); + free(job->proto); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getservbyport | + +-----------------------------------------------------------------+ */ + +struct job_getservbyport { + struct lwt_unix_job job; + int port; + char *proto; + struct servent *result; +}; + +#define Job_getservbyport_val(v) *(struct job_getservbyport**)Data_custom_val(v) + +static void worker_getservbyport(struct job_getservbyport *job) +{ + job->result = getservbyport(job->port, job->proto); +} + +CAMLprim value lwt_unix_getservbyport_job(value val_port, value val_proto) +{ + struct job_getservbyport *job = lwt_unix_new(struct job_getservbyport); + job->job.worker = (lwt_unix_job_worker)worker_getservbyport; + job->port = Int_val(val_port); + job->proto = lwt_unix_strdup(String_val(val_proto)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getservbyport_result(value val_job) +{ + struct job_getservbyport *job = Job_getservbyport_val(val_job); + if (job->result == NULL) caml_raise_not_found(); + return alloc_service_entry(job->result); +} + +CAMLprim value lwt_unix_getservbyport_free(value val_job) +{ + struct job_getservbyport *job = Job_getservbyport_val(val_job); + free(job->proto); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getaddrinfo | + +-----------------------------------------------------------------+ */ + +struct job_getaddrinfo { + struct lwt_unix_job job; + char *node; + char *service; + struct addrinfo hints; + struct addrinfo *info; + int result; +}; + +#define Job_getaddrinfo_val(v) *(struct job_getaddrinfo**)Data_custom_val(v) + +value cst_to_constr(int n, int *tbl, int size, int deflt) +{ + int i; + for (i = 0; i < size; i++) + if (n == tbl[i]) return Val_int(i); + return Val_int(deflt); +} + +static value convert_addrinfo(struct addrinfo * a) +{ + CAMLparam0(); + CAMLlocal3(vres,vaddr,vcanonname); + union sock_addr_union sa; + socklen_t len; + + len = a->ai_addrlen; + if (len > sizeof(sa)) len = sizeof(sa); + memcpy(&sa.s_gen, a->ai_addr, len); + vaddr = alloc_sockaddr(&sa, len, -1); + vcanonname = copy_string(a->ai_canonname == NULL ? "" : a->ai_canonname); + vres = alloc_small(5, 0); + Field(vres, 0) = cst_to_constr(a->ai_family, socket_domain_table, 3, 0); + Field(vres, 1) = cst_to_constr(a->ai_socktype, socket_type_table, 4, 0); + Field(vres, 2) = Val_int(a->ai_protocol); + Field(vres, 3) = vaddr; + Field(vres, 4) = vcanonname; + CAMLreturn(vres); +} + +static void worker_getaddrinfo(struct job_getaddrinfo *job) +{ + job->result = getaddrinfo(job->node, job->service, &(job->hints), &(job->info)); +} + +CAMLprim value lwt_unix_getaddrinfo_job(value val_node, value val_service, value val_hints) +{ + struct job_getaddrinfo *job = lwt_unix_new(struct job_getaddrinfo); + job->job.worker = (lwt_unix_job_worker)worker_getaddrinfo; + job->node = caml_string_length(val_node) == 0 ? NULL : lwt_unix_strdup(String_val(val_node)); + job->service = caml_string_length(val_service) == 0 ? NULL : lwt_unix_strdup(String_val(val_service)); + job->info = NULL; + memset(&(job->hints), 0, sizeof(struct addrinfo)); + job->hints.ai_family = PF_UNSPEC; + for (/*nothing*/; Is_block(val_hints); val_hints = Field(val_hints, 1)) { + value v = Field(val_hints, 0); + if (Is_block(v)) + switch (Tag_val(v)) { + case 0: /* AI_FAMILY of socket_domain */ + job->hints.ai_family = socket_domain_table[Int_val(Field(v, 0))]; + break; + case 1: /* AI_SOCKTYPE of socket_type */ + job->hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))]; + break; + case 2: /* AI_PROTOCOL of int */ + job->hints.ai_protocol = Int_val(Field(v, 0)); + break; + } + else + switch (Int_val(v)) { + case 0: /* AI_NUMERICHOST */ + job->hints.ai_flags |= AI_NUMERICHOST; break; + case 1: /* AI_CANONNAME */ + job->hints.ai_flags |= AI_CANONNAME; break; + case 2: /* AI_PASSIVE */ + job->hints.ai_flags |= AI_PASSIVE; break; + } + } + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getaddrinfo_result(value val_job) +{ + CAMLparam1(val_job); + CAMLlocal3(vres, e, v); + struct addrinfo *r; + struct job_getaddrinfo *job = Job_getaddrinfo_val(val_job); + if (job->result != 0) unix_error(job->result, "getaddrinfo", Nothing); + vres = Val_int(0); + for (r = job->info; r != NULL; r = r->ai_next) { + e = convert_addrinfo(r); + v = alloc_small(2, 0); + Field(v, 0) = e; + Field(v, 1) = vres; + vres = v; + } + CAMLreturn(vres); +} + +CAMLprim value lwt_unix_getaddrinfo_free(value val_job) +{ + struct job_getaddrinfo *job = Job_getaddrinfo_val(val_job); + if (job->node != NULL) free(job->node); + if (job->service != NULL) free(job->service); + if (job->info != NULL) freeaddrinfo(job->info); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: getnameinfo | + +-----------------------------------------------------------------+ */ + +struct job_getnameinfo { + struct lwt_unix_job job; + union sock_addr_union addr; + socklen_t addr_len; + int opts; + char host[4096]; + char serv[1024]; + struct addrinfo *info; + int result; +}; + +#define Job_getnameinfo_val(v) *(struct job_getnameinfo**)Data_custom_val(v) + +static int getnameinfo_flag_table[] = { + NI_NOFQDN, NI_NUMERICHOST, NI_NAMEREQD, NI_NUMERICSERV, NI_DGRAM +}; + +static void worker_getnameinfo(struct job_getnameinfo *job) +{ + job->result = getnameinfo((const struct sockaddr *)&(job->addr.s_gen), job->addr_len, + job->host, sizeof(job->host), job->serv, sizeof(job->serv), + job->opts); +} + +CAMLprim value lwt_unix_getnameinfo_job(value val_sockaddr, value val_opts) +{ + struct job_getnameinfo *job = lwt_unix_new(struct job_getnameinfo); + job->job.worker = (lwt_unix_job_worker)worker_getnameinfo; + get_sockaddr(val_sockaddr, &(job->addr), &(job->addr_len)); + job->opts = convert_flag_list(val_opts, getnameinfo_flag_table); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_getnameinfo_result(value val_job) +{ + CAMLparam1(val_job); + CAMLlocal3(vres, vhost, vserv); + struct job_getnameinfo *job = Job_getnameinfo_val(val_job); + if (job->result != 0) caml_raise_not_found(); + vhost = caml_copy_string(job->host); + vserv = caml_copy_string(job->serv); + vres = alloc_small(2, 0); + Field(vres, 0) = vhost; + Field(vres, 1) = vserv; + CAMLreturn(vres); +} + +CAMLprim value lwt_unix_getnameinfo_free(value val_job) +{ + struct job_getnameinfo *job = Job_getnameinfo_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | Termios conversion | + +-----------------------------------------------------------------+ */ + +/* TODO: make it reentrant. */ + +static struct termios terminal_status; + +enum { Bool, Enum, Speed, Char, End }; + +enum { Input, Output }; + +#define iflags ((long)(&terminal_status.c_iflag)) +#define oflags ((long)(&terminal_status.c_oflag)) +#define cflags ((long)(&terminal_status.c_cflag)) +#define lflags ((long)(&terminal_status.c_lflag)) + +/* Number of fields in the terminal_io record field. Cf. unix.mli */ + +#define NFIELDS 38 + +/* Structure of the terminal_io record. Cf. unix.mli */ + +static long terminal_io_descr[] = { + /* Input modes */ + Bool, iflags, IGNBRK, + Bool, iflags, BRKINT, + Bool, iflags, IGNPAR, + Bool, iflags, PARMRK, + Bool, iflags, INPCK, + Bool, iflags, ISTRIP, + Bool, iflags, INLCR, + Bool, iflags, IGNCR, + Bool, iflags, ICRNL, + Bool, iflags, IXON, + Bool, iflags, IXOFF, + /* Output modes */ + Bool, oflags, OPOST, + /* Control modes */ + Speed, Output, + Speed, Input, + Enum, cflags, 5, 4, CSIZE, CS5, CS6, CS7, CS8, + Enum, cflags, 1, 2, CSTOPB, 0, CSTOPB, + Bool, cflags, CREAD, + Bool, cflags, PARENB, + Bool, cflags, PARODD, + Bool, cflags, HUPCL, + Bool, cflags, CLOCAL, + /* Local modes */ + Bool, lflags, ISIG, + Bool, lflags, ICANON, + Bool, lflags, NOFLSH, + Bool, lflags, ECHO, + Bool, lflags, ECHOE, + Bool, lflags, ECHOK, + Bool, lflags, ECHONL, + /* Control characters */ + Char, VINTR, + Char, VQUIT, + Char, VERASE, + Char, VKILL, + Char, VEOF, + Char, VEOL, + Char, VMIN, + Char, VTIME, + Char, VSTART, + Char, VSTOP, + End +}; + +#undef iflags +#undef oflags +#undef cflags +#undef lflags + +struct speedtable_entry ; + +static struct { + speed_t speed; + int baud; +} speedtable[] = { + {B50, 50}, + {B75, 75}, + {B110, 110}, + {B134, 134}, + {B150, 150}, + {B300, 300}, + {B600, 600}, + {B1200, 1200}, + {B1800, 1800}, + {B2400, 2400}, + {B4800, 4800}, + {B9600, 9600}, + {B19200, 19200}, + {B38400, 38400}, +#ifdef B57600 + {B57600, 57600}, +#endif +#ifdef B115200 + {B115200, 115200}, +#endif +#ifdef B230400 + {B230400, 230400}, +#endif + {B0, 0} +}; + +#define NSPEEDS (sizeof(speedtable) / sizeof(speedtable[0])) + +static void encode_terminal_status(value *dst) +{ + long * pc; + int i; + + for(pc = terminal_io_descr; *pc != End; dst++) { + switch(*pc++) { + case Bool: + { int * src = (int *) (*pc++); + int msk = *pc++; + *dst = Val_bool(*src & msk); + break; } + case Enum: + { int * src = (int *) (*pc++); + int ofs = *pc++; + int num = *pc++; + int msk = *pc++; + for (i = 0; i < num; i++) { + if ((*src & msk) == pc[i]) { + *dst = Val_int(i + ofs); + break; + } + } + pc += num; + break; } + case Speed: + { int which = *pc++; + speed_t speed = 0; + *dst = Val_int(9600); /* in case no speed in speedtable matches */ + switch (which) { + case Output: + speed = cfgetospeed(&terminal_status); break; + case Input: + speed = cfgetispeed(&terminal_status); break; + } + for (i = 0; i < NSPEEDS; i++) { + if (speed == speedtable[i].speed) { + *dst = Val_int(speedtable[i].baud); + break; + } + } + break; } + case Char: + { int which = *pc++; + *dst = Val_int(terminal_status.c_cc[which]); + break; } + } + } +} + +static void decode_terminal_status(value *src) +{ + long * pc; + int i; + + for (pc = terminal_io_descr; *pc != End; src++) { + switch(*pc++) { + case Bool: + { int * dst = (int *) (*pc++); + int msk = *pc++; + if (Bool_val(*src)) + *dst |= msk; + else + *dst &= ~msk; + break; } + case Enum: + { int * dst = (int *) (*pc++); + int ofs = *pc++; + int num = *pc++; + int msk = *pc++; + i = Int_val(*src) - ofs; + if (i >= 0 && i < num) { + *dst = (*dst & ~msk) | pc[i]; + } else { + unix_error(EINVAL, "tcsetattr", Nothing); + } + pc += num; + break; } + case Speed: + { int which = *pc++; + int baud = Int_val(*src); + int res = 0; + for (i = 0; i < NSPEEDS; i++) { + if (baud == speedtable[i].baud) { + switch (which) { + case Output: + res = cfsetospeed(&terminal_status, speedtable[i].speed); break; + case Input: + res = cfsetispeed(&terminal_status, speedtable[i].speed); break; + } + if (res == -1) uerror("tcsetattr", Nothing); + goto ok; + } + } + unix_error(EINVAL, "tcsetattr", Nothing); + ok: + break; } + case Char: + { int which = *pc++; + terminal_status.c_cc[which] = Int_val(*src); + break; } + } + } +} + +/* +-----------------------------------------------------------------+ + | JOB: tcgetattr | + +-----------------------------------------------------------------+ */ + +struct job_tcgetattr { + struct lwt_unix_job job; + int fd; + struct termios termios; + int result; + int error_code; +}; + +#define Job_tcgetattr_val(v) *(struct job_tcgetattr**)Data_custom_val(v) + +static void worker_tcgetattr(struct job_tcgetattr *job) +{ + job->result = tcgetattr(job->fd, &(job->termios)); + job->error_code = errno; +} + +CAMLprim value lwt_unix_tcgetattr_job(value val_fd) +{ + struct job_tcgetattr *job = lwt_unix_new(struct job_tcgetattr); + job->job.worker = (lwt_unix_job_worker)worker_tcgetattr; + job->fd = Int_val(val_fd); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_tcgetattr_result(value val_job) +{ + struct job_tcgetattr *job = Job_tcgetattr_val(val_job); + if (job->result < 0) unix_error(job->error_code, "tcgetattr", Nothing); + value res = alloc_tuple(NFIELDS); + memcpy(&terminal_status, &(job->termios), sizeof(struct termios)); + encode_terminal_status(&Field(res, 0)); + return res; +} + +CAMLprim value lwt_unix_tcgetattr_free(value val_job) +{ + lwt_unix_free_job(&(Job_tcgetattr_val(val_job))->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: tcsetattr | + +-----------------------------------------------------------------+ */ + +struct job_tcsetattr { + struct lwt_unix_job job; + int fd; + int when; + struct termios termios; + int result; + int error_code; +}; + +#define Job_tcsetattr_val(v) *(struct job_tcsetattr**)Data_custom_val(v) + +static int when_flag_table[] = { + TCSANOW, TCSADRAIN, TCSAFLUSH +}; + +static void worker_tcsetattr(struct job_tcsetattr *job) +{ + job->result = tcsetattr(job->fd, job->when, &(job->termios)); + job->error_code = errno; +} + +CAMLprim value lwt_unix_tcsetattr_job(value val_fd, value val_when, value val_termios) +{ + struct job_tcsetattr *job = lwt_unix_new(struct job_tcsetattr); + job->job.worker = (lwt_unix_job_worker)worker_tcsetattr; + job->fd = Int_val(val_fd); + job->when = when_flag_table[Int_val(val_when)]; + decode_terminal_status(&Field(val_termios, 0)); + memcpy(&(job->termios), &terminal_status, sizeof(struct termios)); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_tcsetattr_result(value val_job) +{ + struct job_tcsetattr *job = Job_tcsetattr_val(val_job); + if (job->result < 0) unix_error(job->error_code, "tcsetattr", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_tcsetattr_free(value val_job) +{ + lwt_unix_free_job(&(Job_tcsetattr_val(val_job))->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: tcdrain | + +-----------------------------------------------------------------+ */ + +struct job_tcdrain { + struct lwt_unix_job job; + int fd; + int result; + int error_code; +}; + +#define Job_tcdrain_val(v) *(struct job_tcdrain**)Data_custom_val(v) + +static void worker_tcdrain(struct job_tcdrain *job) +{ + job->result = tcdrain(job->fd); + job->error_code = errno; +} + +CAMLprim value lwt_unix_tcdrain_job(value val_fd) +{ + struct job_tcdrain *job = lwt_unix_new(struct job_tcdrain); + job->job.worker = (lwt_unix_job_worker)worker_tcdrain; + job->fd = Int_val(val_fd); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_tcdrain_result(value val_job) +{ + struct job_tcdrain *job = Job_tcdrain_val(val_job); + if (job->result < 0) unix_error(job->error_code, "tcdrain", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_tcdrain_free(value val_job) +{ + lwt_unix_free_job(&(Job_tcdrain_val(val_job))->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: tcflush | + +-----------------------------------------------------------------+ */ + +struct job_tcflush { + struct lwt_unix_job job; + int fd; + int queue; + int result; + int error_code; +}; + +#define Job_tcflush_val(v) *(struct job_tcflush**)Data_custom_val(v) + +static int queue_flag_table[] = { + TCIFLUSH, TCOFLUSH, TCIOFLUSH +}; + +static void worker_tcflush(struct job_tcflush *job) +{ + job->result = tcflush(job->fd, job->queue); + job->error_code = errno; +} + +CAMLprim value lwt_unix_tcflush_job(value val_fd, value val_queue) +{ + struct job_tcflush *job = lwt_unix_new(struct job_tcflush); + job->job.worker = (lwt_unix_job_worker)worker_tcflush; + job->fd = Int_val(val_fd); + job->queue = queue_flag_table[Int_val(val_queue)]; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_tcflush_result(value val_job) +{ + struct job_tcflush *job = Job_tcflush_val(val_job); + if (job->result < 0) unix_error(job->error_code, "tcflush", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_tcflush_free(value val_job) +{ + lwt_unix_free_job(&(Job_tcflush_val(val_job))->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: tcflow | + +-----------------------------------------------------------------+ */ + +struct job_tcflow { + struct lwt_unix_job job; + int fd; + int action; + int result; + int error_code; +}; + +#define Job_tcflow_val(v) *(struct job_tcflow**)Data_custom_val(v) + +static int action_flag_table[] = { + TCOOFF, TCOON, TCIOFF, TCION +}; + +static void worker_tcflow(struct job_tcflow *job) +{ + job->result = tcflow(job->fd, job->action); + job->error_code = errno; +} + +CAMLprim value lwt_unix_tcflow_job(value val_fd, value val_action) +{ + struct job_tcflow *job = lwt_unix_new(struct job_tcflow); + job->job.worker = (lwt_unix_job_worker)worker_tcflow; + job->fd = Int_val(val_fd); + job->action = action_flag_table[Int_val(val_action)]; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_tcflow_result(value val_job) +{ + struct job_tcflow *job = Job_tcflow_val(val_job); + if (job->result < 0) unix_error(job->error_code, "tcflow", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_tcflow_free(value val_job) +{ + lwt_unix_free_job(&(Job_tcflow_val(val_job))->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: tcsendbreak | + +-----------------------------------------------------------------+ */ + +struct job_tcsendbreak { + struct lwt_unix_job job; + int fd; + int delay; + int result; + int error_code; +}; + +#define Job_tcsendbreak_val(v) *(struct job_tcsendbreak**)Data_custom_val(v) + +static void worker_tcsendbreak(struct job_tcsendbreak *job) +{ + job->result = tcsendbreak(job->fd, job->delay); + job->error_code = errno; +} + +CAMLprim value lwt_unix_tcsendbreak_job(value val_fd, value val_delay) +{ + struct job_tcsendbreak *job = lwt_unix_new(struct job_tcsendbreak); + job->job.worker = (lwt_unix_job_worker)worker_tcsendbreak; + job->fd = Int_val(val_fd); + job->delay = Int_val(val_delay); + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_tcsendbreak_result(value val_job) +{ + struct job_tcsendbreak *job = Job_tcsendbreak_val(val_job); + if (job->result < 0) unix_error(job->error_code, "tcsendbreak", Nothing); + return Val_unit; +} + +CAMLprim value lwt_unix_tcsendbreak_free(value val_job) +{ + lwt_unix_free_job(&(Job_tcsendbreak_val(val_job))->job); + return Val_unit; +} diff --git a/thirdparty/lwt-2.3.2/src/unix/lwt_unix_windows.c b/thirdparty/lwt-2.3.2/src/unix/lwt_unix_windows.c new file mode 100644 index 0000000..c054729 --- /dev/null +++ b/thirdparty/lwt-2.3.2/src/unix/lwt_unix_windows.c @@ -0,0 +1,484 @@ +/* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Lwt_unix_unix + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + */ + +/* Windows version of stubs. */ + +CAMLprim value lwt_unix_is_socket(value fd) +{ + return (Val_bool(Descr_kind_val(fd) == KIND_SOCKET)); +} + +CAMLprim value lwt_unix_write(value fd, value buf, value vofs, value vlen) +{ + intnat ofs, len, written; + DWORD numbytes, numwritten; + DWORD err = 0; + + Begin_root (buf); + ofs = Long_val(vofs); + len = Long_val(vlen); + written = 0; + if (len > 0) { + numbytes = len; + if (Descr_kind_val(fd) == KIND_SOCKET) { + int ret; + SOCKET s = Socket_val(fd); + ret = send(s, &Byte(buf, ofs), numbytes, 0); + if (ret == SOCKET_ERROR) err = WSAGetLastError(); + numwritten = ret; + } else { + HANDLE h = Handle_val(fd); + if (! WriteFile(h, &Byte(buf, ofs), numbytes, &numwritten, NULL)) + err = GetLastError(); + } + if (err) { + win32_maperr(err); + uerror("write", Nothing); + } + written = numwritten; + } + End_roots(); + return Val_long(written); +} + +CAMLprim value lwt_unix_bytes_write(value fd, value buf, value vofs, value vlen) +{ + intnat ofs, len, written; + DWORD numbytes, numwritten; + DWORD err = 0; + + Begin_root (buf); + ofs = Long_val(vofs); + len = Long_val(vlen); + written = 0; + if (len > 0) { + numbytes = len; + if (Descr_kind_val(fd) == KIND_SOCKET) { + int ret; + SOCKET s = Socket_val(fd); + ret = send(s, (char*)Caml_ba_array_val(buf)->data + ofs, numbytes, 0); + if (ret == SOCKET_ERROR) err = WSAGetLastError(); + numwritten = ret; + } else { + HANDLE h = Handle_val(fd); + if (! WriteFile(h, (char*)Caml_ba_array_val(buf)->data + ofs, numbytes, &numwritten, NULL)) + err = GetLastError(); + } + if (err) { + win32_maperr(err); + uerror("write", Nothing); + } + written = numwritten; + } + End_roots(); + return Val_long(written); +} + +CAMLprim value lwt_unix_read(value fd, value buf, value vofs, value vlen) +{ + intnat ofs, len, written; + DWORD numbytes, numwritten; + DWORD err = 0; + + Begin_root (buf); + ofs = Long_val(vofs); + len = Long_val(vlen); + written = 0; + if (len > 0) { + numbytes = len; + if (Descr_kind_val(fd) == KIND_SOCKET) { + int ret; + SOCKET s = Socket_val(fd); + ret = recv(s, &Byte(buf, ofs), numbytes, 0); + if (ret == SOCKET_ERROR) err = WSAGetLastError(); + numwritten = ret; + } else { + HANDLE h = Handle_val(fd); + if (! ReadFile(h, &Byte(buf, ofs), numbytes, &numwritten, NULL)) + err = GetLastError(); + } + if (err) { + win32_maperr(err); + uerror("write", Nothing); + } + written = numwritten; + } + End_roots(); + return Val_long(written); +} + +CAMLprim value lwt_unix_bytes_read(value fd, value buf, value vofs, value vlen) +{ + intnat ofs, len, written; + DWORD numbytes, numwritten; + DWORD err = 0; + + Begin_root (buf); + ofs = Long_val(vofs); + len = Long_val(vlen); + written = 0; + if (len > 0) { + numbytes = len; + if (Descr_kind_val(fd) == KIND_SOCKET) { + int ret; + SOCKET s = Socket_val(fd); + ret = recv(s, (char*)Caml_ba_array_val(buf)->data + ofs, numbytes, 0); + if (ret == SOCKET_ERROR) err = WSAGetLastError(); + numwritten = ret; + } else { + HANDLE h = Handle_val(fd); + if (! ReadFile(h, (char*)Caml_ba_array_val(buf)->data + ofs, numbytes, &numwritten, NULL)) + err = GetLastError(); + } + if (err) { + win32_maperr(err); + uerror("write", Nothing); + } + written = numwritten; + } + End_roots(); + return Val_long(written); +} + +/* +-----------------------------------------------------------------+ + | Memory mapped files | + +-----------------------------------------------------------------+ */ + +CAMLprim value lwt_unix_get_page_size() +{ + SYSTEM_INFO si; + GetSystemInfo(&si); + return Val_long(si.dwPageSize); +} + +/* +-----------------------------------------------------------------+ + | JOB: read | + +-----------------------------------------------------------------+ */ + +struct job_read { + struct lwt_unix_job job; + union { + HANDLE handle; + SOCKET socket; + } fd; + int kind; + char *buffer; + DWORD length; + DWORD result; + DWORD error_code; +}; + +#define Job_read_val(v) *(struct job_read**)Data_custom_val(v) + +static void worker_read(struct job_read *job) +{ + if (job->kind == KIND_SOCKET) { + int ret; + ret = recv(job->fd.socket, job->buffer, job->length, 0); + if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); + job->result = ret; + } else { + if (!ReadFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) + job->error_code = GetLastError(); + } +} + +CAMLprim value lwt_unix_read_job(value val_fd, value val_length) +{ + struct job_read *job = lwt_unix_new(struct job_read); + struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); + long length = Long_val(val_length); + job->job.worker = (lwt_unix_job_worker)worker_read; + job->kind = fd->kind; + if (fd->kind == KIND_HANDLE) + job->fd.handle = fd->fd.handle; + else + job->fd.socket = fd->fd.socket; + job->buffer = (char*)lwt_unix_malloc(length); + job->length = length; + job->error_code = 0; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_read_result(value val_job, value val_string, value val_offset) +{ + struct job_read *job = Job_read_val(val_job); + if (job->error_code) { + win32_maperr(job->error_code); + uerror("read", Nothing); + } + memcpy(String_val(val_string) + Long_val(val_offset), job->buffer, job->result); + return Val_long(job->result); +} + +CAMLprim value lwt_unix_read_free(value val_job) +{ + struct job_read *job = Job_read_val(val_job); + free(job->buffer); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: bytes_read | + +-----------------------------------------------------------------+ */ + +struct job_bytes_read { + struct lwt_unix_job job; + union { + HANDLE handle; + SOCKET socket; + } fd; + int kind; + char *buffer; + DWORD length; + DWORD result; + DWORD error_code; +}; + +#define Job_bytes_read_val(v) *(struct job_bytes_read**)Data_custom_val(v) + +static void worker_bytes_read(struct job_bytes_read *job) +{ + if (job->kind == KIND_SOCKET) { + int ret; + ret = recv(job->fd.socket, job->buffer, job->length, 0); + if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); + job->result = ret; + } else { + if (!ReadFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) + job->error_code = GetLastError(); + } +} + +CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buffer, value val_offset, value val_length) +{ + struct job_bytes_read *job = lwt_unix_new(struct job_bytes_read); + struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); + long length = Long_val(val_length); + job->job.worker = (lwt_unix_job_worker)worker_bytes_read; + job->kind = fd->kind; + if (fd->kind == KIND_HANDLE) + job->fd.handle = fd->fd.handle; + else + job->fd.socket = fd->fd.socket; + job->buffer = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); + job->length = length; + job->error_code = 0; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_bytes_read_result(value val_job) +{ + struct job_bytes_read *job = Job_bytes_read_val(val_job); + if (job->error_code) { + win32_maperr(job->error_code); + uerror("bytes_read", Nothing); + } + return Val_long(job->result); +} + +CAMLprim value lwt_unix_bytes_read_free(value val_job) +{ + struct job_bytes_read *job = Job_bytes_read_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: write | + +-----------------------------------------------------------------+ */ + +struct job_write { + struct lwt_unix_job job; + union { + HANDLE handle; + SOCKET socket; + } fd; + int kind; + char *buffer; + DWORD length; + DWORD result; + DWORD error_code; +}; + +#define Job_write_val(v) *(struct job_write**)Data_custom_val(v) + +static void worker_write(struct job_write *job) +{ + if (job->kind == KIND_SOCKET) { + int ret; + ret = send(job->fd.socket, job->buffer, job->length, 0); + if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); + job->result = ret; + } else { + if (!WriteFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) + job->error_code = GetLastError(); + } +} + +CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length) +{ + struct job_write *job = lwt_unix_new(struct job_write); + struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); + long length = Long_val(val_length); + job->job.worker = (lwt_unix_job_worker)worker_write; + job->kind = fd->kind; + if (fd->kind == KIND_HANDLE) + job->fd.handle = fd->fd.handle; + else + job->fd.socket = fd->fd.socket; + job->buffer = (char*)lwt_unix_malloc(length); + memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length); + job->length = length; + job->error_code = 0; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_write_result(value val_job) +{ + struct job_write *job = Job_write_val(val_job); + if (job->error_code) { + win32_maperr(job->error_code); + uerror("write", Nothing); + } + return Val_long(job->result); +} + +CAMLprim value lwt_unix_write_free(value val_job) +{ + struct job_write *job = Job_write_val(val_job); + free(job->buffer); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: bytes_write | + +-----------------------------------------------------------------+ */ + +struct job_bytes_write { + struct lwt_unix_job job; + union { + HANDLE handle; + SOCKET socket; + } fd; + int kind; + char *buffer; + DWORD length; + DWORD result; + DWORD error_code; +}; + +#define Job_bytes_write_val(v) *(struct job_bytes_write**)Data_custom_val(v) + +static void worker_bytes_write(struct job_bytes_write *job) +{ + if (job->kind == KIND_SOCKET) { + int ret; + ret = send(job->fd.socket, job->buffer, job->length, 0); + if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); + job->result = ret; + } else { + if (!WriteFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) + job->error_code = GetLastError(); + } +} + +CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length) +{ + struct job_bytes_write *job = lwt_unix_new(struct job_bytes_write); + struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); + long length = Long_val(val_length); + job->job.worker = (lwt_unix_job_worker)worker_bytes_write; + job->kind = fd->kind; + if (fd->kind == KIND_HANDLE) + job->fd.handle = fd->fd.handle; + else + job->fd.socket = fd->fd.socket; + job->buffer = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); + job->length = length; + job->error_code = 0; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_bytes_write_result(value val_job) +{ + struct job_bytes_write *job = Job_bytes_write_val(val_job); + if (job->error_code) { + win32_maperr(job->error_code); + uerror("bytes_write", Nothing); + } + return Val_long(job->result); +} + +CAMLprim value lwt_unix_bytes_write_free(value val_job) +{ + struct job_bytes_write *job = Job_bytes_write_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} + +/* +-----------------------------------------------------------------+ + | JOB: fsync | + +-----------------------------------------------------------------+ */ + +struct job_fsync { + struct lwt_unix_job job; + HANDLE handle; + DWORD error_code; +}; + +#define Job_fsync_val(v) *(struct job_fsync**)Data_custom_val(v) + +static void worker_fsync(struct job_fsync *job) +{ + if (!FlushFileBuffers(job->handle)) + job->error_code = GetLastError(); +} + +CAMLprim value lwt_unix_fsync_job(value val_fd) +{ + struct job_fsync *job = lwt_unix_new(struct job_fsync); + struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); + job->job.worker = (lwt_unix_job_worker)worker_fsync; + job->handle = fd->fd.handle; + job->error_code = 0; + return lwt_unix_alloc_job(&(job->job)); +} + +CAMLprim value lwt_unix_fsync_result(value val_job, value val_string, value val_offset) +{ + struct job_fsync *job = Job_fsync_val(val_job); + if (job->error_code) { + win32_maperr(job->error_code); + uerror("fsync", Nothing); + } + return Val_unit; +} + +CAMLprim value lwt_unix_fsync_free(value val_job) +{ + struct job_fsync *job = Job_fsync_val(val_job); + lwt_unix_free_job(&job->job); + return Val_unit; +} diff --git a/thirdparty/lwt-2.3.2/syntax/META b/thirdparty/lwt-2.3.2/syntax/META new file mode 100644 index 0000000..51b02cc --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/META @@ -0,0 +1,10 @@ +# OASIS_START +# DO NOT EDIT (digest: b4e6367f74716c8084939eb1c1a4ccc1) +version = "2.3.2" +description = "Lightweight thread library for Objective Caml" +requires = "camlp4.lib camlp4.quotations.o" +archive(byte) = "optcomp.cma" +archive(native) = "optcomp.cmxa" +exists_if = "optcomp.cma" +# OASIS_STOP + diff --git a/thirdparty/lwt-2.3.2/syntax/lwt-syntax-log.mllib b/thirdparty/lwt-2.3.2/syntax/lwt-syntax-log.mllib new file mode 100644 index 0000000..7d67f53 --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/lwt-syntax-log.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 3dd8f18825465abee972eb9d78d04827) +Pa_lwt_log +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/syntax/lwt-syntax-options.mllib b/thirdparty/lwt-2.3.2/syntax/lwt-syntax-options.mllib new file mode 100644 index 0000000..45f3c5c --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/lwt-syntax-options.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: b07bedaca1c4ada7f18a2dee3e3cb6a0) +Pa_lwt_options +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/syntax/lwt-syntax.mllib b/thirdparty/lwt-2.3.2/syntax/lwt-syntax.mllib new file mode 100644 index 0000000..29def8e --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/lwt-syntax.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 03396b0b9b2d52e4b95f591f2553b12d) +Pa_lwt +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/syntax/optcomp.mllib b/thirdparty/lwt-2.3.2/syntax/optcomp.mllib new file mode 100644 index 0000000..7e1c71a --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/optcomp.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 6072e4752c8626fe698fdb6438b61195) +Pa_optcomp +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/syntax/pa_lwt.ml b/thirdparty/lwt-2.3.2/syntax/pa_lwt.ml new file mode 100644 index 0000000..aaa8a8d --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/pa_lwt.ml @@ -0,0 +1,236 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Pa_lwt + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Camlp4 +open Camlp4.PreCast +open Syntax + +(* Generate the catching function from a macth-case. + + The main work of this functions is to add a case: + + {[ + | exn -> fail exn + ]} + + when there is not already one. *) +let gen_catch mc = + (* Does the match case have a rule of the form "| e -> ..." ? *) + let rec have_default = function + | <:match_case< $a$ | $b$ >> -> have_default a || have_default b + | <:match_case< _ -> $_$ >> + | <:match_case< $lid:_$ -> $_$ >> -> true + | _ -> false + in + if have_default mc then + mc + else + let _loc = Ast.loc_of_match_case mc in + <:match_case< $mc$ | exn -> Lwt.fail exn >> + +let gen_binding l = + let rec aux n = function + | [] -> + assert false + | [(_loc, p, e)] -> + <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ >> + | (_loc, p, e) :: l -> + <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ and $aux (n + 1) l$ >> + in + aux 0 l + +let gen_bind l e = + let rec aux n = function + | [] -> + e + | (_loc, p, e) :: l -> + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> + else + <:expr< Lwt.bind $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> + in + aux 0 l + +let gen_top_bind _loc l = + let rec aux n vars = function + | [] -> + <:expr< Lwt.return ($tup:Ast.exCom_of_list (List.rev vars)$) >> + | (_loc, p, e) :: l -> + let id = "__pa_lwt_" ^ string_of_int n in + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> + else + <:expr< Lwt.bind $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> + in + aux 0 [] l + +EXTEND Gram + GLOBAL: expr str_item; + + cases: + [ [ "with"; c = match_case -> Some(gen_catch c) + | -> None ] ]; + + finally: + [ [ "finally"; f = sequence -> Some f + | -> None ] ]; + + letb_binding: + [ [ b1 = SELF; "and"; b2 = SELF -> b1 @ b2 + | p = patt; "="; e = expr -> [(_loc, p, e)] + ] ]; + + for_scheme: + [ [ "="; s = sequence; "to"; e = sequence -> + `CountTo(s, e) + | "="; s = sequence; "downto"; e = sequence -> + `CountDownTo(s, e) + | "in"; e = sequence -> + `IterOver(e) ] ]; + + expr: LEVEL "top" + [ [ "try_lwt"; e = expr LEVEL ";"; c = cases; f = finally -> + begin match c, f with + | None, None -> + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) Lwt.fail >> + else + <:expr< Lwt.catch (fun () -> $e$) Lwt.fail >> + | Some c, None -> + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (function $c$) >> + else + <:expr< Lwt.catch (fun () -> $e$) (function $c$) >> + | None, Some f -> + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_finalize (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (fun () -> (begin $f$ end)) >> + else + <:expr< Lwt.finalize (fun () -> $e$) (fun () -> (begin $f$ end)) >> + | Some c, Some f -> + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_try_bind (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) + (fun __pa_lwt_x -> Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) (begin $f$ end) (fun () -> Lwt.return __pa_lwt_x)) + (fun __pa_lwt_e -> Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) (begin $f$ end) (fun () -> match __pa_lwt_e with $c$)) + >> + else + <:expr< Lwt.try_bind (fun () -> $e$) + (fun __pa_lwt_x -> Lwt.bind (begin $f$ end) (fun () -> Lwt.return __pa_lwt_x)) + (fun __pa_lwt_e -> Lwt.bind (begin $f$ end) (fun () -> match __pa_lwt_e with $c$)) + >> + end + + | "lwt"; l = letb_binding; "in"; e = expr LEVEL ";" -> + <:expr< let $gen_binding l$ in $gen_bind l e$ >> + + | "for_lwt"; p = patt; scheme = for_scheme; "do"; seq = do_sequence -> + (match p, scheme with + | <:patt< $lid:id$ >>, `CountTo(s, e) -> + <:expr< let __pa_lwt_max = $e$ in + let rec __pa_lwt_loop $lid:id$ = + if $lid:id$ > __pa_lwt_max then + Lwt.return () + else + Lwt.bind (begin $seq$ end) (fun () -> __pa_lwt_loop ($lid:id$ + 1)) + in + __pa_lwt_loop $s$ + >> + + | <:patt< $lid:id$ >>, `CountDownTo(s, e) -> + <:expr< let __pa_lwt_min = $e$ in + let rec __pa_lwt_loop $lid:id$ = + if $lid:id$ < __pa_lwt_min then + Lwt.return () + else + Lwt.bind (begin $seq$ end) (fun () -> __pa_lwt_loop ($lid:id$ - 1)) + in + __pa_lwt_loop $s$ + >> + + | p, `IterOver(e) -> + <:expr< Lwt_stream.iter_s (fun $p$ -> $seq$) $e$ >> + + | _ -> + Loc.raise _loc (Failure "syntax error")) + + | "raise_lwt"; e = SELF -> + if !Pa_lwt_options.debug then + <:expr< Lwt.fail (try raise $e$ with exn -> exn) >> + else + <:expr< Lwt.fail $e$ >> + + | "assert_lwt"; e = SELF -> + <:expr< try Lwt.return (assert $e$) with exn -> Lwt.fail exn >> + + | "while_lwt"; cond = sequence; "do"; body = sequence; "done" -> + <:expr< + let rec __pa_lwt_loop () = + if $cond$ then + Lwt.bind (begin $body$ end) __pa_lwt_loop + else + Lwt.return () + in + __pa_lwt_loop () + >> + + | "match_lwt"; e = sequence; "with"; c = match_case -> + <:expr< + Lwt.bind (begin $e$ end) (function $c$) + >> + ] ]; + + str_item: + [ [ "lwt"; l = letb_binding -> begin + match l with + | [(_loc, p, e)] -> + <:str_item< + let $p$ = Lwt_main.run $e$ + >> + | _ -> + <:str_item< + let $tup:Ast.paCom_of_list (List.map (fun (_loc, p, e) -> p) l)$ = + Lwt_main.run begin + let $gen_binding l$ in + $gen_top_bind _loc l$ + end + >> + end + | "lwt"; l = letb_binding; "in"; e = expr -> + <:str_item< let () = Lwt_main.run (let $gen_binding l$ in $gen_bind l e$) >> + ] ]; +END + +(* Replace the anonymous bind [x >> y] by [x >>= fun _ -> y] or [x >>= fun () -> + y] if the strict sequence flag is used. *) +let map_anonymous_bind = object + inherit Ast.map as super + method expr e = match super#expr e with + | <:expr@_loc< $lid:f$ $a$ $b$ >> when f = ">>" -> + if !Pa_lwt_options.strict_sequence then + <:expr< Lwt.bind $a$ (fun () -> $b$) >> + else + <:expr< Lwt.bind $a$ (fun _ -> $b$) >> + | e -> e +end + +let _ = + AstFilters.register_str_item_filter map_anonymous_bind#str_item; + AstFilters.register_topphrase_filter map_anonymous_bind#str_item diff --git a/thirdparty/lwt-2.3.2/syntax/pa_lwt.mli b/thirdparty/lwt-2.3.2/syntax/pa_lwt.mli new file mode 100644 index 0000000..6141166 --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/pa_lwt.mli @@ -0,0 +1,175 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Pa_lwt + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Syntactic sugars for lwt *) + +(** This extension add the following sugars: + + - anonymous bind: + + {[ + write stdio "Hello, " >> write stdio "world!" + ]} + + - lwt-binding: + + {[ + lwt ch = get_char stdin in + code + ]} + + is the same as [bind (get_char stdin) (fun ch -> code)] + + Moreover it supports parallel binding: + + {[ + lwt x = do_something1 () + and y = do_something2 in + code + ]} + + will let [do_something1 ()] and [do_something2 ()] runs then + bind their result to [x] and [y]. It is the same as: + + {[ + let t1 = do_something1 + and t2 = do_something2 in + bind t1 (fun x -> bind t2 (fun y -> code)) + ]} + + - exception catching: + + {[ + try_lwt + + ]}, + + {[ + try_lwt + + with + + ]}, + + {[ + try_lwt + + finally + + ]} + + and: + + {[ + try_lwt + + with + + finally + + ]} + + For example: + + {[ + try_lwt + f x + with + | Failure msg -> + prerr_endline msg; + return () + ]} + + is expanded to: + + {[ + catch (fun _ -> f x) + (function + | Failure msg -> + prerr_endline msg; + return () + | exn -> + Lwt.fail exn) + ]} + + Note that the [exn -> Lwt.fail exn] branch is automatically addedd + when needed. + + The construction [try_lwt ] just catch regular exception + into lwt exception. i.e. it is the same as [catch (fun _ -> ) fail]. + + - exception raising: + + {[ + raise_lwt + ]} + + This allow exception to be traced when the -lwt-debug switch is passed + to the syntax extension. + + - assertion: + + {[ + assert_lwt + ]} + + - for loop: + + {[ + for_lwt i = to do + + done + ]} + + and: + + {[ + for_lwt i = downto do + + done + ]} + + - iteration over streams: + + {[ + for_lwt in do + + done + ]} + + - while loop: + + {[ + while_lwt do + + done + ]} + + - pattern mattching: + + {[ + match_lwt with + | -> + ... + | -> + ]} +*) diff --git a/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.ml b/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.ml new file mode 100644 index 0000000..5bf451c --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.ml @@ -0,0 +1,127 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Pa_lwt_log + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Camlp4.PreCast + +let levels = [ + "Fatal"; + "Error"; + "Warning"; + "Notice"; + "Info"; + "Debug"; +] + +let module_name _loc = + let file_name = Loc.file_name _loc in + if file_name = "" then + "" + else + String.capitalize (Filename.basename (try + Filename.chop_extension file_name + with Invalid_argument _ -> + file_name)) + +let rec apply e = function + | [] -> e + | x :: l -> let _loc = Ast.loc_of_expr x in apply <:expr< $e$ $x$ >> l + +let split e = + let rec aux section acc = function + | <:expr@_loc< Lwt_log.$lid:func$ >> -> + let level = + String.capitalize ( + let len = String.length func in + if len >= 2 && func.[len - 2] = '_' && func.[len - 1] = 'f' then + String.sub func 0 (len - 2) + else + func + ) + in + if level = "Debug" && (not !Pa_lwt_options.debug) then + `Delete + else if List.mem level levels then + `Log(func, section, level, acc) + else + `Not_a_log + | <:expr@loc< $a$ $b$ >> -> begin + match b with + | <:expr< ~section >> -> + aux `Label (b :: acc) a + | <:expr@_loc< ~section:$section$ >> -> + aux (`Expr section) (<:expr< ~section:__pa_log_section >> :: acc) a + | b -> + aux section (b :: acc) a + end + | _ -> + `Not_a_log + in + aux `None [] e + +let make_loc _loc = + <:expr< + ($str:Loc.file_name _loc$, + $int:string_of_int (Loc.start_line _loc)$, + $int:string_of_int (Loc.start_off _loc - Loc.start_bol _loc)$) + >> + +let map = +object + inherit Ast.map as super + + method expr e = + let _loc = Ast.loc_of_expr e in + match split e with + | `Delete -> + <:expr< Lwt.return () >> + | `Log(func, `None, level, args) -> + let args = List.map super#expr args in + <:expr< + if Lwt_log.$uid:level$ >= Lwt_log.Section.level Lwt_log.Section.main then + $apply <:expr< Lwt_log.$lid:func$ ~location:$make_loc _loc$ >> args$ + else + Lwt.return () + >> + | `Log(func, `Label, level, args) -> + let args = List.map super#expr args in + <:expr< + if Lwt_log.$uid:level$ >= Lwt_log.Section.level section then + $apply <:expr< Lwt_log.$lid:func$ ~location:$make_loc _loc$ >> args$ + else + Lwt.return () + >> + | `Log(func, `Expr section, level, args) -> + let args = List.map super#expr args in + <:expr< + let __pa_log_section = $section$ in + if Lwt_log.$uid:level$ >= Lwt_log.Section.level __pa_log_section then + $apply <:expr< Lwt_log.$lid:func$ ~location:$make_loc _loc$ >> args$ + else + Lwt.return () + >> + | `Not_a_log -> + super#expr e +end + +let () = + AstFilters.register_str_item_filter map#str_item; + AstFilters.register_topphrase_filter map#str_item; diff --git a/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.mli b/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.mli new file mode 100644 index 0000000..46ca612 --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/pa_lwt_log.mli @@ -0,0 +1,47 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Pa_lwt_log + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Logging facility + + It replaces expression of the form: + + {[ + Lwt_log.info_f ~section "x = %d" x + ]} + + by + + {[ + if Lwt_log.Section.level section <= Lwt_log.Info then + Lwt_log.info_f ~section "x = %d" x + else + return () + ]} + + Note: + + - the application must be complete. For example: [Log.info "%d"] + will make compilation to fail + + - it also add the command line flags "-lwt-debug" to keep all debug + messages. By default debug messages are removed. +*) diff --git a/thirdparty/lwt-2.3.2/syntax/pa_lwt_options.ml b/thirdparty/lwt-2.3.2/syntax/pa_lwt_options.ml new file mode 100644 index 0000000..e980743 --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/pa_lwt_options.ml @@ -0,0 +1,31 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Pa_lwt_options + * Copyright (C) 2010 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +let debug = ref false +let strict_sequence = ref false + +let () = + Camlp4.Options.add "-lwt-debug" (Arg.Set debug) "debugging mode" + +let () = + Camlp4.Options.add "-lwt-strict-sequence" (Arg.Set strict_sequence) + "check left hand side of >> for non unit expressions " diff --git a/thirdparty/lwt-2.3.2/syntax/pa_optcomp.ml b/thirdparty/lwt-2.3.2/syntax/pa_optcomp.ml new file mode 100644 index 0000000..583248f --- /dev/null +++ b/thirdparty/lwt-2.3.2/syntax/pa_optcomp.ml @@ -0,0 +1,709 @@ +(* + * pa_optcomp.ml + * ------------- + * Copyright : (c) 2008, Jeremie Dimino + * Licence : BSD3 + * + * This file is a part of optcomp. + *) + +open Camlp4.Sig +open Camlp4.PreCast + +external filter : 'a Gram.not_filtered -> 'a = "%identity" +external not_filtered : 'a -> 'a Gram.not_filtered = "%identity" + +(* Subset of supported caml types *) +type typ = + | Tvar of string + | Tbool + | Tint + | Tchar + | Tstring + | Ttuple of typ list + +(* Subset of supported caml values *) +type value = + | Bool of bool + | Int of int + | Char of char + | String of string + | Tuple of value list + +type ident = string + (* An identifier. It is either a lower or a upper identifier. *) + +module Env = Map.Make(struct type t = ident let compare = compare end) + +type env = value Env.t + +type directive = + | Dir_let of ident * Ast.expr + | Dir_default of ident * Ast.expr + | Dir_if of Ast.expr + | Dir_else + | Dir_elif of Ast.expr + | Dir_endif + | Dir_include of Ast.expr + | Dir_error of Ast.expr + | Dir_warning of Ast.expr + | Dir_directory of Ast.expr + + (* This one is not part of optcomp but this is one of the directives + handled by camlp4 we probably want to use. *) + | Dir_default_quotation of Ast.expr + +(* Quotations are evaluated by the token filters, but are expansed + after. Evaluated quotations are kept in this table, which quotation + id to to values: *) +let quotations : (int, value) Hashtbl.t = Hashtbl.create 42 + +let next_quotation_id = + let r = ref 0 in + fun _ -> incr r; !r + +(* +-------------+ + | Environment | + +-------------+ *) + +let env = ref Env.empty +let define id value = env := Env.add id value !env + +let _ = + define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> Tuple [Int major; Int minor])) + +let dirs = ref [] +let add_include_dir dir = dirs := dir :: !dirs + +(* +--------------+ + | Dependencies | + +--------------+ *) + +module String_set = Set.Make(String) + +(* All depencies of the file being parsed *) +let dependencies = ref String_set.empty + +(* Where to write dependencies *) +let dependency_filename = ref None + +(* The file being parsed. This is set when the first (token, location) + pair is fetched. *) +let source_filename = ref None + +let write_depencies () = + match !dependency_filename, !source_filename with + | None, _ + | _, None -> + () + + | Some dependency_filename, Some source_filename -> + let oc = open_out dependency_filename in + if not (String_set.is_empty !dependencies) then begin + output_string oc "# automatically generated by optcomp\n"; + output_string oc source_filename; + output_string oc ": "; + output_string oc (String.concat " " (String_set.elements !dependencies)); + output_char oc '\n' + end; + close_out oc + +(* +----------------------------------------+ + | Value to expression/pattern conversion | + +----------------------------------------+ *) + +let rec expr_of_value _loc = function + | Bool true -> <:expr< true >> + | Bool false -> <:expr< false >> + | Int x -> <:expr< $int:string_of_int x$ >> + | Char x -> <:expr< $chr:Char.escaped x$ >> + | String x -> <:expr< $str:String.escaped x$ >> + | Tuple [] -> <:expr< () >> + | Tuple [x] -> expr_of_value _loc x + | Tuple l -> <:expr< $tup:Ast.exCom_of_list (List.map (expr_of_value _loc) l)$ >> + +let rec patt_of_value _loc = function + | Bool true -> <:patt< true >> + | Bool false -> <:patt< false >> + | Int x -> <:patt< $int:string_of_int x$ >> + | Char x -> <:patt< $chr:Char.escaped x$ >> + | String x -> <:patt< $str:String.escaped x$ >> + | Tuple [] -> <:patt< () >> + | Tuple [x] -> patt_of_value _loc x + | Tuple l -> <:patt< $tup:Ast.paCom_of_list (List.map (patt_of_value _loc) l)$ >> + +(* +-----------------------+ + | Expression evaluation | + +-----------------------+ *) + +let rec type_of_value = function + | Bool _ -> Tbool + | Int _ -> Tint + | Char _ -> Tchar + | String _ -> Tstring + | Tuple l -> Ttuple (List.map type_of_value l) + +let rec string_of_type = function + | Tvar v -> "'" ^ v + | Tbool -> "bool" + | Tint -> "int" + | Tchar -> "char" + | Tstring -> "string" + | Ttuple l -> "(" ^ String.concat " * " (List.map string_of_type l) ^ ")" + +let invalid_type loc expected real = + Loc.raise loc (Failure + (Printf.sprintf "this expression has type %s but is used with type %s" + (string_of_type real) (string_of_type expected))) + +let type_of_patt patt = + let rec aux (a, n) = function + | <:patt< $tup:x$ >> -> + let l, x = List.fold_left + (fun (l, x) patt -> let t, x = aux x patt in (t :: l, x)) + ([], (a, n)) (Ast.list_of_patt x []) in + (Ttuple(List.rev l), x) + | _ -> + (Tvar(Printf.sprintf "%c%s" + (char_of_int (Char.code 'a' + a)) + (if n = 0 then "" else string_of_int n)), + if a = 25 then (0, n + 1) else (a + 1, n)) + in + fst (aux (0, 0) patt) + +let rec eval env = function + + (* Literals *) + | <:expr< true >> -> Bool true + | <:expr< false >> -> Bool false + | <:expr< $int:x$ >> -> Int(int_of_string x) + | <:expr< $chr:x$ >> -> Char(Camlp4.Struct.Token.Eval.char x) + | <:expr< $str:x$ >> -> String(Camlp4.Struct.Token.Eval.string ~strict:() x) + + (* Tuples *) + | <:expr< $tup:x$ >> -> Tuple(List.map (eval env) (Ast.list_of_expr x [])) + + (* Variables *) + | <:expr@loc< $lid:x$ >> + | <:expr@loc< $uid:x$ >> -> + begin try + Env.find x env + with + Not_found -> + Loc.raise loc (Failure (Printf.sprintf "unbound value %s" x)) + end + + (* Value comparing *) + | <:expr< $x$ = $y$ >> -> let x, y = eval_same env x y in Bool(x = y) + | <:expr< $x$ < $y$ >> -> let x, y = eval_same env x y in Bool(x < y) + | <:expr< $x$ > $y$ >> -> let x, y = eval_same env x y in Bool(x > y) + | <:expr< $x$ <= $y$ >> -> let x, y = eval_same env x y in Bool(x <= y) + | <:expr< $x$ >= $y$ >> -> let x, y = eval_same env x y in Bool(x >= y) + | <:expr< $x$ <> $y$ >> -> let x, y = eval_same env x y in Bool(x <> y) + + (* min and max *) + | <:expr< min $x$ $y$ >> -> let x, y = eval_same env x y in min x y + | <:expr< max $x$ $y$ >> -> let x, y = eval_same env x y in max x y + + (* Arithmetic *) + | <:expr< $x$ + $y$ >> -> Int(eval_int env x + eval_int env y) + | <:expr< $x$ - $y$ >> -> Int(eval_int env x - eval_int env y) + | <:expr< $x$ * $y$ >> -> Int(eval_int env x * eval_int env y) + | <:expr< $x$ / $y$ >> -> Int(eval_int env x / eval_int env y) + | <:expr< $x$ mod $y$ >> -> Int(eval_int env x mod eval_int env y) + + (* Boolean operations *) + | <:expr< not $x$ >> -> Bool(not (eval_bool env x)) + | <:expr< $x$ or $y$ >> -> Bool(eval_bool env x or eval_bool env y) + | <:expr< $x$ || $y$ >> -> Bool(eval_bool env x || eval_bool env y) + | <:expr< $x$ && $y$ >> -> Bool(eval_bool env x && eval_bool env y) + + (* String operations *) + | <:expr< $x$ ^ $y$ >> -> String(eval_string env x ^ eval_string env y) + + (* Pair operations *) + | <:expr< fst $x$ >> -> fst (eval_pair env x) + | <:expr< snd $x$ >> -> snd (eval_pair env x) + + (* Let-binding *) + | <:expr< let $p$ = $x$ in $y$ >> -> + let vx = eval env x in + let env = + try + bind env p vx + with + Exit -> invalid_type (Ast.loc_of_expr x) (type_of_patt p) (type_of_value vx) + in + eval env y + + | e -> Loc.raise (Ast.loc_of_expr e) (Stream.Error "expression not supported") + +and bind env patt value = match patt with + | <:patt< $lid:id$ >> -> + Env.add id value env + + | <:patt< $tup:patts$ >> -> + let patts = Ast.list_of_patt patts [] in + begin match value with + | Tuple values when List.length values = List.length patts -> + List.fold_left2 bind env patts values + | _ -> + raise Exit + end + + | _ -> + Loc.raise (Ast.loc_of_patt patt) (Stream.Error "pattern not supported") + +and eval_same env ex ey = + let vx = eval env ex and vy = eval env ey in + let tx = type_of_value vx and ty = type_of_value vy in + if tx = ty then + (vx, vy) + else + invalid_type (Ast.loc_of_expr ey) tx ty + +and eval_int env e = match eval env e with + | Int x -> x + | v -> invalid_type (Ast.loc_of_expr e) Tint (type_of_value v) + +and eval_bool env e = match eval env e with + | Bool x -> x + | v -> invalid_type (Ast.loc_of_expr e) Tbool (type_of_value v) + +and eval_string env e = match eval env e with + | String x -> x + | v -> invalid_type (Ast.loc_of_expr e) Tstring (type_of_value v) + +and eval_pair env e = match eval env e with + | Tuple [x; y] -> (x, y) + | v -> invalid_type (Ast.loc_of_expr e) (Ttuple [Tvar "a"; Tvar "b"]) (type_of_value v) + +(* +-----------------------+ + | Parsing of directives | + +-----------------------+ *) + +let rec skip_space stream = match Stream.peek stream with + | Some((BLANKS _ | COMMENT _), _) -> + Stream.junk stream; + skip_space stream + | _ -> + () + +let parse_equal stream = + skip_space stream; + match Stream.next stream with + | KEYWORD "=", _ -> () + | _, loc -> Loc.raise loc (Stream.Error "'=' expected") + +let rec parse_eol stream = + let tok, loc = Stream.next stream in + match tok with + | BLANKS _ | COMMENT _ -> + parse_eol stream + | NEWLINE | EOI -> + () + | _ -> + Loc.raise loc (Stream.Error "end of line expected") + +(* Return wether a keyword can be interpreted as an identifier *) +let keyword_is_id str = + let rec aux i = + if i = String.length str then + true + else + match str.[i] with + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' -> + aux (i + 1) + | _ -> + false + in + aux 0 + +let parse_ident stream = + skip_space stream; + let tok, loc = Stream.next stream in + begin match tok with + | LIDENT id | UIDENT id -> + id + | KEYWORD kwd when keyword_is_id kwd -> + kwd + | _ -> + Loc.raise loc (Stream.Error "identifier expected") + end + +let parse_expr stream = + (* Lists of opened brackets *) + let opened_brackets = ref [] in + + (* Return the next token of [stream] until all opened parentheses + have been closed and a newline is reached *) + let rec next_token _ = + Some(match Stream.next stream, !opened_brackets with + | (NEWLINE, loc), [] -> + EOI, loc + + | (KEYWORD("(" | "[" | "{" as b), _) as x, l -> + opened_brackets := b :: l; + x + + | (KEYWORD ")", loc) as x, "(" :: l -> + opened_brackets := l; + x + + | (KEYWORD "]", loc) as x, "[" :: l -> + opened_brackets := l; + x + + | (KEYWORD "}", loc) as x, "{" :: l -> + opened_brackets := l; + x + + | x, _ -> + x) + in + + Gram.parse_tokens_before_filter Syntax.expr_eoi + (not_filtered (Stream.from next_token)) + +let parse_directive stream = match Stream.peek stream with + | Some(KEYWORD "#", loc) -> + Stream.junk stream; + + (* Move the location to the beginning of the line *) + let (file_name, + start_line, start_bol, start_off, + stop_line, stop_bol, stop_off, + ghost) = Loc.to_tuple loc in + let loc = Loc.of_tuple (file_name, + start_line, start_bol, start_bol, + start_line, start_bol, start_bol, + ghost) in + + begin match parse_ident stream with + + | "let" -> + let id = parse_ident stream in + parse_equal stream; + let expr = parse_expr stream in + Some(Dir_let(id, expr), loc) + + | "let_default" -> + let id = parse_ident stream in + parse_equal stream; + let expr = parse_expr stream in + Some(Dir_default(id, expr), loc) + + (* For compatibility *) + | "define" -> + let id = parse_ident stream in + let expr = parse_expr stream in + Some(Dir_let(id, expr), loc) + + (* For compatibility *) + | "default" -> + let id = parse_ident stream in + let expr = parse_expr stream in + Some(Dir_default(id, expr), loc) + + | "if" -> + Some(Dir_if(parse_expr stream), loc) + + | "else" -> + parse_eol stream; + Some(Dir_else, loc) + + | "elif" -> + Some(Dir_elif(parse_expr stream), loc) + + | "endif" -> + parse_eol stream; + Some(Dir_endif, loc) + + | "include" -> + Some(Dir_include(parse_expr stream), loc) + + | "directory" -> + Some(Dir_directory(parse_expr stream), loc) + + | "error" -> + Some(Dir_error(parse_expr stream), loc) + + | "warning" -> + Some(Dir_warning(parse_expr stream), loc) + + | "default_quotation" -> + Some(Dir_default_quotation(parse_expr stream), loc) + + | dir -> + Loc.raise loc (Stream.Error (Printf.sprintf "bad directive ``%s''" dir)) + end + + | _ -> + None + +let parse_command_line_define str = + match Gram.parse_string Syntax.expr (Loc.mk "") str with + | <:expr< $lid:id$ = $e$ >> + | <:expr< $uid:id$ = $e$ >> -> define id (eval !env e) + | _ -> invalid_arg str + +(* +----------------+ + | BLock skipping | + +----------------+ *) + +let rec skip_line stream = + match Stream.next stream with + | NEWLINE, _ -> () + | EOI, loc -> Loc.raise loc (Stream.Error "#endif missing") + | _ -> skip_line stream + +let rec next_directive stream = match parse_directive stream with + | Some dir -> dir + | None -> skip_line stream; next_directive stream + +let rec next_endif stream = + let dir, loc = next_directive stream in + match dir with + | Dir_if _ -> skip_if stream; next_endif stream + | Dir_else + | Dir_elif _ + | Dir_endif -> dir + | _ -> next_endif stream + +and skip_if stream = + let dir, loc = next_directive stream in + match dir with + | Dir_if _ -> + skip_if stream; + skip_if stream + + | Dir_else -> + skip_else stream + + | Dir_elif _ -> + skip_if stream + + | Dir_endif -> + () + + | _ -> skip_if stream + +and skip_else stream = + let dir, loc = next_directive stream in + match dir with + | Dir_if _ -> + skip_if stream; + skip_else stream + + | Dir_else -> + Loc.raise loc (Stream.Error "#else without #if") + + | Dir_elif _ -> + Loc.raise loc (Stream.Error "#elif without #if") + + | Dir_endif -> + () + + | _ -> + skip_else stream + +(* +-----------------+ + | Token filtering | + +-----------------+ *) + +type context = Ctx_if | Ctx_else + +(* State of the token filter *) +type state = { + stream : (Gram.Token.t * Loc.t) Stream.t; + (* Input stream *) + + mutable bol : bool; + (* Wether we are at the beginning of a line *) + + mutable stack : context list; + (* Nested contexts *) + + on_eoi : Gram.Token.t * Loc.t -> Gram.Token.t * Loc.t; + (* Eoi handler, it is used to restore the previous sate on #include + directives *) +} + +(* Read and return one token *) +let really_read state = + let tok, loc = Stream.next state.stream in + state.bol <- tok = NEWLINE; + match tok with + | QUOTATION ({ q_name = "optcomp" } as quot) -> + let id = next_quotation_id () in + Hashtbl.add quotations id (eval !env (Gram.parse_string + Syntax.expr_eoi + (Loc.move `start quot.q_shift loc) + quot.q_contents)); + + (* Replace the quotation by its id *) + (QUOTATION { quot with q_contents = string_of_int id }, loc) + + | EOI -> + (* If end of input is reached, we call the eoi handler. It may + continue if we were parsing an included file *) + if state.stack <> [] then + Loc.raise loc (Stream.Error "#endif missing"); + state.on_eoi (tok, loc) + + | _ -> + (tok, loc) + +(* Return the next token from a stream, interpreting directives. *) +let rec next_token state_ref = + let state = !state_ref in + if state.bol then + match parse_directive state.stream, state.stack with + | Some(Dir_if e, _), _ -> + let rec aux e = + if eval_bool !env e then begin + state.stack <- Ctx_if :: state.stack; + next_token state_ref + end else + match next_endif state.stream with + | Dir_else -> + state.stack <- Ctx_else :: state.stack; + next_token state_ref + + | Dir_elif e -> + aux e + + | Dir_endif -> + next_token state_ref + + | _ -> + assert false + in + aux e + + | Some(Dir_else, loc), ([] | Ctx_else :: _) -> + Loc.raise loc (Stream.Error "#else without #if") + + | Some(Dir_elif _, loc), ([] | Ctx_else :: _) -> + Loc.raise loc (Stream.Error "#elif without #if") + + | Some(Dir_endif, loc), [] -> + Loc.raise loc (Stream.Error "#endif without #if") + + | Some(Dir_else, loc), Ctx_if :: l -> + skip_else state.stream; + state.stack <- l; + next_token state_ref + + | Some(Dir_elif _, loc), Ctx_if :: l -> + skip_if state.stream; + state.stack <- l; + next_token state_ref + + | Some(Dir_endif, loc), _ :: l -> + state.stack <- l; + next_token state_ref + + | Some(Dir_let(id, e), _), _ -> + define id (eval !env e); + next_token state_ref + + | Some(Dir_default(id, e), _), _ -> + if not (Env.mem id !env) then + define id (eval !env e); + next_token state_ref + + | Some(Dir_include e, _), _ -> + let fname = eval_string !env e in + (* Try to looks up in all include directories *) + let fname = + try + List.find (fun dir -> Sys.file_exists (Filename.concat dir fname)) !dirs + with + (* Just try in the current directory *) + Not_found -> fname + in + dependencies := String_set.add fname !dependencies; + let ic = open_in fname in + let nested_state = { + stream = Gram.Token.Filter.filter (Gram.get_filter ()) (filter (Gram.lex (Loc.mk fname) (Stream.of_channel ic))); + bol = true; + stack = []; + on_eoi = (fun _ -> + (* Restore previous state and close channel on + eoi *) + state_ref := state; + close_in ic; + next_token state_ref) + } in + (* Replace current state with the new one *) + state_ref := nested_state; + next_token state_ref + + | Some(Dir_directory e, loc), _ -> + let dir = eval_string !env e in + add_include_dir dir; + next_token state_ref + + | Some(Dir_error e, loc), _ -> + Loc.raise loc (Failure (eval_string !env e)) + + | Some(Dir_warning e, loc), _ -> + Syntax.print_warning loc (eval_string !env e); + next_token state_ref + + | Some(Dir_default_quotation e, loc), _ -> + Syntax.Quotation.default := eval_string !env e; + next_token state_ref + + | None, _ -> + really_read state + + else + really_read state + +let stream_filter filter stream = + (* Set the source filename *) + begin match !source_filename with + | Some _ -> + () + | None -> + match Stream.peek stream with + | None -> + () + | Some(tok, loc) -> + source_filename := Some(Loc.file_name loc) + end; + let state_ref = ref { stream = stream; + bol = true; + stack = []; + on_eoi = (fun x -> x) } in + filter (Stream.from (fun _ -> Some(next_token state_ref))) + +(* +----------------------+ + | Quotations expansion | + +----------------------+ *) + +let expand f loc _ contents = + try + f loc (Hashtbl.find quotations (int_of_string contents)) + with + exn -> Loc.raise loc (Failure "fatal error in optcomp!") + +(* +--------------+ + | Registration | + +--------------+ *) + +let _ = + Camlp4.Options.add "-let" (Arg.String parse_command_line_define) + " Binding for a #let directive."; + Camlp4.Options.add "-depend" + (Arg.String (fun filename -> dependency_filename := Some filename)) + " Write dependencies to ."; + + Pervasives.at_exit write_depencies; + + Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.expr_tag (expand expr_of_value); + Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.patt_tag (expand patt_of_value); + + Gram.Token.Filter.define_filter (Gram.get_filter ()) stream_filter diff --git a/thirdparty/lwt-2.3.2/tests/META b/thirdparty/lwt-2.3.2/tests/META new file mode 100644 index 0000000..ceba0ee --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/META @@ -0,0 +1,9 @@ +# OASIS_START +# DO NOT EDIT (digest: 5cec65fa74f26fc5d2c2466b1d89ccdf) +version = "2.3.2" +description = "Lightweight thread library for Objective Caml" +archive(byte) = "test.cma" +archive(native) = "test.cmxa" +exists_if = "test.cma" +# OASIS_STOP + diff --git a/thirdparty/lwt-2.3.2/tests/core/main.ml b/thirdparty/lwt-2.3.2/tests/core/main.ml new file mode 100644 index 0000000..44aa78a --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/core/main.ml @@ -0,0 +1,27 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Main + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +Test.run "core" [ + Test_lwt.suite; + Test_lwt_stream.suite; + Test_lwt_util.suite; +] diff --git a/thirdparty/lwt-2.3.2/tests/core/test_lwt.ml b/thirdparty/lwt-2.3.2/tests/core/test_lwt.ml new file mode 100644 index 0000000..711cdef --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/core/test_lwt.ml @@ -0,0 +1,552 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Test_lwt + * Copyright (C) 2010 Jérémie Dimino, Pierre Chambart + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Test +open Lwt + +let ( <=> ) v v' = + assert ( state v = v') + +let test_exn f v e = + assert ( try f v;assert false with exn -> exn = e) + +let f x = return ("test"^x) +let g x = ("test"^x) + +exception Exn + +let key : int key = new_key () + +let suite = suite "lwt" [ + test "0" + (fun () -> + return "test" <=> Return "test"; + fail Exn <=> Fail Exn; + bind (return "test") f <=> Return "testtest"; + bind (fail Exn) return <=> Fail Exn; + (return "test") >>= f <=> Return "testtest"; + f =<< (return "test") <=> Return "testtest"; + map g (return "test") <=> Return "testtest"; + (return "test") >|= g <=> Return "testtest"; + g =|< (return "test") <=> Return "testtest"; + return true); + + test "1" + (fun () -> + catch return (fun e -> return ()) <=> Return (); + catch (fun () -> fail Exn) (function Exn -> return ()| e -> assert false) <=> Return (); + catch (fun () -> fail Exn) (fun e -> fail e) <=> Fail Exn; + return true); + + test "2" + (fun () -> + try_bind return return ( fun e -> assert false ) <=> Return (); + try_bind (fun () -> fail Exn) return (function Exn -> return ()| e -> assert false) <=> Return (); + return true); + + test "3" + (fun () -> + finalize return return <=> Return (); + finalize (fun () -> fail Exn) return <=> Fail Exn; + return true); + + test "4" + (fun () -> + apply (fun () -> raise Exn) () <=> Fail Exn; + return true); + + test "5" + (fun () -> + choose [return ()] <=> Return (); + return () return () <=> Return (); + return true); + + test "6" + (fun () -> + join [return ()] <=> Return (); + return () <&> return () <=> Return (); + return true); + + test "7" + (fun () -> + assert (ignore_result (return ()) = ()); + test_exn ignore_result (fail Exn) Exn; + return true); + + test "8" + (fun () -> + let t,w = wait () in + t <=> Sleep; + wakeup w (); + t <=> Return (); + return true); + + test "9" + (fun () -> + let t,w = wait () in + wakeup_exn w Exn; + t <=> Fail Exn; + return true); + + test "10" + (fun () -> + let t,w = task () in + t <=> Sleep; + wakeup w (); + t <=> Return (); + return true); + + test "11" + (fun () -> + let t,w = wait () in + let r1 = choose [t] in r1 <=> Sleep; + choose [t;return ()] <=> Return (); + join [fail Exn;t] <=> Sleep; + let r2 = join [t] in r2 <=> Sleep; + let r3 = join [t;return ()] in r3 <=> Sleep; + wakeup w (); + r1 <=> Return (); r2 <=> Return (); r3 <=> Return (); + return true); + + test "12" + (fun () -> + let t,w = wait () in + let t',w' = wait () in + let r1 = join [return ();t] in + let r2 = join [t;t'] in + wakeup_exn w Exn; + r1 <=> Fail Exn; + r2 <=> Sleep; + return true); + + test "13" + (fun () -> + let t,w = wait () in + let t',w' = wait () in + let r = bind (choose [t;t']) return in + r <=> Sleep; + wakeup w' (); + r <=> Return (); + let r' = bind (choose [t;t]) return in + wakeup w (); + r' <=> Return (); + return true); + + test "14" + (fun () -> + assert ( poll (return ()) = Some () ); + test_exn poll (fail Exn) Exn; + let t,w = wait () in + assert ( poll t = None ); + return true); + + test "15" + (fun () -> + let t,w = wait () in + assert ( ignore_result t = () ); + wakeup w (); + let t,w = wait () in + ignore_result t; + (* XXX c'est quand meme un comportement bizare *) + test_exn (wakeup_exn w) Exn Exn; + return true); + + test "16" + (fun () -> + let t,w = wait () in + let r1 = catch (fun () -> t) (fun e -> return ()) in r1 <=> Sleep; + let r2 = try_bind (fun () -> t) return ( fun e -> assert false ) in r2 <=> Sleep; + wakeup w (); + r1 <=> Return (); + r2 <=> Return (); + return true); + + (****) + + test "17" + (fun () -> + let t,w = task () in + let t',w' = wait () in + let t'' = return () in + cancel t; + cancel t'; + cancel t''; + t <=> Fail Canceled; + t' <=> Sleep; + t'' <=> Return () ; + return true); + + test "18" + (fun () -> + let t,w = task () in + let r = bind t return in + cancel r; + r <=> Fail Canceled; + return true); + + test "19" + (fun () -> + let t,w = task () in + on_cancel t (fun () -> ()); + on_cancel t (fun () -> raise Exn); + on_cancel (return ()) (fun () -> assert false); + cancel t; + on_cancel t (fun () -> ()); + let t,w = wait () in + on_cancel t (fun () -> ()); + wakeup w (); + return true); + + test "20" + (fun () -> + let t,w = task () in + let t',w' = wait () in + let r = pick [t;t'] in r <=> Sleep; + wakeup w' (); + r <=> Return (); + t <=> Fail Canceled; + return true); + + test "21" + (fun () -> + pick [return ()] <=> Return (); + return true); + + test "22" + (fun () -> + let t,w = task () in + let t',w' = wait () in + let r = pick [t;t'] in + cancel r; + r <=> Fail Canceled; + t <=> Fail Canceled; + return true); + + test "23" + (fun () -> + let t,w = task () in + let r = join [t] in + cancel r; + r <=> Fail Canceled; + t <=> Fail Canceled; + return true); + + test "24" + (fun () -> + let t,w = task () in + let r = choose [t] in + cancel r; + r <=> Fail Canceled; + t <=> Fail Canceled; + return true); + + test "25" + (fun () -> + let t,w = task () in + let r = catch (fun () -> t) (function Canceled -> return ()| _ -> assert false) in + cancel r; + r <=> Return (); + t <=> Fail Canceled; + return true); + + test "26" + (fun () -> + let t,w = task () in + let r = try_bind (fun () -> t) (fun _ -> assert false) (function Canceled -> return ()| _ -> assert false) in + cancel r; + r <=> Return (); + t <=> Fail Canceled; + return true); + + test "27" + (fun () -> + let t,w = wait () in + wakeup w (); + test_exn (wakeup w) () (Invalid_argument "Lwt.wakeup"); + return true); + + test "28" + (fun () -> + let t,w = task () in + cancel t; + wakeup w (); + return true); + + test "29" + (fun () -> + let t,w = wait () in + let t',w' = wait () in + let r = bind t ( fun () -> t' ) in + let r' = bind t ( fun () -> r ) in + wakeup w (); + r <=> Sleep; + r' <=> Sleep; + wakeup w' (); + r <=> Return (); + r' <=> Return (); + return true); + + test "30" + (fun () -> + let t,w = wait () in + let t',w' = wait () in + let t'',w'' = wait () in + let r = bind t ( fun () -> t' ) in + let r' = bind t'' ( fun () -> r ) in + wakeup w'' (); + r <=> Sleep; + r' <=> Sleep; + wakeup w (); + wakeup w' (); + r' <=> Return (); + r <=> Return (); + return true); + + test "31" + (fun () -> + let t,w = wait () in + let a = ref (return ()) in + let r = bind t ( fun () -> !a ) in + a := r; + wakeup w (); + return true); + + test "choose" + (fun () -> + let t1,w1 = wait () in + let t2,w2 = wait () in + let rec f = function + | 0 -> [] + | i -> (choose [t1;t2])::(f (i-1)) + in + let l = f 100 in + t1 <=> Sleep; + t2 <=> Sleep; + List.iter (fun t -> t <=> Sleep) l; + wakeup w1 (); + List.iter (fun t -> t <=> Return ()) l; + t1 <=> Return (); + t2 <=> Sleep; + return true); + + test "protected return" + (fun () -> + let t = return 1 in + let t' = protected t in + return ((state t' = Return 1) && (state t = Return 1))); + + test "protected fail" + (fun () -> + let t = fail Exn in + let t' = protected t in + return ((state t' = Fail Exn) && (state t = Fail Exn))); + + test "protected wait 1" + (fun () -> + let t,w = wait () in + let t' = protected t in + wakeup w 1; + return ((state t' = Return 1) && (state t = Return 1))); + + test "protected wait 2" + (fun () -> + let t,w = wait () in + let t' = protected t in + wakeup_exn w Exn; + return ((state t' = Fail Exn) && (state t = Fail Exn))); + + test "protected wait 3" + (fun () -> + let t,w = wait () in + let t' = protected t in + cancel t'; + return ((state t' = Fail Canceled) && (state t = Sleep))); + + test "protected wait 4" + (fun () -> + let t,w = wait () in + let t' = protected t in + cancel t'; + wakeup w 1; + return ((state t' = Fail Canceled) && (state t = Return 1))); + + test "protected wait 5" + (fun () -> + let t,w = wait () in + let t' = protected t in + cancel t'; + wakeup_exn w Exn; + return ((state t' = Fail Canceled) && (state t = Fail Exn))); + + test "protected wait 6" + (fun () -> + let t,w = wait () in + let t' = protected t in + wakeup_exn w Exn; + cancel t'; + return ((state t' = Fail Exn) && (state t = Fail Exn))); + + test "protected wait 7" + (fun () -> + let t,w = wait () in + let t' = protected t in + wakeup w 1; + cancel t'; + return ((state t' = Return 1) && (state t = Return 1))); + + test "join 1" + (fun () -> + let t1 = fail Exn in + let t2 = join [t1] in + return ((state t1 = Fail Exn) && (state t2 = Fail Exn))); + + test "join 2" + (fun () -> + let t1,w1 = wait () in + let t2 = join [t1] in + wakeup_exn w1 Exn; + return ((state t1 = Fail Exn) && (state t2 = Fail Exn))); + + test "join 3" + (fun () -> + let t1 = fail Exn in + let t2,w2 = wait () in + let t3 = fail Not_found in + let t4 = join [t2;t1;t3] in + return ((state t1 = Fail Exn) && (state t2 = Sleep) && + (state t3 = Fail Not_found) && (state t4 = Sleep))); + + test "join 4" + (fun () -> + let t1 = fail Exn in + let t2,w2 = wait () in + let t3 = return () in + let rec f = function + | 0 -> return true + | i -> + let t = join [t2;t3;t1] in + if ((state t1 = Fail Exn) && (state t2 = Sleep) + && (state t = Sleep) && (state t3 = Return ())) + then f (i-1) + else return false + in + f 100); + + test "cancel loop" + (fun () -> + let rec loop () = + lwt () = Lwt_unix.yield () in + loop () + in + let t = loop () in + cancel t; + return (state t = Fail Canceled)); + + test "cancel loop 2" + (fun () -> + let rec loop () = + lwt () = Lwt_unix.yield () in + loop () + in + let t = loop () in + lwt () = Lwt_unix.yield () in + cancel t; + return (state t = Fail Canceled)); + + test "nchoose" + (fun () -> + lwt l = nchoose [return 1; return 2] in + return (l = [1; 2])); + + test "npick" + (fun () -> + lwt l = npick [return 1; return 2] in + return (l = [1; 2])); + + test "bind/cancel 1" + (fun () -> + let waiter, wakener = wait () in + let t = + lwt () = waiter in + let waiter, wakener = task () in + waiter + in + wakeup wakener (); + cancel t; + return (state t = Fail Canceled)); + + test "bind/cancel 2" + (fun () -> + let waiter, wakener = wait () in + let t = + lwt () = waiter in + let waiter, wakener = task () in + waiter + in + let t = t >>= return in + wakeup wakener (); + cancel t; + return (state t = Fail Canceled)); + + test "bind/cancel 3" + (fun () -> + let waiter1, wakener1 = wait () in + let waiter2, wakener2 = wait () in + let t = + lwt () = waiter1 in + try_lwt + lwt () = waiter2 in + fst (task ()) + with Canceled -> + return true + in + wakeup wakener1 (); + wakeup wakener2 (); + cancel t; + return (state t = Return true)); + + test "data 1" + (fun () -> + with_value key (Some 1) + (fun () -> return (get key = Some 1))); + + test "data 2" + (fun () -> + with_value key (Some 1) + (fun () -> + with_value key (Some 2) + (fun () -> return (get key = Some 2)))); + + test "data 3" + (fun () -> + with_value key (Some 1) + (fun () -> + let waiter, wakener = wait () in + let t = + with_value key (Some 2) + (fun () -> + lwt () = waiter in + return (get key = Some 2)) + in + wakeup wakener (); + t)); +] diff --git a/thirdparty/lwt-2.3.2/tests/core/test_lwt_stream.ml b/thirdparty/lwt-2.3.2/tests/core/test_lwt_stream.ml new file mode 100644 index 0000000..76b15da --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/core/test_lwt_stream.ml @@ -0,0 +1,221 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Test_lwt_stream + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt +open Test + +let suite = suite "lwt_stream" [ + test "from" + (fun () -> + let mvar = Lwt_mvar.create_empty () in + let stream = Lwt_stream.from (fun () -> + lwt x = Lwt_mvar.take mvar in + return (Some x)) in + let t1 = Lwt_stream.next stream in + let t2 = Lwt_stream.next stream in + let t3 = Lwt_stream.next stream in + lwt () = Lwt_mvar.put mvar 1 in + lwt () = Lwt_mvar.put mvar 2 in + lwt () = Lwt_mvar.put mvar 3 in + lwt x1 = t1 and x2 = t2 and x3 = t3 in + return ([x1; x2; x3] = [1; 2; 3])); + + test "clone" + (fun () -> + let stream1 = Lwt_stream.of_list [1; 2; 3] in + let stream2 = Lwt_stream.clone stream1 in + lwt x1_1 = Lwt_stream.next stream1 in + lwt x2_1 = Lwt_stream.next stream2 in + lwt x1_2 = Lwt_stream.next stream1 + and x1_3 = Lwt_stream.next stream1 + and x2_2 = Lwt_stream.next stream2 + and x2_3 = Lwt_stream.next stream2 in + return ([x1_1; x1_2; x1_3] = [1; 2; 3] && [x2_1; x2_2; x2_3] = [1; 2; 3])); + + test "clone 2" + (fun () -> + let stream1, push = Lwt_stream.create () in + push (Some 1); + let stream2 = Lwt_stream.clone stream1 in + let x1_1 = poll (Lwt_stream.next stream1) in + let x1_2 = poll (Lwt_stream.next stream1) in + let x2_1 = poll (Lwt_stream.next stream2) in + let x2_2 = poll (Lwt_stream.next stream2) in + return ([x1_1;x1_2;x2_1;x2_2] = [Some 1;None;Some 1;None])); + + test "create" + (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + push None; + lwt l = Lwt_stream.to_list stream in + return (l = [1; 2; 3])); + + test "create 2" + (fun () -> + let stream, push = Lwt_stream.create () in + push None; + let t = Lwt_stream.next stream in + return (Lwt.state t = Fail Lwt_stream.Empty)); + + test "get_while" + (fun () -> + let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in + lwt l1 = Lwt_stream.get_while (fun x -> x < 3) stream in + lwt l2 = Lwt_stream.to_list stream in + return (l1 = [1; 2] && l2 = [3; 4; 5])); + + test "peek" + (fun () -> + let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in + lwt x = Lwt_stream.peek stream in + lwt y = Lwt_stream.peek stream in + lwt l = Lwt_stream.to_list stream in + return (x = Some 1 && y = Some 1 && l = [1; 2; 3; 4; 5])); + + test "npeek" + (fun () -> + let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in + lwt x = Lwt_stream.npeek 3 stream in + lwt y = Lwt_stream.npeek 1 stream in + lwt l = Lwt_stream.to_list stream in + return (x = [1; 2; 3] && y = [1] && l = [1; 2; 3; 4; 5])); + + test "get_available" + (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + let l = Lwt_stream.get_available stream in + push (Some 4); + lwt x = Lwt_stream.get stream in + return (l = [1; 2; 3] && x = Some 4)); + + test "get_available_up_to" + (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + push (Some 4); + let l = Lwt_stream.get_available_up_to 2 stream in + lwt x = Lwt_stream.get stream in + return (l = [1; 2] && x = Some 3)); + + test "filter" + (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + push (Some 4); + let filtered = Lwt_stream.filter ((=) 3) stream in + lwt x = Lwt_stream.get filtered in + let l = Lwt_stream.get_available filtered in + return (x = Some 3 && l = [])); + + test "filter_map" + (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + push (Some 4); + let filtered = Lwt_stream.filter_map (function 3 -> Some "3" | _ -> None ) stream in + lwt x = Lwt_stream.get filtered in + let l = Lwt_stream.get_available filtered in + return (x = Some "3" && l = [])); + + test "last_new" + (fun () -> + let stream, push = Lwt_stream.create () in + push (Some 1); + push (Some 2); + push (Some 3); + lwt x = Lwt_stream.last_new stream in + return (x = 3)); + + test "cancel push stream 1" + (fun () -> + let stream, push = Lwt_stream.create () in + let t = Lwt_stream.next stream in + cancel t; + return (state t = Fail Canceled)); + + test "cancel push stream 2" + (fun () -> + let stream, push = Lwt_stream.create () in + let t = Lwt_stream.next stream in + cancel t; + push (Some 1); + let t' = Lwt_stream.next stream in + return (state t' = Return 1)); + + (* check if the push function keeps references to the elements in + the stream *) + test "push and GC" + (fun () -> + let w = Weak.create 5 in + (* Count the number of reachable elements in the stream. *) + let count () = + let rec loop acc idx = + if idx = Weak.length w then + acc + else + match Weak.get w idx with + | None -> loop acc (idx + 1) + | Some v -> loop (acc + 1) (idx + 1) + in + loop 0 0 + in + (* Run some test and return the push function of the stream. *) + let test () = + let stream, push = Lwt_stream.create () in + assert (count () = 0); + let r1 = Some(ref 1) in + push r1; + Weak.set w 1 r1; + let r2 = Some(ref 2) in + push r2; + Weak.set w 2 r2; + let r3 = Some(ref 3) in + push r3; + Weak.set w 3 r3; + assert (count () = 3); + assert (state (Lwt_stream.next stream) = Return {contents = 1}); + Gc.full_major (); + (* Ocaml can consider that stream is unreachable before the + next line, hence freeing the whole data. *) + assert (count () <= 3); + push + in + let push = test () in + Gc.full_major (); + (* At this point [stream] is unreachable. *) + assert (count () = 0); + (* We have that to force caml to keep a reference on [push]. *) + push (Some(ref 4)); + return true); +] diff --git a/thirdparty/lwt-2.3.2/tests/core/test_lwt_util.ml b/thirdparty/lwt-2.3.2/tests/core/test_lwt_util.ml new file mode 100644 index 0000000..3e216af --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/core/test_lwt_util.ml @@ -0,0 +1,226 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Test_lwt_util + * Copyright (C) 2009 Jérémie Dimino, Pierre Chambart + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + + +open Test +open Lwt +open Lwt_util + +let ( <=> ) v v' = + assert ( state v = v') + +let test_exn f v e = + assert ( try f v;assert false with exn -> exn = e) + +exception Exn + +let test_iter f test_list = + let incr_ x = return ( incr x ) in + let () = + let l = [ref 0;ref 0; ref 0] in + let t = f incr_ l in + t <=> Return (); + List.iter2 (fun v r -> assert (v = !r)) [1;1;1] l + in + let () = + let l = [ref 0;ref 0; ref 0] in + let t,w = wait () in + let r = ref [incr_;(fun x -> t >>= ( fun () -> incr_ x ));incr_] in + let t' = f (fun x -> + let f = List.hd !r in + let t = f x in + r := List.tl !r; + t ) l + in + t' <=> Sleep; + List.iter2 (fun v r -> assert (v = !r)) test_list l; + wakeup w (); + List.iter2 (fun v r -> assert (v = !r)) [1;1;1] l; + t' <=> Return () + in + () + +let test_exception f = + let g = + let r = ref 0 in + fun _ -> + incr r; + match !r with + | 2 -> raise Exn + | _ -> return () + in + (* XXX est-ce le comportement souhaite ? + On pourrait plutot vouloir que iter et map + passent leur fonctions en parametre dans Lwt.apply. + + Une autre maniere serait d'avoir 2 bind, un tail recursif un non. + *) + test_exn (f g) [();();()] Exn + +let test_map f test_list = + let t,w = wait () in + let t',w' = task () in + let get = + let r = ref 0 in + let c = ref 0 in + fun () -> + let th = + incr c; + match !c with + | 5 -> t + | 8 -> t' + | _ -> return () + in + th >>= ( fun () -> + incr r; + return (!r) ) + in + let () = + let l = [();();()] in + let t1 = f get l in + t1 <=> Return [1;2;3]; + let t2 = f get l in + t2 <=> Sleep; + let t3 = f get l in + t3 <=> Sleep; + cancel t'; + t3 <=> Fail Canceled; + wakeup w (); + t2 <=> Return test_list; + in + () + +let suite = suite "lwt_util" [ + test "0" + (fun () -> + test_iter iter [1;0;1]; + test_exception iter; + return true); + + test "1" + (fun () -> + test_iter iter_serial [1;0;0]; + test_exception iter; + return true); + + test "2" + (fun () -> + test_map map [4;8;5]; + test_exception map; + return true); + + test "3" + (fun () -> + test_map map_serial [4;7;8]; + test_exception map_serial; + return true); + + test "4" + (fun () -> + let l = [1;2;3] in + let f acc v = return (v::acc) in + let t = fold_left f [] l in + t <=> Return (List.rev l); + return true); + + (* XXX l'espace semble mal compte dans les regions: on peut lancer + un thread tant que l'espace n'est pas nul, ca ne prends pas en + compte la taille du thread. ca devrait bloquer si il n'y a pas + assez de place. De plus resize region devrait permetre de + reveiller des threads. + + Une maniere de corriger est de ne pas permetre aux threads de + faire une taille superieur a 1. *) + + test "5" + (fun () -> + let t1,w1 = wait () in + let t2,w2 = wait () in + let t3,w3 = task () in + let region = make_region 3 in + run_in_region region 1 return <=> Return (); + (* XXX ne devrait pas pouvoir se lancer *) + run_in_region region 4 return <=> Return (); + let a = run_in_region region 3 (fun () -> t1) in + a <=> Sleep; + let b = run_in_region region 1 return in + b <=> Sleep; + let c = run_in_region region 3 (fun () -> t2) in + c <=> Sleep; + let d = run_in_region region 1 return in + d <=> Sleep; + let e = run_in_region region 3 (fun () -> t3) in + e <=> Sleep; + let f = run_in_region region 1 return in + f <=> Sleep; + wakeup w1 (); + a <=> Return (); + b <=> Return (); + c <=> Sleep; + d <=> Sleep; + e <=> Sleep; + f <=> Sleep; + cancel t3; + e <=> Sleep; + f <=> Sleep; + wakeup w2 (); + c <=> Return (); + d <=> Return (); + e <=> Fail Canceled; + f <=> Return (); + return true); + + test "6" + (fun () -> + let f () = raise Exn in + let region = make_region 1 in + run_in_region region 1 f <=> Fail Exn; + run_in_region region 1 return <=> Return (); + return true); +] + +(* XXX le comportement souhaite devrait etre: + ( avec resize qui renvoie un lwt qui se reveille + quand il y a suffisement de resources libres ) +*) +(* +let () = + let region = make_region 1 in + run_in_region region 1 return <=> Return (); + let t = run_in_region region 2 return in + t <=> Sleep; + resize_region region 2 <=> Return (); + t <=> Return (); + let t,w = wait () in + let t = run_in_region region 2 (fun () -> t) in + t <=> Sleep; + let t2 = run_in_region region 2 return in + let t3 = resize_region region 1 in + t2 <=> Sleep; + t3 <=> Sleep; + wakeup w (); + t <=> Return (); + t3 <=> Return (); + t2 <=> Sleep +*) + +(* XXX ca ne gere pas les cancel non plus *) diff --git a/thirdparty/lwt-2.3.2/tests/react/main.ml b/thirdparty/lwt-2.3.2/tests/react/main.ml new file mode 100644 index 0000000..8384a18 --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/react/main.ml @@ -0,0 +1,26 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Main + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +Test.run "react" [ + Test_lwt_event.suite; + Test_lwt_signal.suite; +] diff --git a/thirdparty/lwt-2.3.2/tests/react/test_lwt_event.ml b/thirdparty/lwt-2.3.2/tests/react/test_lwt_event.ml new file mode 100644 index 0000000..7567a5b --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/react/test_lwt_event.ml @@ -0,0 +1,75 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Test_lwt_event + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Test +open Lwt + +let suite = suite "lwt_event" [ + test "to_stream" + (fun () -> + let event, push = React.E.create () in + let stream = Lwt_event.to_stream event in + let t = Lwt_stream.next stream in + assert (state t = Sleep); + push 42; + return (state t = Return 42)); + + test "to_stream 2" + (fun () -> + let event, push = React.E.create () in + let stream = Lwt_event.to_stream event in + push 1; + push 2; + push 3; + lwt l = Lwt_stream.nget 3 stream in + return (l = [1; 2; 3])); + + test "map_s" + (fun () -> + let l = ref [] in + let event, push = React.E.create () in + let event' = Lwt_event.map_s (fun x -> l := x :: !l; return ()) event in + ignore event'; + push 1; + return (!l = [1])); + + test "map_p" + (fun () -> + let l = ref [] in + let event, push = React.E.create () in + let event' = Lwt_event.map_p (fun x -> l := x :: !l; return ()) event in + ignore event'; + push 1; + return (!l = [1])); + + test "of_stream" + (fun () -> + let stream, push = Lwt_stream.create () in + let l = ref [] in + let event = React.E.map (fun x -> l := x :: !l) (Lwt_event.of_stream stream) in + ignore event; + push (Some 1); + push (Some 2); + push (Some 3); + Lwt.wakeup_paused (); + return (!l = [3; 2; 1])); +] diff --git a/thirdparty/lwt-2.3.2/tests/react/test_lwt_signal.ml b/thirdparty/lwt-2.3.2/tests/react/test_lwt_signal.ml new file mode 100644 index 0000000..75e2151 --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/react/test_lwt_signal.ml @@ -0,0 +1,27 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Test_lwt_signal + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Test +open Lwt + +let suite = suite "lwt_signal" [ +] diff --git a/thirdparty/lwt-2.3.2/tests/test.ml b/thirdparty/lwt-2.3.2/tests/test.ml new file mode 100644 index 0000000..d52e1df --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/test.ml @@ -0,0 +1,78 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Test + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt +open Lwt_io + +type t = { + name : string; + run : unit -> bool Lwt.t; +} + +type suite = { + suite_name : string; + suite_tests : t list; +} + +let test ~name ~run = { name = name; run = run } +let suite ~name ~tests = { suite_name = name; suite_tests = tests } + +let run ~name ~suites = + let n = Lwt_main.run begin + (* Count the number of tests in [suites] *) + let total = List.fold_left (fun n { suite_tests = l } -> n + List.length l) 0 suites in + + lwt () = printlf "Running %d tests for library %S." total name in + + (* Iterate over suites: *) + let rec loop_suites failures number = function + | [] -> + if failures = 0 then + lwt () = printl "\r\027[JDone. All tests succeeded." in + return 0 + else + lwt () = printlf "\r\027[JDone. %d of %d tests failed." failures total in + return 1 + | suite :: suites -> + loop_tests failures suite.suite_name number suites suite.suite_tests + + (* Iterate over tests: *) + and loop_tests failures suite_name number suites = function + | [] -> + loop_suites failures number suites + | test :: tests -> + lwt () = printf "\r\027[J(%d/%d) Running test %S from suite %S" number total test.name suite_name in + lwt () = flush stdout in + try_lwt + test.run () >>= function + | false -> + lwt () = printlf "\r\027[J\027[31;1mTest %S from suite %S failed.\027[0m" test.name suite_name in + loop_tests (failures + 1) suite_name (number + 1) suites tests + | true -> + loop_tests failures suite_name (number + 1) suites tests + with exn -> + lwt () = printlf "\r\027[J\027[31;1mTest %S from suite %S failed. It raised: %S.\027[0m" test.name suite_name (Printexc.to_string exn) in + loop_tests (failures + 1) suite_name (number + 1) suites tests + in + loop_suites 0 1 suites + end in + exit n diff --git a/thirdparty/lwt-2.3.2/tests/test.mli b/thirdparty/lwt-2.3.2/tests/test.mli new file mode 100644 index 0000000..83b8ee5 --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/test.mli @@ -0,0 +1,40 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Interface Test + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +(** Helpers for test *) + +type t + (** Type of a test *) + +type suite + (** Type of a suite of tests *) + +val test : name : string -> run : (unit -> bool Lwt.t) -> t + (** Defines a test. [run] must returns [true] if the test succeeded + and [false] otherwise. *) + +val suite : name : string -> tests : t list -> suite + (** Defines a suite of tests *) + +val run : name : string -> suites : suite list -> unit + (** Run all the given tests and exit the program with an exit code + of [0] if all tests succeeded and with [1] otherwise. *) diff --git a/thirdparty/lwt-2.3.2/tests/test.mllib b/thirdparty/lwt-2.3.2/tests/test.mllib new file mode 100644 index 0000000..147c9c2 --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/test.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 0cbc6611f5540bd0809a388dc95a615b) +Test +# OASIS_STOP diff --git a/thirdparty/lwt-2.3.2/tests/unix/main.ml b/thirdparty/lwt-2.3.2/tests/unix/main.ml new file mode 100644 index 0000000..d7a0435 --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/unix/main.ml @@ -0,0 +1,26 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Main + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +Test.run "unix" [ + Test_lwt_io.suite; + Test_lwt_io_non_block.suite; +] diff --git a/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io.ml b/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io.ml new file mode 100644 index 0000000..32f4c2e --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io.ml @@ -0,0 +1,62 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Test_lwt_io + * Copyright (C) 2009 Jérémie Dimino + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt +open Lwt_io +open Test + +let suite = suite "lwt_io" [ + test "auto-flush" + (fun () -> + let sent = ref [] in + let oc = Lwt_io.make ~mode:output (fun buf ofs len -> + let str = String.create len in + Lwt_bytes.blit_bytes_string buf ofs str 0 len; + sent := str :: !sent; + return len) in + lwt () = write oc "foo" in + lwt () = write oc "bar" in + if !sent <> [] then + return false + else + lwt () = Lwt_unix.yield () in + return (!sent = ["foobar"])); + + test "auto-flush in atomic" + (fun () -> + let sent = ref [] in + let oc = make ~mode:output (fun buf ofs len -> + let str = String.create len in + Lwt_bytes.blit_bytes_string buf ofs str 0 len; + sent := str :: !sent; + return len) in + atomic + (fun oc -> + lwt () = write oc "foo" in + lwt () = write oc "bar" in + if !sent <> [] then + return false + else + lwt () = Lwt_unix.yield () in + return (!sent = ["foobar"])) + oc); +] diff --git a/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io_non_block.ml b/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io_non_block.ml new file mode 100644 index 0000000..9182f61 --- /dev/null +++ b/thirdparty/lwt-2.3.2/tests/unix/test_lwt_io_non_block.ml @@ -0,0 +1,66 @@ +(* Lightweight thread library for Objective Caml + * http://www.ocsigen.org/lwt + * Module Test_lwt_io + * Copyright (C) 2010 Pierre Chambart + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation, with linking exceptions; + * either version 2.1 of the License, or (at your option) any later + * version. See COPYING file for details. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + * 02111-1307, USA. + *) + +open Lwt +open Lwt_io +open Test + +let test_file = "Lwt_io_test" +let file_contents = "test file content" + +let open_and_read_filename () = + lwt in_chan = open_file ~mode:input test_file in + lwt s = read in_chan in + lwt () = close in_chan in + assert (s = file_contents); + return () + +let suite = suite "lwt_io non blocking io" [ + test "create file" + (fun () -> + lwt out_chan = open_file ~mode:output test_file in + lwt () = write out_chan file_contents in + lwt () = close out_chan in + return true); + + test "read file" + (fun () -> + lwt in_chan = open_file ~mode:input test_file in + lwt s = read in_chan in + lwt () = close in_chan in + return (s = file_contents)); + + test "many read file" + (fun () -> + lwt () = for_lwt i = 0 to 10000 do + try_lwt + open_and_read_filename () + with e -> lwt () = printf "\nstep %i\n" i in raise_lwt e + done in + return true); + + test "remove file" + (fun () -> + Unix.unlink test_file; + return true); + +] diff --git a/thirdparty/lwt-2.3.2/utils/ocamlinit b/thirdparty/lwt-2.3.2/utils/ocamlinit new file mode 100644 index 0000000..668e93f --- /dev/null +++ b/thirdparty/lwt-2.3.2/utils/ocamlinit @@ -0,0 +1,38 @@ +(* -*- tuareg -*- *) + +(* This file is a sample ocaml init file for friendly interactive use + of Lwt. + + You can copy it to ~/.ocamlinit. +*) + +(* Use topfind, this is the minimum: *) +#use "topfind";; +(* Note: if you use lwt/toplevel.byte, you should remove this line *) + +(* Syntax to use, you can replace that with #camlp4r if you prefer + revised syntax: *) +#camlp4o;; + +(* Load Lwt syntactic sugars: *) +#require "lwt.syntax";; + +(* Load the lwt.top package, with line-editing support :) *) +#require "lwt.top";; + +(* Open useful Lwt modules for scripting: *) +open Lwt_unix;; +open Lwt;; +open Lwt_io;; +open Lwt_process;; + +(* Useful definitions for interactive use of Lwt, so you can write: + + $ run& printl "plop";; + + or: + + $ let l = run& read_line stdin;; +*) +let ( & ) a b = a b;; +let run = Lwt_main.run;; diff --git a/thirdparty/lwt-2.3.2/utils/style.css b/thirdparty/lwt-2.3.2/utils/style.css new file mode 100644 index 0000000..fb02716 --- /dev/null +++ b/thirdparty/lwt-2.3.2/utils/style.css @@ -0,0 +1,171 @@ +/* A style for ocamldoc. Daniel C. Buenzli, Jérémie Dimino */ + +body { + padding: 0em; + border: 0em; + margin: 2em 10% 2em 10%; + font-weight: normal; + line-height: 130%; + text-align: justify; + background: white; + color : black; + min-width: 40ex; +} + +pre, p, div, span, img, table, td, ol, ul, li { + padding: 0em; + border: 0em; + margin: 0em +} + +h1, h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { + fontsize: 100%; + margin-bottom: 1em + padding: 1ex 0em 0em 0em; + border: 0em; + margin: 1em 0em 0em 0em; + font-weight : bold; + text-align: center; +} + +h1 { + font-size : 140% +} + +h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { + font-size : 100%; + border-top-style : none; + margin: 1ex 0em 0em 0em; + border: 1px solid #000000; + margin-top: 5px; + margin-bottom: 2px; + text-align: center; + padding: 2px; +} + +h2 { + font-size : 120%; + background-color: #90BDFF ; +} +h3 { + background-color: #90DDFF; +} +h4 { + background-color: #90EDFF; +} +h5 { + background-color: #90FDFF; +} +h6 { + background-color: #C0FFFF; +} +div.h7 { + background-color: #E0FFFF; +} +div.h8 { + background-color: #F0FFFF; +} +div.h9 { + background-color: #FFFFFF; +} + +.navbar { + padding-bottom : 1em; + margin-bottom: 1em; + border-bottom: 1px solid #000000; + border-bottom-style: dotted; +} + +p { + padding: 1em 0ex 0em 0em +} + +a, a:link, a:visited, a:active, a:hover { + color : #009; + text-decoration: none +} +a:hover { + color : #009; + text-decoration : none; + background-color: #5FFF88 +} + +hr { + border-style: none; +} +table { + font-size : 100% /* Why ? */ +} +ul li { + padding: 1em 0em 0em 0em; + margin:0em 0em 0em 2.5ex +} +ol li { + padding: 1em 0em 0em 0em; + margin:0em 0em 0em 2em +} + +pre { + margin: 3ex 0em 1ex 0em; + background-color: #edf0f9; +} +.keyword { + font-weight: bold; + color: #a020f0; +} +.keywordsign { + font-weight: bold; + color: #a020f0; +} +.typefieldcomment { + color : #b22222; +} +.keywordsign { + color: #a020f0; + +} +.code { + font-size: 120%; + color: #5f5f5f; +} +.info { + margin: 0em 0em 0em 2em +} +.comment { + color : #b22222; +} +.constructor { + color : #072 +} +.type { + color : #228b22; +} +.string { + color : #bc8f8f; +} +.warning { + color : Red; + font-weight : bold +} + +div.sig_block { + margin-left: 2em +} +.typetable { + color : #b8860b; + border-style : hidden +} +.indextable { + border-style : hidden +} +.paramstable { + border-style : hidden; + padding: 5pt 5pt +} + +.superscript { + font-size : 80% +} +.subscript { + font-size : 80% +} diff --git a/thirdparty/lwt-2.3.2/utils/tuareg.patch b/thirdparty/lwt-2.3.2/utils/tuareg.patch new file mode 100644 index 0000000..a611392 --- /dev/null +++ b/thirdparty/lwt-2.3.2/utils/tuareg.patch @@ -0,0 +1,377 @@ +diff --git a/tuareg.el b/tuareg.el +index 7529577..e5b3b71 100644 +--- a/tuareg.el ++++ b/tuareg.el +@@ -693,7 +693,7 @@ and `tuareg-xemacs-w3-manual' (XEmacs only)." + "Return relative indentation of the keyword given in argument." + (let ((ind (symbol-value (cdr (assoc kwop tuareg-keyword-alist)))) + (looking-let-or-and (and look-for-let-or-and +- (looking-at "\\<\\(let\\|and\\)\\>")))) ++ (looking-at "\\<\\(let\\|lwt\\|and\\)\\>")))) + (if (string-match "\\<\\(with\\|function\\|parser?\\)\\>" kwop) + (+ (if (and tuareg-let-always-indent + looking-let-or-and (< ind tuareg-let-indent)) +@@ -1015,7 +1015,8 @@ Regexp match data 0 points to the chars." + '("module" "class" "functor" "object" "type" "val" "inherit" + "include" "virtual" "constraint" "exception" "external" "open" + "method" "and" "initializer" "to" "downto" "do" "done" "else" +- "begin" "end" "let" "in" "then" "with")) ++ "begin" "end" "let" "in" "then" "with" ++ "lwt" "try_lwt" "for_lwt" "finally")) + (setq abbrevs-changed nil)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +@@ -1143,7 +1144,7 @@ Special keys for Tuareg mode:\\{tuareg-mode-map}" + tuareg-font-lock-keywords + (append + (list +- (list "\\<\\(external\\|open\\|include\\|rule\\|s\\(ig\\|truct\\)\\|module\\|functor\\|with[ \t\n]+\\(type\\|module\\)\\|val\\|type\\|method\\|virtual\\|constraint\\|class\\|in\\|inherit\\|initializer\\|let\\|rec\\|and\\|begin\\|object\\|end\\)\\>" ++ (list "\\<\\(external\\|open\\|include\\|rule\\|s\\(ig\\|truct\\)\\|module\\|functor\\|with[ \t\n]+\\(type\\|module\\)\\|val\\|type\\|method\\|virtual\\|constraint\\|class\\|in\\|inherit\\|initializer\\|let\\|lwt\\|rec\\|and\\|begin\\|object\\|end\\)\\>" + 0 'tuareg-font-lock-governing-face nil nil)) + (if tuareg-support-metaocaml + (list (list "\\.<\\|>\\.\\|\\.~\\|\\.!" +@@ -1152,19 +1153,19 @@ Special keys for Tuareg mode:\\{tuareg-mode-map}" + (list + (list "\\<\\(false\\|true\\)\\>" + 0 'font-lock-constant-face nil nil) +- (list "\\<\\(as\\|do\\(ne\\|wnto\\)?\\|else\\|for\\|if\\|m\\(atch\\|utable\\)\\|new\\|p\\(arser\\|rivate\\)\\|t\\(hen\\|o\\|ry\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|lazy\\|exception\\|raise\\|failwith\\|exit\\|assert\\|fun\\(ction\\)?\\)\\>" ++ (list "\\<\\(raise_lwt\\|as\\|do\\(ne\\|wnto\\)?\\|else\\|for\\(_lwt\\)?\\|if\\|m\\(atch\\|utable\\)\\|new\\|p\\(arser\\|rivate\\)\\|t\\(hen\\|o\\|ry\\(_lwt\\)?\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|lazy\\|exception\\|raise\\|failwith\\|exit\\|assert\\|fun\\(ction\\)?\\|finally\\)\\>" + 0 'font-lock-keyword-face nil nil) + (list "[][;,()|{}]\\|[@^!:*=<>&/%+~?#---]\\.?\\|\\.\\.\\.*\\|\\<\\(asr\\|asl\\|lsr\\|lsl\\|l?or\\|l?and\\|xor\\|not\\|mod\\|of\\|ref\\)\\>" + 0 'tuareg-font-lock-operator-face nil nil) +- (list (concat "\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(['_" tuareg-lower "]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)") ++ (list (concat "\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\|lwt\\)\\>[ \t\n]*\\(['_" tuareg-lower "]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)") + 8 'font-lock-function-name-face 'keep nil) + (list "\\[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" + 3 'font-lock-function-name-face 'keep nil) + (list "\\<\\(fun\\(ction\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_ \t()*,]\\)+\\)" + 3 'font-lock-variable-name-face 'keep nil) +- (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" ++ (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\|lwt\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" + 4 'font-lock-variable-name-face 'keep nil) +- (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" ++ (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\|lwt\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" + 6 'font-lock-variable-name-face 'keep nil) + (list "\\<\\(open\\|\\(class\\([ \t\n]+type\\)?\\)\\([ \t\n]+virtual\\)?\\|inherit\\|include\\|module\\([ \t\n]+\\(type\\|rec\\)\\)?\\|type\\)\\>[ \t\n]*\\(['~?]*\\([_--->.* \t]\\|\\w\\|(['~?]*\\([_--->.,* \t]\\|\\w\\)*)\\)*\\)" + 7 'font-lock-type-face 'keep nil) +@@ -1279,7 +1280,7 @@ possible." + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Indentation stuff + +-(defconst tuareg-keyword-regexp "\\<\\(object\\|initializer\\|and\\|c\\(onstraint\\|lass\\)\\|m\\(atch\\|odule\\|ethod\\|utable\\)\\|s\\(ig\\|truct\\)\\|begin\\|e\\(lse\\|x\\(ception\\|ternal\\)\\)\\|t\\(o\\|hen\\|ry\\|ype\\)\\|v\\(irtual\\|al\\)\\|w\\(h\\(ile\\|en\\)\\|ith\\)\\|i\\(f\\|n\\(herit\\)?\\)\\|f\\(or\\|un\\(ct\\(or\\|ion\\)\\)?\\)\\|let\\|do\\(wnto\\)?\\|parser?\\|rule\\|of\\)\\>\\|->\\|[;,|]" ++(defconst tuareg-keyword-regexp "\\<\\(object\\|initializer\\|and\\|c\\(onstraint\\|lass\\)\\|m\\(atch\\|odule\\|ethod\\|utable\\)\\|s\\(ig\\|truct\\)\\|begin\\|e\\(lse\\|x\\(ception\\|ternal\\)\\)\\|t\\(o\\|hen\\|ry\\(_lwt\\)?\\|ype\\)\\|v\\(irtual\\|al\\)\\|w\\(h\\(ile\\|en\\)\\|ith\\)\\|i\\(f\\|n\\(herit\\)?\\)\\|f\\(inally\\|or\\(_lwt\\)?\\|un\\(ct\\(or\\|ion\\)\\)?\\)\\|l\\(e\\|w\\)t\\|do\\(wnto\\)?\\|parser?\\|rule\\|of\\)\\>\\|->\\|[;,|]" + "Regexp for all recognized keywords.") + + (defconst tuareg-match-|-keyword-regexp +@@ -1298,11 +1299,11 @@ considered as a special keyword.") + "Regexp matching Caml keywords which act as end block delimiters.") + + (defconst tuareg-leading-kwop-regexp +- (concat tuareg-matching-keyword-regexp "\\|\\\\|[|>]?\\]\\|>?}\\|[|)]\\|;;") ++ (concat tuareg-matching-keyword-regexp "\\|\\<\\(with\\|finally\\)\\>\\|[|>]?\\]\\|>?}\\|[|)]\\|;;") + "Regexp matching Caml keywords which need special indentation.") + + (defconst tuareg-governing-phrase-regexp +- "\\<\\(val\\|type\\|m\\(ethod\\|odule\\)\\|c\\(onstraint\\|lass\\)\\|in\\(herit\\|itializer\\)\\|ex\\(ternal\\|ception\\)\\|open\\|let\\|object\\|include\\)\\>" ++ "\\<\\(val\\|type\\|m\\(ethod\\|odule\\)\\|c\\(onstraint\\|lass\\)\\|in\\(herit\\|itializer\\)\\|ex\\(ternal\\|ception\\)\\|open\\|l\\(e\\|w\\)t\\|object\\|include\\)\\>" + "Regexp matching tuareg phrase delimitors.") + + (defconst tuareg-governing-phrase-regexp-with-break +@@ -1318,6 +1319,7 @@ considered as a special keyword.") + ("begin" . tuareg-begin-indent) + (".<" . tuareg-begin-indent) + ("for" . tuareg-for-while-indent) ++ ("for_lwt" . tuareg-for-while-indent) + ("while" . tuareg-for-while-indent) + ("do" . tuareg-do-indent) + ("type" . tuareg-type-indent) ; in some cases, `type' acts like a match +@@ -1327,8 +1329,10 @@ considered as a special keyword.") + ("then" . tuareg-if-then-else-indent) + ("else" . tuareg-if-then-else-indent) + ("let" . tuareg-let-indent) ++ ("lwt" . tuareg-let-indent) + ("match" . tuareg-match-indent) + ("try" . tuareg-try-indent) ++ ("try_lwt" . tuareg-try-indent) + ("rule" . tuareg-rule-indent) + + ;; Case match keywords +@@ -1338,6 +1342,7 @@ considered as a special keyword.") + ("parser" . tuareg-parser-indent) + + ;; Default indentation keywords ++ ("finally" . tuareg-default-indent) + ("when" . tuareg-default-indent) + ("functor" . tuareg-default-indent) + ("exception" . tuareg-default-indent) +@@ -1372,6 +1377,7 @@ considered as a special keyword.") + ("done" . tuareg-find-done-match) + ("in" . tuareg-find-in-match) + ("with" . tuareg-find-with-match) ++ ("finally" . tuareg-find-finally-match) + ("else" . tuareg-find-else-match) + ("then" . tuareg-find-match) + ("do" . tuareg-find-do-match) +@@ -1400,7 +1406,7 @@ Returns the actual text of the word, if found." + + (defconst tuareg-find-kwop-regexp + (concat tuareg-matching-keyword-regexp +- "\\|\\<\\(for\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|object\\)\\>\\|[][(){}]\\|\\*)")) ++ "\\|\\<\\(for\\(_lwt\\)?\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|object\\)\\>\\|[][(){}]\\|\\*)")) + + (defun tuareg-make-find-kwop-regexp (kwop-regexp) + (concat tuareg-find-kwop-regexp "\\|" kwop-regexp)) +@@ -1440,45 +1446,55 @@ If found, return the actual text of the keyword or operator." + + (defconst tuareg-find-,-match-regexp + (tuareg-make-find-kwop-regexp +- "\\<\\(and\\|match\\|begin\\|else\\|exception\\|then\\|try\\|with\\|or\\|fun\\|function\\|let\\|do\\)\\>\\|->\\|[[{(]")) ++ "\\<\\(and\\|match\\|begin\\|else\\|exception\\|then\\|try\\(_lwt\\)?\\|with\\|or\\|fun\\|function\\|l\\(e\\|w\\)t\\|do\\)\\>\\|->\\|[[{(]")) + (defun tuareg-find-,-match () + (tuareg-find-kwop tuareg-find-,-match-regexp)) + + (defconst tuareg-find-with-match-regexp + (tuareg-make-find-kwop-regexp +- "\\<\\(match\\|try\\|module\\|begin\\|with\\)\\>\\|[[{(]")) ++ "\\<\\(match\\|try\\(_lwt\\)?\\|module\\|begin\\|with\\)\\>\\|[[{(]")) + (defun tuareg-find-with-match () + (let ((kwop (tuareg-find-kwop tuareg-find-with-match-regexp + "\\"))) +- (if (string= kwop "with") ++ (if (or (string= kwop "with")) + (progn + (tuareg-find-with-match) + (tuareg-find-with-match))) + kwop)) + ++(defun tuareg-find-finally-match () ++ (let ((kwop (tuareg-find-kwop tuareg-find-with-match-regexp ++ "\\"))) ++ (if (or (string= kwop "with")) ++ (tuareg-find-with-match)) ++ kwop)) ++ + (defconst tuareg-find-in-match-regexp +- (tuareg-make-find-kwop-regexp "\\")) ++ (tuareg-make-find-kwop-regexp "\\")) + (defun tuareg-find-in-match () + (let ((kwop (tuareg-find-kwop tuareg-find-in-match-regexp "\\"))) + (cond ((string= kwop "and") (tuareg-find-in-match)) + (t kwop)))) + + (defconst tuareg-find-else-match-regexp +- (tuareg-make-find-kwop-regexp ";\\|->\\|\\")) ++ (tuareg-make-find-kwop-regexp ";\\|->\\|\\<\\(with\\|finally\\)\\>")) + (defun tuareg-find-else-match () + (let ((kwop (tuareg-find-kwop tuareg-find-else-match-regexp +- "->\\|\\<\\(with\\|then\\)\\>"))) ++ "->\\|\\<\\(with\\|finally\\|then\\)\\>"))) + (cond + ((string= kwop "then") + (tuareg-find-match)) + ((string= kwop "with") + (tuareg-find-with-match)) ++ ((string= kwop "finally") ++ (tuareg-find-finally-match)) + ((string= kwop "->") + (setq kwop (tuareg-find-->-match)) + (while (string= kwop "|") + (setq kwop (tuareg-find-|-match))) +- (if (string= kwop "with") +- (tuareg-find-with-match)) ++ (cond ++ ((string= kwop "with") (tuareg-find-with-match)) ++ ((string= kwop "finally") (tuareg-find-finally-match))) + (tuareg-find-else-match)) + ((string= kwop ";") + (tuareg-find-semi-colon-match) +@@ -1497,7 +1513,7 @@ If found, return the actual text of the keyword or operator." + (tuareg-find-do-match) kwop))) + + (defconst tuareg-find-and-match-regexp +- "\\<\\(do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|then\\|\\(down\\)?to\\)\\>\\|\\<\\(for\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|class\\)\\>\\|[][(){}]\\|\\*)\\|\\<\\(rule\\|exception\\|let\\|in\\|type\\|val\\|module\\)\\>") ++ "\\<\\(do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|then\\|\\(down\\)?to\\)\\>\\|\\<\\(for\\(_lwt\\)\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|class\\)\\>\\|[][(){}]\\|\\*)\\|\\<\\(rule\\|exception\\|l\\(e\\|w\\)t\\|in\\|type\\|val\\|module\\)\\>") + (defconst tuareg-find-and-match-regexp-dnr + (concat tuareg-find-and-match-regexp "\\|\\")) + (defun tuareg-find-and-match (&optional do-not-recurse) +@@ -1519,7 +1535,7 @@ If found, return the actual text of the keyword or operator." + (t kwop)))) + + (defconst tuareg-find-=-match-regexp +- (tuareg-make-find-kwop-regexp "\\<\\(val\\|let\\|m\\(ethod\\|odule\\)\\|type\\|class\\|when\\|i[fn]\\)\\>\\|=")) ++ (tuareg-make-find-kwop-regexp "\\<\\(val\\|l\\(e\\\|w\\)t\\|m\\(ethod\\|odule\\)\\|type\\|class\\|when\\|i[fn]\\)\\>\\|=")) + (defun tuareg-find-=-match () + (let ((kwop (tuareg-find-kwop tuareg-find-=-match-regexp + "\\<\\(and\\|in\\)\\>\\|="))) +@@ -1542,7 +1558,7 @@ If found, return the actual text of the keyword or operator." + (defun tuareg-captive-= () + (save-excursion + (tuareg-find-=-match) +- (looking-at "\\<\\(let\\|if\\|when\\|module\\|type\\|class\\)\\>"))) ++ (looking-at "\\<\\(l\\(e\\|w\\)t\\|if\\|when\\|module\\|type\\|class\\)\\>"))) + + (defconst tuareg-find-|-match-regexp + (tuareg-make-find-kwop-regexp +@@ -1575,7 +1591,7 @@ If found, return the actual text of the keyword or operator." + (t kwop)))) + + (defconst tuareg-find-->-match-regexp +- (tuareg-make-find-kwop-regexp "\\<\\(external\\|val\\|method\\|let\\|with\\|fun\\(ction\\|ctor\\)?\\|parser\\)\\>\\|[|:;]")) ++ (tuareg-make-find-kwop-regexp "\\<\\(external\\|val\\|method\\|l\\(e\\|w\\)t\\|with\\|fun\\(ction\\|ctor\\)?\\|parser\\)\\>\\|[|:;]")) + (defun tuareg-find-->-match () + (let ((kwop (tuareg-find-kwop tuareg-find-->-match-regexp "\\"))) + (cond +@@ -1600,7 +1616,7 @@ If found, return the actual text of the keyword or operator." + kwop))))))) + + (defconst tuareg-find-semi-colon-match-regexp +- (tuareg-make-find-kwop-regexp ";[ \t]*\\((\\*\\|$\\)\\|->\\|\\<\\(let\\|method\\|with\\|try\\|initializer\\)\\>")) ++ (tuareg-make-find-kwop-regexp ";[ \t]*\\((\\*\\|$\\)\\|->\\|\\<\\(l\\(e\\|w\\)t\\|method\\|with\\|finally\\|try\\(_lwt\\)?\\|initializer\\)\\>")) + (defun tuareg-find-semi-colon-match (&optional leading-semi-colon) + (tuareg-find-kwop tuareg-find-semi-colon-match-regexp + "\\<\\(in\\|end\\|and\\|do\\|with\\)\\>") +@@ -1644,7 +1660,7 @@ If found, return the actual text of the keyword or operator." + (tuareg-find-in-match) + (tuareg-back-to-paren-or-indentation) + (+ (current-column) tuareg-in-indent)) +- ((looking-at "\\") ++ ((looking-at "\\") + (+ (current-column) tuareg-let-indent)) + (t (tuareg-back-to-paren-or-indentation t) + (+ (current-column) tuareg-default-indent)))) +@@ -1660,7 +1676,7 @@ If found, return the actual text of the keyword or operator." + (if (and (looking-at "\\<\\(type\\|module\\)\\>") (> (point) (point-min)) + (save-excursion + (tuareg-find-meaningful-word) +- (looking-at "\\<\\(module\\|with\\|and\\|let\\)\\>"))) ++ (looking-at "\\<\\(module\\|with\\|and\\|l\\(e\\|w\\)t\\)\\>"))) + (progn + (tuareg-find-meaningful-word) + (+ (current-column) tuareg-default-indent)) +@@ -1669,7 +1685,7 @@ If found, return the actual text of the keyword or operator." + (if phrase-break + tuareg-find-phrase-indentation-regexp-pb + tuareg-find-phrase-indentation-regexp) +- "\\<\\(end\\|and\\|with\\|in\\)\\>")) ++ "\\<\\(end\\|and\\|with\\|finally\\|in\\)\\>")) + (tmpkwop nil) (curr nil)) + (if (and kwop (string= kwop "and")) + (setq kwop (tuareg-find-and-match))) +@@ -1698,7 +1714,7 @@ If found, return the actual text of the keyword or operator." + (if (string= tmpkwop "and") + (setq tmpkwop (tuareg-find-and-match))) + (setq curr (point)) +- (and (string= tmpkwop "let") ++ (and (or (string= tmpkwop "let") (string= tmpkwop "lwt")) + (not (tuareg-looking-at-expression-let)))))) + (goto-char curr) + (tuareg-find-phrase-indentation phrase-break)) +@@ -1706,12 +1722,14 @@ If found, return the actual text of the keyword or operator." + (end-of-line) + (tuareg-skip-blank-and-comments) + (current-column)) +- ((string= kwop "let") ++ ((or (string= tmpkwop "let") (string= tmpkwop "lwt")) + (if (tuareg-looking-at-expression-let) + (tuareg-find-phrase-indentation phrase-break) + (current-column))) + ((string= kwop "with") + (current-column)) ++ ((string= kwop "finally") ++ (current-column)) + ((string= kwop "end") + (current-column)) + ((string= kwop "in") +@@ -1765,12 +1783,12 @@ Returns t iff skipped to indentation." + (if forward-in + tuareg-back-to-paren-or-indentation-in-regexp + tuareg-back-to-paren-or-indentation-regexp)) +- "\\")) ++ "\\")) + (retval)) +- (if (string= kwop "with") ++ (if (or (string= kwop "with") (string= kwop "finally")) + (let ((with-point (point))) + (setq kwop (tuareg-find-with-match)) +- (if (or (string= kwop "match") (string= kwop "try")) ++ (if (or (string= kwop "match") (string= kwop "try") (string= kwop "try_lwt")) + (tuareg-find-kwop + tuareg-back-to-paren-or-indentation-regexp + "\\") +@@ -1778,6 +1796,7 @@ Returns t iff skipped to indentation." + (setq retval + (cond + ((string= kwop "with") nil) ++ ((string= kwop "finally") nil) + ((string= kwop "in") (tuareg-in-indentation-p)) + ((looking-at "[[{(]") (tuareg-search-forward-paren) nil) + ((looking-at "\\.<") +@@ -1792,7 +1811,7 @@ Returns t iff skipped to indentation." + ((and forward-in (string= kwop "in")) + (tuareg-find-in-match) + (tuareg-back-to-paren-or-indentation forward-in) +- (if (looking-at "\\<\\(let\\|and\\)\\>") ++ (if (looking-at "\\<\\(l\\(e\\|w\\)t\\|and\\)\\>") + (forward-char tuareg-in-indent)) nil) + (t retval))))) + +@@ -1993,7 +2012,7 @@ Returns t iff skipped to indentation." + (+ tuareg-type-indent + tuareg-|-extra-unindent)))) + ((looking-at +- "\\<\\(val\\|let\\|m\\(ethod\\|odule\\)\\|class\\|when\\|\\|for\\|if\\)\\>") ++ "\\<\\(val\\|l\\(e\\|w\\)t\\|m\\(ethod\\|odule\\)\\|class\\|when\\|\\|for\\|if\\)\\>") + (let ((matched-string (tuareg-match-string 0))) + (tuareg-back-to-paren-or-indentation t) + (setq current-column-module-type (current-column)) +@@ -2020,12 +2039,12 @@ Returns t iff skipped to indentation." + (not (and tuareg-support-metaocaml + (looking-at "\\.") + (char-equal ?> (preceding-char)))) +- (or (looking-at "[[({;=]\\|\\<\\(begin\\|i[fn]\\|do\\|t\\(ry\\|hen\\)\\|else\\|match\\|wh\\(ile\\|en\\)\\)\\>") ++ (or (looking-at "[[({;=]\\|\\<\\(begin\\|i[fn]\\|do\\|t\\(ry\\(_lwt\\)?\\|hen\\)\\|else\\|match\\|wh\\(ile\\|en\\)\\)\\>") + (looking-at tuareg-operator-regexp))))) + + (defun tuareg-looking-at-false-module () + (save-excursion (tuareg-find-meaningful-word) +- (looking-at "\\<\\(let\\|with\\|and\\)\\>"))) ++ (looking-at "\\<\\(l\\(e\\|w\\)t\\|with\\|and\\)\\>"))) + + (defun tuareg-looking-at-false-sig-struct () + (save-excursion (tuareg-find-module) +@@ -2109,7 +2128,7 @@ Compute new indentation based on Caml syntax." + (t (current-column)))) + ((tuareg-in-literal-p) + (current-column)) +- ((looking-at "\\") ++ ((looking-at "\\") + (if (tuareg-looking-at-expression-let) + (if (tuareg-looking-at-in-let) + (progn +@@ -2339,7 +2358,7 @@ by |, insert one |." + (tuareg-beginning-of-literal-or-comment) (skip-chars-backward " \t\n"))) + + (defconst tuareg-beginning-phrase-regexp +- "^#[ \t]*[a-z][_a-z]*\\>\\|\\<\\(end\\|type\\|module\\|sig\\|struct\\|class\\|exception\\|open\\|let\\)\\>\\|;;" ++ "^#[ \t]*[a-z][_a-z]*\\>\\|\\<\\(end\\|type\\|module\\|sig\\|struct\\|class\\|exception\\|open\\|l\\(e\\|w\\)t\\)\\>\\|;;" + "Regexp matching tuareg phrase delimitors.") + (defun tuareg-find-phrase-beginning () + "Find `real' phrase beginning and return point." +@@ -2351,7 +2370,7 @@ by |, insert one |." + (tuareg-find-kwop tuareg-beginning-phrase-regexp) + (while (and (> (point) (point-min)) (< (point) old-point) + (or (not (looking-at tuareg-beginning-phrase-regexp)) +- (and (looking-at "\\") ++ (and (looking-at "\\") + (tuareg-looking-at-expression-let)) + (and (looking-at "\\") + (tuareg-looking-at-false-module)) +@@ -3280,7 +3299,7 @@ current phrase else insert a newline and indent." + ;; Designed from original code by M. Quercia + + (defconst tuareg-definitions-regexp +- "\\<\\(and\\|val\\|type\\|module\\|class\\|exception\\|let\\)\\>" ++ "\\<\\(and\\|val\\|type\\|module\\|class\\|exception\\|l\\(e\\|w\\)t\\)\\>" + "Regexp matching definition phrases.") + + (defconst tuareg-definitions-bind-skip-regexp diff --git a/util.ml b/util.ml index a8eb268..d559b0a 100644 --- a/util.ml +++ b/util.ml @@ -15,6 +15,7 @@ (* You should have received a copy of the GNU General Public License *) (* along with Hop. If not, see . *) +open Lwt open Sexp open Printf @@ -23,37 +24,26 @@ let message_not_understood context m = let create_thread name cleanup main initarg = let guarded_main initarg = - try + try_lwt main initarg with e -> - Log.warn "Thread died with exception" [Str name; Str (Printexc.to_string e)]; + lwt () = Log.warn "Thread died with exception" [Str name; Str (Printexc.to_string e)] in (match cleanup with | Some cleaner -> cleaner e - | None -> ()) + | None -> return ()) in - Thread.create guarded_main initarg + guarded_main initarg let daemon_thread_died name nested_cleaner e = - (match nested_cleaner with - | Some c -> c e - | None -> ()); - Server_control.shutdown_now [Sexp.Str "Daemon thread exited"; Sexp.Str name] + lwt () = (match nested_cleaner with + | Some c -> c e + | None -> return ()) in + Server_control.shutdown_now [Sexp.Str "Daemon thread exited"; Sexp.Str name]; + return () let create_daemon_thread name cleanup main initarg = create_thread name (Some (daemon_thread_died name cleanup)) main initarg -let with_mutex m f arg = - Mutex.lock m; - try - let result = f arg in - Mutex.unlock m; - result - with e -> - Mutex.unlock m; - raise e - -let with_mutex0 m thunk = with_mutex m thunk () - let starts_with s1 s2 = try Str.first_chars s1 (String.length s2) = s2 with _ -> false