pax_global_header00006660000000000000000000000064127074252130014515gustar00rootroot0000000000000052 comment=e7c75d9b27e8788548ce94e5b6b110d609da065e lwt-2.5.2/000077500000000000000000000000001270742521300123315ustar00rootroot00000000000000lwt-2.5.2/.gitignore000066400000000000000000000004511270742521300143210ustar00rootroot00000000000000_build lwt-*.tar.gz src/unix/lwt_config.ml src/unix/lwt_config.h src/unix/lwt_unix_jobs_generated.ml src/unix/jobs-unix/ webdarcs.log setup.data setup.log manual/*.toc manual/*.pdf manual/*.out manual/*.log manual/*.aux manual/manual-wiki.tex manual/.latex_of_wiki_offsets setup.exe setup-dev.exe lwt-2.5.2/.merlin000066400000000000000000000000751270742521300136220ustar00rootroot00000000000000S src/** S ppx/ S syntax/ B _build/** S tests/ S examples/lwt-2.5.2/CHANGES000066400000000000000000000326331270742521300133330ustar00rootroot00000000000000===== 2.5.2 (2015-04-25) ===== * Fix compatibility for 4.03 (#227) * Various documentation fixes (#199,#200,#210,) * Improve wildcard detection in the ppx (#198) * Fix Lwt_stream: bounded_push#close wake the reader (#201) * Fix infinite loop with Lwt_stream.choose (#214) * Fix lazyness failure with Lwt_io.common#close (#207) ===== 2.5.1 (2015-12-07) ===== * Lwt_stream.on_terminate -> Lwt_stream.on_termination * Lwt_unix: handle O_CLOEXEC * Lwt_log: add OSX syslog path * Ppx: Improve lwt%match, improve catchall detection * Add Lwt_unix.file_exists and Lwt_unix.Large_file.file_exists * Build fixes ===== 2.5.0 (2015-07-03) ===== * API CHANGE: Functions in Lwt_io that were previously using a ~buffer_size argument now takes a ~buffer argument. * Accept ?buffer argument in Lwt_ssl.{in,out}_channel_of_descr. * Use newer Ssl bigarray read/write functionality to avoid allocation in Lwt_ssl. * Fix non-reentrant function calls (#136) * IPv4 multicast support. * Add support for if%lwt in ppx extension. * Add Lwt.return_some. * Disable log syntax extension by default in ppx. Give [-log] as ppx argument to enable it. * Nanosecond precision for Lwt_unix.stat. * Minor fixes + documentation improvements. ===== 2.4.8 (2015-03-11) ===== * Fix compilation under Windows (#117, #129) * Fix Lwt_engine.on_timer (#121) * Add Lwt_log_core.reset_rules (#123) * Fixed typos in the documentation (#119, #131) ===== 2.4.7 (2015-01-06) ===== * camlp4 is now optional. * Add safe_string compliance except for Lwt_ssl (need ocaml-ssl fix). * Add Lwt.Infix module to open instead of Lwt to have (>>=), etc. * Add Lwt_list.filter_map_{s,p} functions. * Add Lwt.fail_{with,invalid_arg} functions. * Improved Android support. * Remove deprecated lwt.text and lwt.top libraries. * Remove deprecated Lwt_signal and Lwt_event modules from lwt.react. * Fix #111: try_lwt wrongly warns about unused match case. * Fix #96: Fix Lwt_react.S.limit and Lwt_react.E.limit. * Fix #91: Workaround to fix compilation on OSX. ===== 2.4.6 (2014-10-12) ===== * Add a ppx syntax extension * Add a ?fd argument to Lwt_io.{open_connection,with_connection,establish_server}. * Fix stub for getaddrinfo and getprotobyname * Windows fix: don't throw an exception in the notification handler if we're shutting down * Fix include file search in ./configure * ./configure fixes for windows * Fix: use sys_exit instead of exit when Unix.execv fails ===== 2.4.5 (2014-04-21) ===== * Lwt_ssl: expand API to allow setting socket options with Ssl functions * fix for camlp4 trunk * support for React 1.0.0 * add Lwt_sequence.find_node_* functions * Lwt_log: get backtrace early to overcome exns in Printexc.to_string * fix potential deadlock in lwt_unix_recv_notifications * lwt.glib fixes: - handle HUP - fix for BSD/OSX * do not raise an exception in Lwt_log if argv[0] is blank ===== 2.4.4 (2013-10-22) ===== * add Android support * fix issues in stubs for Lwt_unix jobs * fix compatibility issue with OCaml 4.01 * fix the stub for ev_timer_init * add Lwt.log containing Lwt_log_core, the Unix-free part of Lwt_log * add Lwt_ssl.get_fd * fix stdout/stderr redirections in Lwt_daemon.daemonize * add Lwt_list.{map,iter}i{_s,_p} ===== 2.4.3 (2012-12-27) ===== * fix Lwt_ssl.{in,out}_channel_of_descr: shutdown and close the socket when the channel is closed ===== 2.4.2 (2012-09-28) ===== * fix the stub for Lwt_unix.readdir * change the default method for Lwt_glib.install (use the glib main loop by default: more portable) * ignore invalid file descriptors returned by glib (like the emulation of select in glib does) * use environment variables in discover.ml - use LIBRARY_PATH and C_INCLUDE_PATH for searching headers - allow to pass flags for a library in _CLFAGS and _LIBS * add Lwt_unix.on_signal_full ===== 2.4.1 (2012-08-22) ===== * Add Lwt_stream.on_terminate * Fix Lwt_gc * Fix stubs for get_credentials on *BSD ===== 2.4.0 (2012-07-16) ===== * Reimplement Lwt_stream - much simpler and more efficient - do not use Weak - add bounded push streams * Add Lwt.async * Add Lwt_preemptive.run_in_main * Implement Lwt_unix.get_credentials on MacOS X/OpenBSD * Ensure that on_cancel functions are executed first * Better implementation of Lwt.cancel with more tests * Simplify the API for unix jobs * Better handling of the master lock in libev stubs * Windows fixes/updates: - pass -lws2_32 instead of ws2_32.lib if building with mingw - fix a bug causing Lwt_unix.read/write to block when a socket is not readable/writable - port Lwt_process and Lwt_unix.system to Windows * Compatibility with OCaml 4.00: - add O_SHARE_DELETE to Lwt_unix.open_flag - add -package compiler-libs.toplevel for files using Toploop * Do not use module Sys for signal handling to avoid OCaml code to be called in a C thread * Fix Lwt_unix.wrap_syscall: try instead of Lwt.catch * Fix a dead-lock between lwt_unix_send_notification and lwt_unix_recv_notifications * Fix #277: add a function to return the Ssl.socket of a Lwt_ssl.socket * Fix problems with C libraries detection/linking ===== 2.3.2 (2011-11-04) ===== * Add location informations in logs: ** allow loggers to get the current location through local storage ** pass current location to logging functions ** pass the current location with the syntax extension * Add Lwt.on_termination * Add Lwt_unix.reinstall_signal_handler * Add Lwt_io.flush_all * Add assert_lwt keyword to the syntax extension * Add Lwt.wrap * Add Lwt_glib.iter and Lwt_glib.wakeup * OCaml 3.13 ready * Allow to compile without libev support * Fix bugs in Lwt_io * Better handling of forks * Fix many problems on Windows ===== 2.3.1 (2011-07-13) ===== * Fix building of documentation when using the tarball * Add Lwt_unix.fsync and Lwt_unix.fdatasync * Fix the stubs for Lwt_unix.send_msg when fd-passing is not available * Add -lwt-sequence-strict option to the syntax extension * Use a custom PRNG state for Lwt.choose and Lwt.pick * Fix a display glitch when starting the toplevel * Add Lwt_unix.fork which should now be used when one want to use Lwt in the child process * Better implementation of Lwt_unix.readlink and Lwt_unix.gethostbyname, which fixes compilation on Hurd * Add Lwt.wakeup_later and Lwt.wakeup_later_exn to be used when one need to do lot of nested wakeup, which fixes a buffer overflow in Lwt_mutex * Fix Lwt_unix.abort and Lwt_unix.close (threads was never wakeup) * Fix Lwt_throttle for correct timings * Fix subtle use of cancel ===== 2.3.0 (2011-04-12) ===== * Add an extensible system of engines to: ** allow the user to replace libev by another event system, such as select ** allow easier integration of external libraries supporting asynchronous operations * Lots of improvements for Windows: ** use the OCaml select instead of libev by default on Windows ** make asynchronous operations on non-socket file descriptors such as pipes to work ** make glib integration to work * Better use of engines in Lwt_unix: now events are cached to minimize the amount of calls to epoll_ctl * Use an eventfd when possible for notifications for faster delivery * Add modules: ** Lwt_sys: allow to test availability of extra features ** Lwt_react: replace Lwt_event and Lwt_signal * Allow to configure logging rules at runtime in Lwt_log * Add match_lwt and while_lwt to the syntax extension * Fixes: ** syntax extension: handle "lwt ... = ... in ..." at toplevel ** make the notification system fork-proof ** fix an issue with stubs not raising correctly exceptions ===== 2.2.1 (2011-01-26) ===== * Better interaction with Js_of_OCaml. * Add functions {{{Lwt.register_pause_notifier}}} and {{{Lwt.paused_count}}}. ===== 2.2.0 (2010-12-13) ===== * Bugfixes: ** Fix a bug with cancellable threads causing {{{Canceled}}} exceptions to be raised randomly ** Fix a fd-leak in Lwt_io.open_connection * {{{Lwt_unix}}} now use libev instead of select * Add thread local storage support to {{{Lwt}}} * Add backtrace support to {{{Lwt}}}. Now {{{Lwt}}} exceptions can be recored by using the syntax extension with the {{{-lwt-debug}}} command line switch. * Allow blocking system calls to be executed in parallels * Change the type of many functions of {{{Lwt_unix}}}, which now return a {{{Lwt}}} thread * Add functions {{{Lwt_unix.readable}}} and {{{Lwt_unix.writable}}} * Add function {{{Lwt_io.is_busy}}} * Add functions {{{Lwt_event.delay}}} and {{{Lwt_signal.delay}}} * Add function {{{Lwt_term.render_update}}} * Add function {{{Lwt_ssl.embed_socket}}} * Add module {{{Lwt_bytes}}} defining operations on bigarrays instead of strings * Use bigarrays in Lwt_io instead of strings for the internal buffer. Lwt_io.make now takes a function that uses a bigarray. * Add module {{{Lwt_switch}}} ===== 2.1.1 (2010-06-13) ===== * Many bugfixes, including: ** buggy behaviour of cancellable threads ** file descriptor leakage in {{{Lwt_unix.accept_n}}} * Add {{{Lwt.nchoose}}} and {{{Lwt.npick}}} * Use {{{set_close_on_exec}}} for fds created by {{{Lwt_log}}} * Better implementation of lwtized react functions ===== 2.1.0 (2010-04-19) ===== * Rename {{{Lwt.select}}} to {{{Lwt.pick}}} * Removing module {{{Lwt_monitor}}} in favour of {{{Lwt_mutex}}} and new module {{{Lwt_condition}}} * More react helpers: ** {{{Lwt_event.next}}} ** {{{Lwt_event.limit}}} and {{{Lwt_signal.limit}}} ** {{{Lwt_event.from}}} * Adding function {{{Lwt_main.fast_yield}}} * Adding unit tests * Optimisation of {{{Lwt}}} * Adding module {{{Lwt_log}}} for logging * Adding a camlp4 filter for remmoving logging statement or inlining tests * Adding module {{{Lwt_daemon}}} * Adding function {{{Lwt_unix.recv_msg}}} and {{{Lwt_unix.send_msg}}} * Adding function {{{Lwt_unix.wait4}}} * Adding function {{{Lwt_io.establish_server}}} * Adding module {{{Lwt_list}}} * Enhancement in {{{Lwt_process}}}, it now support redirections and timeouts * Allow to use {{{select}}} on arbitrary high file descriptors * More commands and features in {{{Lwt_read_line}}}: ** Handle "undo" command ** New controlable read-lines instances ** More edition commands ** Completion as you type ** Backward search * Enhancement in {{{Lwt_term}}}: more drawing functions and allow to put the terminal into drawing mode * Optimisation of {{{Lwt_stream}}} * Optimisation of {{{Lwt_io.write_char}}} and {{{Lwt_io.read_char}}} * Bugfix of {{{Lwt_stream}}}: two parallel {{{Lwt_stream.get}}} returned the same value * Bugfix in {{{Lwt_unix.connect}}}: it returned immediately on EINPROGRESS * Bugfixes in {{{Lwt_glib}}}: file descriptors were not monitored correctly ===== 2.0.0 (2009-10-15) ===== * Adding modules: ** {{{Lwt_stream}}}: lwt-aware version of the {{{Stream}}} module ** {{{Lwt_gc}}} for using {{{finalise}}} without {{{Lwt_unix.run}}} ** {{{Lwt_io}}}: a new implementation of buffered channels with more features and better handling of concurrent access ** {{{Lwt_text}}}: implementation of text channels ** {{{Lwt_process}}}: helpers to spawn processes and communicate with them ** {{{Lwt_main}}} for abstracting the main loop and allowing replacement by a custom main loop ** {{{Lwt_glib}}} for integration into the glib main event loop ** {{{Lwt_term}}} for interaction with the terminal ** {{{Lwt_read_line}}} for interactive user input ** {{{Lwt_monitor}}}, {{{Lwt_mvar}}}: combined locks for synchronization with conditional variables for notification ** {{{Lwt_throttle}}} for limiting rate of execution (e.g. for authentication procedure) ** {{{Lwt_sequence}}}: mutable sequence of elements ** {{{Lwt_event}}}, {{{Lwt_signal}}}: helpers for reactive programming with lwt * Adding a syntax extension {{{pa_lwt}}}: ** handles anonymous bind {{{a >> b}}} ** adds syntactic sugar for catching errors (ticket #6) ** adds syntactic sugar for parallel let-binding construction ** adds syntactic sugar for for-like loops * Top-level integration: ** threads can runs while reading user input ** line editing support * New enhanced OCaml toplevel with some basic completion features * Adding C stubs to reimplement {{{Unix.read}}} and {{{Unix.write}}} with assumption of non-blocking behaviour * Adding more functions/helpers in {{{Lwt}}} * Fixing memory leaks in {{{Lwt.choose}}} * Bugfix in {{{Lwt_chan.close_*}}} (ticket #66) * Separate the type of threads (covariant) from the type of thread wakeners (contravariant); the type of many functions related to {{{Lwt.wait}}} has been changed * Add cancelable threads * Unix-dependent part is now put in its own archive and findlib package. ===== 1.1.0 (2008-06-25) ===== * Adding module {{{Lwt_pool}}} for creating pools (for example pools of connections) * Adding a few functions in {{{Lwt_chan}}} * Fixing bugs in {{{Lwt_util.map_serial}}} and {{{Lwt_util.iter_serial}}} * Putting {{{Lwt_preemptive}}}, {{{Lwt_lib}}} and {{{Lwt_ssl}}} in separate libraries and findlib subpackages so that lwt.cma depends only on unix.cma. ===== 1.0.0 (and before) ===== * See Ocsigen changelog lwt-2.5.2/COPYING000066400000000000000000000706241270742521300133750ustar00rootroot00000000000000This program is released under the LGPL version 2.1 (see the text below) with the additional exemption that compiling, linking, and/or using OpenSSL is allowed. As a special exception to the GNU Library General Public License, you may also link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library, or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. Some parts, when stated (as licenced under BSD3) are licenced under 3-clauses or Modified BSD License. GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! ====== BSD3 or Modified BSD License ====== Copyright (c) , All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. lwt-2.5.2/LICENSE000066400000000000000000000004121270742521300133330ustar00rootroot00000000000000The Ocsigen application core, and other portions of the official Ocsigen distribution not explicitly licensed otherwise, are licensed under the GNU LESSER GENERAL PUBLIC LICENSE with openssl linking exception -- see the 'COPYING' file in this directory for details. lwt-2.5.2/Makefile000066400000000000000000000030061270742521300137700ustar00rootroot00000000000000# Makefile # -------- # Copyright : (c) 2012, Jérémie Dimino # Licence : BSD3 # # Generic Makefile for oasis project # Set to setup.exe for the release SETUP := setup.exe # Default rule default: build # Setup for the development version setup-dev.exe: _oasis setup.ml grep -v '^#' setup.ml > setup_dev.ml ocamlfind ocamlopt -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || \ ocamlfind ocamlc -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || true rm -f setup_dev.* # Setup for the release setup.exe: setup.ml ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< rm -f setup.cmx setup.cmi setup.o setup.obj setup.cmo build: $(SETUP) setup.data ./$(SETUP) -build $(BUILDFLAGS) doc: $(SETUP) setup.data build ./$(SETUP) -doc $(DOCFLAGS) doc-api: $(SETUP) setup.data build ./$(SETUP) -build lwt-api.docdir/index.html test: $(SETUP) setup.data build ./$(SETUP) -test $(TESTFLAGS) all: $(SETUP) ./$(SETUP) -all $(ALLFLAGS) install: $(SETUP) setup.data ./$(SETUP) -install $(INSTALLFLAGS) uninstall: $(SETUP) setup.data ./$(SETUP) -uninstall $(UNINSTALLFLAGS) reinstall: $(SETUP) setup.data ./$(SETUP) -reinstall $(REINSTALLFLAGS) clean: $(SETUP) ./$(SETUP) -clean $(CLEANFLAGS) distclean: $(SETUP) ./$(SETUP) -distclean $(DISTCLEANFLAGS) configure: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) setup.data: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) .PHONY: default build doc test all install uninstall reinstall clean distclean configure lwt-2.5.2/README.md000066400000000000000000000045641270742521300136210ustar00rootroot00000000000000# Lwt: lightweight thread library for OCaml -------------------------------------------------------------------------- This library is part of the Ocsigen project. See: http://ocsigen.org/lwt -------------------------------------------------------------------------- ## Requirements: * OCaml (>= 4.01) * findlib * [optional] camlp4 (from http://github.com/ocaml/camlp4) * [optional] ppx_tools (from http://github.com/alainfrisch/ppx_tools) * [optional] react (from http://erratique.ch/software/react) * [optional] libev (from http://software.schmorp.de/pkg/libev.html) * [optional] ocamlssl (>= 0.4.0) (ocamlssl needs openssl) (>= 0.4.1 for MacOS) * [optional] glib-2.0 development files and pkg-config If the dependencies are not installed on your computer, you can use OPAM to install them automatically. See: http://opam.ocaml.org/ 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, including `--enable-ppx`; pass `--disable-ppx` explicitly on OCaml <4.02. In order to compile without libev support you must add `--disable-libev`. On OCaml >= 4.02, you should pass '--enable-ppx' and install ppx_tools. * 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/). The Lwt toplevel was deprecated and removed. Use utop instead: https://github.com/diml/utop -------------------------------------------------------------------------- ## Authors: * Jérôme Vouillon * Vincent Balat * Nataliya Guts * Pierre Clairambault * Stéphane Glondu * Jérémie Dimino * Warren Harris * Pierre Chambart * Mauricio Fernandez * Gregoire Henri * Gabriel Radanne * Peter Zotov * Hugo Heuzard * Vincent Bernardoff * Romain Slootmaekers See each source file for copyright information, and COPYING for license. -------------------------------------------------------------------------- lwt-2.5.2/_oasis000066400000000000000000000267641270742521300135500ustar00rootroot00000000000000# +-------------------------------------------------------------------+ # | Package parameters | # +-------------------------------------------------------------------+ OASISFormat: 0.4 OCamlVersion: >= 4.01 Name: lwt Version: 2.5.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, Grégoire Henri, Gabriel Radanne, Peter Zotov, Hugo Heuzard, Vincent Bernardoff, Romain Slootmaekers Homepage: http://ocsigen.org/lwt/ BuildTools: ocamlbuild Plugins: DevFiles (0.4), META (0.4) XDevFilesEnableMakefile: false PostConfCommand: ocaml discover.ml -ext-obj $ext_obj -exec-name $default_executable_name -use-libev $libev -os-type $os_type -use-glib $glib -ccomp-type $ccomp_type -use-pthread $pthread -use-unix $unix -android-target $android_target -libev_default $libev_default PostDistCleanCommand: $rm src/unix/lwt_config.h src/unix/lwt_config.ml src/unix/lwt_unix_jobs_generated.ml src/unix/jobs-unix/* AlphaFeatures: pure_interface Synopsis: Lightweight thread library for OCaml 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 android_target Description: Compiles for Android Default: false Flag all Description: build and install everything Default: false Flag camlp4 Description: Build the syntax extension Default$: flag(all) Flag ppx Description: Build the ppx syntax extension Default$: flag(all) Flag unix Description: Unix support Default: true Flag react Description: React helpers Default$: flag(all) Flag glib Description: Glib integration Default$: flag(all) Flag ssl Description: SSL support Default$: flag(all) Flag preemptive Description: Preemptive threads support Default$: flag(unix) && !flag(android_target) Flag libev Description: Compile with libev support Default$: !os_type(Win32) && !flag(android_target) Flag libev_default Description: Use the libev backend by default Default$: system(linux) || system(linux_elf) || system(linux_aout) || system(linux_eabi) || system(linux_eabihf) Flag pthread Description: Use pthread Default$: !os_type(Win32) # +-------------------------------------------------------------------+ # | Libraries | # +-------------------------------------------------------------------+ Library "lwt" Path: src/core Modules: Lwt_condition, Lwt_list, Lwt, Lwt_mutex, Lwt_mvar, Lwt_pool, Lwt_sequence, Lwt_stream, Lwt_switch, Lwt_pqueue BuildDepends: bytes XMETADescription: Lightweight thread library for OCaml (core library) Library "lwt-log" FindlibName: log FindlibParent: lwt Path: src/logger Modules: Lwt_log_core, Lwt_log_rules BuildDepends: lwt XMETADescription: Logger for lwt 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_unix_jobs_generated, Lwt_config BuildDepends: lwt, lwt.log, unix, bigarray XMETADescription: Unix support for lwt CSources: lwt_config.h, lwt_unix.h, lwt_unix_stubs.c, lwt_libev_stubs.c, lwt_process_stubs.c, jobs-unix/lwt_unix_job_access.c, jobs-unix/lwt_unix_job_chdir.c, jobs-unix/lwt_unix_job_chmod.c, jobs-unix/lwt_unix_job_chown.c, jobs-unix/lwt_unix_job_chroot.c, jobs-unix/lwt_unix_job_close.c, jobs-unix/lwt_unix_job_fchmod.c, jobs-unix/lwt_unix_job_fchown.c, jobs-unix/lwt_unix_job_fdatasync.c, jobs-unix/lwt_unix_job_fsync.c, jobs-unix/lwt_unix_job_ftruncate.c, jobs-unix/lwt_unix_job_link.c, jobs-unix/lwt_unix_job_lseek.c, jobs-unix/lwt_unix_job_mkdir.c, jobs-unix/lwt_unix_job_mkfifo.c, jobs-unix/lwt_unix_job_rename.c, jobs-unix/lwt_unix_job_rmdir.c, jobs-unix/lwt_unix_job_symlink.c, jobs-unix/lwt_unix_job_tcdrain.c, jobs-unix/lwt_unix_job_tcflow.c, jobs-unix/lwt_unix_job_tcflush.c, jobs-unix/lwt_unix_job_tcsendbreak.c, jobs-unix/lwt_unix_job_truncate.c, jobs-unix/lwt_unix_job_unlink.c if os_type(Win32) && ccomp_type(msvc) CCLib+: ws2_32.lib else if os_type(Win32) CCLib+: -lws2_32 Library "lwt-simple-top" Build$: flag(unix) || flag(all) Install$: flag(unix) || flag(all) FindlibName: simple-top FindlibParent: lwt Path: src/simple_top InternalModules: Lwt_simple_top BuildDepends: lwt, lwt.unix, compiler-libs.common 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_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-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-syntax" Build$: flag(camlp4) || flag(all) Install$: flag(camlp4) || flag(all) FindlibName: syntax FindlibParent: lwt Path: syntax Modules: Pa_lwt BuildDepends: camlp4, camlp4.quotations.o, camlp4.extend XMETAType: syntax XMETADescription: Syntactic sugars for Lwt XMETARequires: camlp4, lwt.syntax.options Library "lwt-syntax-options" Build$: flag(camlp4) || flag(all) Install$: flag(camlp4) || flag(all) FindlibName: options FindlibParent: lwt-syntax Path: syntax InternalModules: Pa_lwt_options BuildDepends: camlp4 XMETAType: syntax XMETADescription: Options for syntax extensions XMETARequires: camlp4 Library "lwt-syntax-log" Build$: flag(camlp4) || flag(all) Install$: flag(camlp4) || flag(all) FindlibName: log FindlibParent: lwt-syntax Path: syntax Modules: Pa_lwt_log BuildDepends: camlp4, camlp4.quotations.o XMETAType: syntax XMETADescription: Syntactic sugars for logging XMETARequires: camlp4, lwt.syntax.options Library "ppx" Build$: flag(ppx) || flag(all) Install$: flag(ppx) || flag(all) FindlibName: ppx FindlibParent: lwt Path: ppx Modules: Ppx_lwt XMETADescription: New-style (ppx) syntax extension XMETARequires: lwt XMETAExtraLines: ppx = "ppx_lwt" Executable "ppx_lwt" Build$: flag(ppx) || flag(all) Install$: flag(ppx) || flag(all) Path: ppx MainIs: ppx_lwt_ex.ml BuildDepends: compiler-libs.common, ppx_tools.metaquot CompiledObject: best # +-------------------------------------------------------------------+ # | Doc | # +-------------------------------------------------------------------+ Document "lwt-manual" Title: Lwt user manual Type: custom (0.3) Install: true XCustom: make -C manual manual.pdf DataFiles: manual/manual.pdf InstallDir: $pdfdir Document "lwt-api" Title: API reference for Lwt Type: ocamlbuild (0.3) Install: true InstallDir: $htmldir/api DataFiles: utils/style.css BuildTools: ocamldoc XOCamlbuildPath: ./ XOCamlbuildLibraries: lwt, lwt.glib, lwt.preemptive, lwt.react, lwt.ssl, lwt.log, lwt.unix, lwt.syntax, lwt.syntax.log, lwt.ppx # +-------------------------------------------------------------------+ # | Examples | # +-------------------------------------------------------------------+ Executable logging Path: examples/unix Build$: flag(unix) && flag(camlp4) Install: false MainIs: logging.ml BuildDepends: lwt.unix, lwt.syntax CompiledObject: best Executable relay Path: examples/unix Build$: flag(unix) && flag(camlp4) Install: false MainIs: relay.ml BuildDepends: lwt.unix, lwt.syntax CompiledObject: best Executable parallelize Path: examples/unix Build$: flag(unix) && flag(camlp4) Install: false MainIs: parallelize.ml BuildDepends: lwt.unix, lwt.syntax CompiledObject: best # +-------------------------------------------------------------------+ # | Tests | # +-------------------------------------------------------------------+ Library test Path: tests Modules: Test Install: false Build$: flag(tests) && (flag(unix) || flag(all)) BuildDepends: lwt, unix, lwt.unix Executable test_core Path: tests/core Build$: flag(tests) && (flag(unix) || flag(all)) Install: false CompiledObject: best MainIs: main.ml BuildDepends: test, lwt, unix, lwt.unix Executable test_unix Path: tests/unix Build$: flag(tests) && (flag(unix) || flag(all)) Install: false CompiledObject: best MainIs: main.ml BuildDepends: test, lwt, unix, lwt.unix Executable test_react Path: tests/react Build$: flag(tests) && ((flag(unix) && flag(react)) || flag(all)) Install: false CompiledObject: best MainIs: main.ml BuildDepends: test, lwt, unix, lwt.unix, react, lwt.react Executable test_preemptive Path: tests/preemptive Build$: flag(tests) && ((flag(preemptive) && flag(unix)) || flag(all)) Install: false CompiledObject: best MainIs: main.ml BuildDepends: test, lwt, unix, lwt.unix, lwt.preemptive, threads Executable test_ppx Path: tests/ppx Build$: flag(tests) && ((flag(ppx) && flag(unix)) || flag(all)) Install: false CompiledObject: best MainIs: main.ml BuildTools: ppx_lwt BuildDepends: test, lwt, lwt.unix Test core Command: $test_core TestTools: test_core Run$: flag(tests) && (flag(unix) || flag(all)) Test unix Command: $test_unix TestTools: test_unix Run$: flag(tests) && (flag(unix) || flag(all)) Test react Command: $test_react TestTools: test_react Run$: flag(tests) && ((flag(unix) && flag(react)) || flag(all)) Test preemptive Command: $test_preemptive TestTools: test_preemptive Run$: flag(tests) && ((flag(preemptive) && flag(unix)) || flag(all)) Test ppx Command: $test_ppx TestTools: test_ppx Run$: flag(tests) && ((flag(ppx) && flag(unix)) || flag(all)) # +-------------------------------------------------------------------+ # | Misc | # +-------------------------------------------------------------------+ SourceRepository head Type: git Location: git://github.com/ocsigen/lwt Browser: https://github.com/ocsigen/lwt lwt-2.5.2/_tags000066400000000000000000000427141270742521300133610ustar00rootroot00000000000000# -*- conf -*- not : safe_string # Syntax extension : syntax(camlp4o) # Stubs : use_C_libev, use_C_pthread : use_C_glib <**/*.c>: use_lwt_headers <**/*.h>: use_lwt_headers # Ppx tests : ppx_lwt # Examples : syntax(camlp4o), package(camlp4), pa_lwt_options, pa_lwt, pa_lwt_log # OASIS_START # DO NOT EDIT (digest: c021494f3c14777d9e4f05e049ef0533) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process true: annot, bin_annot <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse ".bzr": not_hygienic ".hg": -traverse ".hg": not_hygienic ".git": -traverse ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic # Library lwt "src/core/lwt.cmxs": use_lwt : package(bytes) # Library lwt-log "src/logger/lwt-log.cmxs": use_lwt-log : package(bytes) : use_lwt # Library lwt-unix "src/unix/lwt-unix.cmxs": use_lwt-unix : oasis_library_lwt_unix_cclib "src/unix/liblwt-unix_stubs.lib": oasis_library_lwt_unix_cclib "src/unix/dlllwt-unix_stubs.dll": oasis_library_lwt_unix_cclib "src/unix/liblwt-unix_stubs.a": oasis_library_lwt_unix_cclib "src/unix/dlllwt-unix_stubs.so": oasis_library_lwt_unix_cclib : use_liblwt-unix_stubs : package(bigarray) : package(bytes) : package(unix) : use_lwt : use_lwt-log "src/unix/lwt_unix_stubs.c": package(bigarray) "src/unix/lwt_unix_stubs.c": package(bytes) "src/unix/lwt_unix_stubs.c": package(unix) "src/unix/lwt_unix_stubs.c": use_lwt "src/unix/lwt_unix_stubs.c": use_lwt-log "src/unix/lwt_libev_stubs.c": package(bigarray) "src/unix/lwt_libev_stubs.c": package(bytes) "src/unix/lwt_libev_stubs.c": package(unix) "src/unix/lwt_libev_stubs.c": use_lwt "src/unix/lwt_libev_stubs.c": use_lwt-log "src/unix/lwt_process_stubs.c": package(bigarray) "src/unix/lwt_process_stubs.c": package(bytes) "src/unix/lwt_process_stubs.c": package(unix) "src/unix/lwt_process_stubs.c": use_lwt "src/unix/lwt_process_stubs.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_access.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_access.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_access.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_access.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_access.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_chdir.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_chdir.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_chdir.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_chdir.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_chdir.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_chmod.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_chmod.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_chmod.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_chmod.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_chmod.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_chown.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_chown.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_chown.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_chown.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_chown.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_chroot.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_chroot.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_chroot.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_chroot.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_chroot.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_close.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_close.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_close.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_close.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_close.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_fchmod.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_fchmod.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_fchmod.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_fchmod.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_fchmod.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_fchown.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_fchown.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_fchown.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_fchown.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_fchown.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_fdatasync.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_fdatasync.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_fdatasync.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_fdatasync.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_fdatasync.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_fsync.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_fsync.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_fsync.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_fsync.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_fsync.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_ftruncate.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_ftruncate.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_ftruncate.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_ftruncate.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_ftruncate.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_link.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_link.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_link.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_link.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_link.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_lseek.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_lseek.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_lseek.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_lseek.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_lseek.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_mkdir.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_mkdir.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_mkdir.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_mkdir.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_mkdir.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_mkfifo.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_mkfifo.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_mkfifo.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_mkfifo.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_mkfifo.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_rename.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_rename.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_rename.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_rename.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_rename.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_rmdir.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_rmdir.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_rmdir.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_rmdir.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_rmdir.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_symlink.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_symlink.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_symlink.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_symlink.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_symlink.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_tcdrain.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_tcdrain.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_tcdrain.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_tcdrain.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_tcdrain.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_tcflow.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_tcflow.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_tcflow.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_tcflow.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_tcflow.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_tcflush.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_tcflush.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_tcflush.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_tcflush.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_tcflush.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_tcsendbreak.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_tcsendbreak.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_tcsendbreak.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_tcsendbreak.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_tcsendbreak.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_truncate.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_truncate.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_truncate.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_truncate.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_truncate.c": use_lwt-log "src/unix/jobs-unix/lwt_unix_job_unlink.c": package(bigarray) "src/unix/jobs-unix/lwt_unix_job_unlink.c": package(bytes) "src/unix/jobs-unix/lwt_unix_job_unlink.c": package(unix) "src/unix/jobs-unix/lwt_unix_job_unlink.c": use_lwt "src/unix/jobs-unix/lwt_unix_job_unlink.c": use_lwt-log # Library lwt-simple-top "src/simple_top/lwt-simple-top.cmxs": use_lwt-simple-top : package(bigarray) : package(bytes) : package(compiler-libs.common) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix # Library lwt-react "src/react/lwt-react.cmxs": use_lwt-react : package(bytes) : package(react) : use_lwt # Library lwt-preemptive "src/preemptive/lwt-preemptive.cmxs": use_lwt-preemptive : package(bigarray) : package(bytes) : package(threads) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix # Library lwt-glib "src/glib/lwt-glib.cmxs": use_lwt-glib : use_liblwt-glib_stubs : package(bigarray) : package(bytes) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix "src/glib/lwt_glib_stubs.c": package(bigarray) "src/glib/lwt_glib_stubs.c": package(bytes) "src/glib/lwt_glib_stubs.c": package(unix) "src/glib/lwt_glib_stubs.c": use_lwt "src/glib/lwt_glib_stubs.c": use_lwt-log "src/glib/lwt_glib_stubs.c": use_lwt-unix # Library lwt-ssl "src/ssl/lwt-ssl.cmxs": use_lwt-ssl : package(bigarray) : package(bytes) : package(ssl) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix # Library lwt-syntax "syntax/lwt-syntax.cmxs": use_lwt-syntax : package(camlp4.extend) # Library lwt-syntax-options "syntax/lwt-syntax-options.cmxs": use_lwt-syntax-options # Library lwt-syntax-log "syntax/lwt-syntax-log.cmxs": use_lwt-syntax-log : package(camlp4) : package(camlp4.quotations.o) # Library ppx "ppx/ppx.cmxs": use_ppx # Executable ppx_lwt : package(compiler-libs.common) : package(ppx_tools.metaquot) : package(compiler-libs.common) : package(ppx_tools.metaquot) # Executable logging : package(bigarray) : package(bytes) : package(camlp4) : package(camlp4.extend) : package(camlp4.quotations.o) : package(unix) : use_lwt : use_lwt-log : use_lwt-syntax : use_lwt-unix # Executable relay : package(bigarray) : package(bytes) : package(camlp4) : package(camlp4.extend) : package(camlp4.quotations.o) : package(unix) : use_lwt : use_lwt-log : use_lwt-syntax : use_lwt-unix # Executable parallelize : package(bigarray) : package(bytes) : package(camlp4) : package(camlp4.extend) : package(camlp4.quotations.o) : package(unix) : use_lwt : use_lwt-log : use_lwt-syntax : use_lwt-unix : package(bigarray) : package(bytes) : package(camlp4) : package(camlp4.extend) : package(camlp4.quotations.o) : package(unix) : use_lwt : use_lwt-log : use_lwt-syntax : use_lwt-unix # Library test "tests/test.cmxs": use_test : package(bigarray) : package(bytes) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix # Executable test_core : package(bigarray) : package(bytes) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix : use_test : package(bigarray) : package(bytes) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix : use_test # Executable test_unix : package(bigarray) : package(bytes) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix : use_test : package(bigarray) : package(bytes) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix : use_test # Executable test_react : package(bigarray) : package(bytes) : package(react) : package(unix) : use_lwt : use_lwt-log : use_lwt-react : use_lwt-unix : use_test : package(bigarray) : package(bytes) : package(react) : package(unix) : use_lwt : use_lwt-log : use_lwt-react : use_lwt-unix : use_test # Executable test_preemptive : package(bigarray) : package(bytes) : package(threads) : package(unix) : use_lwt : use_lwt-log : use_lwt-preemptive : use_lwt-unix : use_test : package(bigarray) : package(bytes) : package(threads) : package(unix) : use_lwt : use_lwt-log : use_lwt-preemptive : use_lwt-unix : use_test # Executable test_ppx : package(bigarray) : package(bytes) : package(compiler-libs.common) : package(ppx_tools.metaquot) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix : use_test : package(bigarray) : package(bytes) : package(compiler-libs.common) : package(ppx_tools.metaquot) : package(unix) : use_lwt : use_lwt-log : use_lwt-unix : use_test # OASIS_STOP lwt-2.5.2/apiref-intro000066400000000000000000000043151270742521300146560ustar00rootroot00000000000000{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 Logger} The {e lwt.log} package provides a logger engine. {!modules: Lwt_log_core } This package depends on the {e core} library {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, the {e unix} package and the {e lwt.log} 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 caml4 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 ppx syntax extension} This new ppx extension provided by the package {e lwt.ppx} replaces {!Pa_lwt} and {!Pa_lwt_log} using the new ppx mechanism. {!modules: Ppx_lwt } {2 Miscellaneous} The following modules are wrapper for integration of non-Lwt functions/packages into Lwt. {!modules: Lwt_glib Lwt_preemptive Lwt_ssl } {2 Index} {!indexlist} lwt-2.5.2/configure000077500000000000000000000005531270742521300142430ustar00rootroot00000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) set -e FST=true for i in "$@"; do if $FST; then set -- FST=false fi case $i in --*=*) ARG=${i%%=*} VAL=${i##*=} set -- "$@" "$ARG" "$VAL" ;; *) set -- "$@" "$i" ;; esac done ocaml setup.ml -configure "$@" # OASIS_STOP lwt-2.5.2/discover.ml000066400000000000000000000535741270742521300145170ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Program discover * Copyright (C) 2010 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (* Discover available features *) open Printf (* +-----------------------------------------------------------------+ | Search path | +-----------------------------------------------------------------+ *) (* List of search paths for header files, mostly for MacOS users. libev is installed by port systems into non-standard locations by default on MacOS. We use a hardcorded list of path + the ones from C_INCLUDE_PATH and LIBRARY_PATH. *) let ( // ) = Filename.concat let default_search_paths = List.map (fun dir -> (dir // "include", dir // "lib")) [ "/usr"; "/usr/local"; "/usr/pkg"; "/opt"; "/opt/local"; "/sw"; "/mingw"; ] let path_sep = if Sys.os_type = "Win32" then ';' else ':' let split_path str = let len = String.length str in let rec aux i = if i >= len then [] else let j = try String.index_from str i path_sep with Not_found -> len in String.sub str i (j - i) :: aux (j + 1) in aux 0 let rec replace_last path ~patt ~repl = let comp = Filename.basename path and parent = Filename.dirname path in if comp = patt then parent // repl else if parent = path then path else (replace_last parent ~patt ~repl) // comp let search_paths = let get var f = try List.map f (split_path (Sys.getenv var)) with Not_found -> [] in List.flatten [ get "C_INCLUDE_PATH" (fun dir -> (dir, replace_last dir ~patt:"include" ~repl:"lib")); get "LIBRARY_PATH" (fun dir -> (replace_last dir ~patt:"lib" ~repl:"include", dir)); default_search_paths; ] (* +-----------------------------------------------------------------+ | Test codes | +-----------------------------------------------------------------+ *) let caml_code = " external test : unit -> unit = \"lwt_test\" let () = test () " let pthread_code = " #include #include CAMLprim value lwt_test(value Unit) { pthread_create(0, 0, 0, 0); return Val_unit; } " let libev_code = " #include #include CAMLprim value lwt_test(value Unit) { ev_default_loop(0); return Val_unit; } " let fd_passing_code = " #include #include #include CAMLprim value lwt_test(value Unit) { 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(value Unit) { sched_getcpu(); return Val_unit; } " let affinity_code = " #include #define _GNU_SOURCE #include CAMLprim value lwt_test(value Unit) { sched_getaffinity(0, 0, 0); return Val_unit; } " let eventfd_code = " #include #include CAMLprim value lwt_test(value Unit) { eventfd(0, 0); return Val_unit; } " let get_credentials_code struct_name = " #define _GNU_SOURCE #include #include #include CAMLprim value lwt_test(value Unit) { struct " ^ struct_name ^ " cred; socklen_t cred_len = sizeof(cred); getsockopt(0, SOL_SOCKET, SO_PEERCRED, &cred, &cred_len); return Val_unit; } " let get_peereid_code = " #include #include #include CAMLprim value lwt_test(value Unit) { uid_t euid; gid_t egid; getpeereid(0, &euid, &egid); return Val_unit; } " let fdatasync_code = " #include #include CAMLprim value lwt_test(value Unit) { fdatasync(0); return Val_unit; } " let glib_code = " #include #include CAMLprim value lwt_test(value Unit) { g_main_context_dispatch(0); return Val_unit; } " let netdb_reentrant_code = " #define _POSIX_PTHREAD_SEMANTICS #include #include #include CAMLprim value lwt_test(value Unit) { struct hostent *he; struct servent *se; he = gethostbyname_r((const char *)NULL, (struct hostent *)NULL,(char *)NULL, (int)0, (struct hostent **)NULL, (int *)NULL); he = gethostbyaddr_r((const char *)NULL, (int)0, (int)0,(struct hostent *)NULL, (char *)NULL, (int)0, (struct hostent **)NULL,(int *)NULL); se = getservbyname_r((const char *)NULL, (const char *)NULL,(struct servent *)NULL, (char *)NULL, (int)0, (struct servent **)NULL); se = getservbyport_r((int)0, (const char *)NULL,(struct servent *)NULL, (char *)NULL, (int)0, (struct servent **)NULL); pr = getprotoent_r((struct protoent *)NULL, (char *)NULL, (int)0, (struct protoent **)NULL); pr = getprotobyname_r((const char *)NULL, (struct protoent *)NULL, (char *)NULL, (int)0, (struct protoent **)NULL); pr = getprotobynumber_r((int)0, (struct protoent *)NULL, (char *)NULL, (int)0, (struct protoent **)NULL); return Val_unit; } " let hostent_reentrant_code = " #define _GNU_SOURCE #include #include #include /* Helper functions for not re-entrant functions */ #if !defined(HAS_GETHOSTBYADDR_R) || (HAS_GETHOSTBYADDR_R != 7 && HAS_GETHOSTBYADDR_R != 8) #define NON_R_GETHOSTBYADDR 1 #endif #if !defined(HAS_GETHOSTBYNAME_R) || (HAS_GETHOSTBYNAME_R != 5 && HAS_GETHOSTBYNAME_R != 6) #define NON_R_GETHOSTBYNAME 1 #endif CAMLprim value lwt_test(value u) { (void)u; #if defined(NON_R_GETHOSTBYNAME) || defined(NON_R_GETHOSTBYNAME) #error \"not available\" #else return Val_unit; #endif } " let struct_ns_code conversion = " #define _GNU_SOURCE #include #include #include #include #define NANOSEC" ^ conversion ^ " CAMLprim value lwt_test() { struct stat *buf; double a, m, c; a = (double)NANOSEC(buf, a); m = (double)NANOSEC(buf, m); c = (double)NANOSEC(buf, c); return Val_unit; } " (* +-----------------------------------------------------------------+ | Compilation | +-----------------------------------------------------------------+ *) let ocamlc = ref "ocamlfind ocamlc" let ext_obj = ref ".o" let exec_name = ref "a.out" let use_libev = ref true let use_glib = ref false let use_pthread = ref true let use_unix = ref true let os_type = ref "Unix" let android_target = ref false let ccomp_type = ref "cc" let libev_default = ref true let debug = ref (try Sys.getenv "DEBUG" = "y" with Not_found -> false) let dprintf fmt = if !debug then ( eprintf "DBG: "; kfprintf (fun oc -> fprintf oc "\n%!") stderr fmt ) else ifprintf stderr fmt let log_file = ref "" let caml_file = ref "" (* Search for a header file in standard directories. *) let search_header header = let rec loop = function | [] -> None | (dir_include, dir_lib) :: dirs -> if Sys.file_exists (dir_include // header) then Some (dir_include, dir_lib) else loop dirs in loop search_paths (* CFLAGS should not be passed to the linker. *) let compile (opt, lib) stub_file = let cmd fmt = ksprintf (fun s -> dprintf "RUN: %s" s; Sys.command s = 0) fmt in let obj_file = Filename.chop_suffix stub_file ".c" ^ !ext_obj in (* First compile the .c file using -ocamlc and CFLAGS (opt) *) (cmd "%s -c %s %s -ccopt -o -ccopt %s >> %s 2>&1" !ocamlc (String.concat " " (List.map (fun x -> "-ccopt " ^ x) (List.map Filename.quote opt))) (Filename.quote stub_file) (Filename.quote obj_file) (Filename.quote !log_file)) && (* Now link the resulting .o with the LDFLAGS (lib) *) (cmd "%s -custom %s %s %s >> %s 2>&1" !ocamlc (Filename.quote obj_file) (Filename.quote !caml_file) (String.concat " " (List.map (sprintf "-cclib %s") lib)) (Filename.quote !log_file)) let safe_remove file_name = if !debug then dprintf "DEBUG: Not removing %s\n" file_name else 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 stub_file ^ !ext_obj) in try output_string oc stub_code; flush oc; close_out oc; let result = compile args stub_file in cleanup (); result with exn -> (try close_out oc with _ -> ()); cleanup (); raise exn let config = open_out "src/unix/lwt_config.h" let config_ml = open_out "src/unix/lwt_config.ml" let () = fprintf config "\ #ifndef __LWT_CONFIG_H #define __LWT_CONFIG_H " let not_available = ref [] let test_feature ?(do_check = true) name macro test = if do_check then begin printf "testing for %s:%!" name; if test () then begin if macro <> "" then begin fprintf config "#define %s\n" macro; fprintf config_ml "let _%s = true\n" macro end; printf " %s available\n%!" (String.make (34 - String.length name) '.') end else begin if macro <> "" then begin fprintf config "//#define %s\n" macro; fprintf config_ml "let _%s = false\n" macro end; printf " %s unavailable\n%!" (String.make (34 - String.length name) '.'); not_available := name :: !not_available end end else begin printf "not checking for %s\n%!" name; if macro <> "" then begin fprintf config "//#define %s\n" macro; fprintf config_ml "let _%s = false\n" macro end end (* +-----------------------------------------------------------------+ | pkg-config | +-----------------------------------------------------------------+ *) let split str = let rec skip_spaces i = if i = String.length str then [] else if str.[i] = ' ' then skip_spaces (i + 1) else extract i (i + 1) and extract i j = if j = String.length str then [String.sub str i (j - i)] else if str.[j] = ' ' then String.sub str i (j - i) :: skip_spaces (j + 1) else extract i (j + 1) in skip_spaces 0 let pkg_config flags = if ksprintf Sys.command "pkg-config %s > %s 2>&1" flags !log_file = 0 then begin let ic = open_in !log_file in let line = input_line ic in close_in ic; split line end else raise Exit let pkg_config_flags name = try (* Get compile flags. *) let opt = ksprintf pkg_config "--cflags %s" name in (* Get linking flags. *) let lib = if !ccomp_type = "msvc" then (* With msvc we need to pass "glib-2.0.lib" instead of "-lglib-2.0" otherwise executables will fail. *) ksprintf pkg_config "--libs-only-L %s" name @ ksprintf pkg_config "--libs-only-l --msvc-syntax %s" name else ksprintf pkg_config "--libs %s" name in Some (opt, lib) with Exit -> None let lib_flags env_var_prefix fallback = let get var = try Some (split (Sys.getenv var)) with Not_found -> None in match get (env_var_prefix ^ "_CFLAGS"), get (env_var_prefix ^ "_LIBS") with | Some opt, Some lib -> (opt, lib) | x -> let opt, lib = fallback () in match x with | Some opt, Some lib -> assert false | Some opt, None -> (opt, lib) | None, Some lib -> (opt, lib) | None, None -> (opt, lib) (* +-----------------------------------------------------------------+ | Entry point | +-----------------------------------------------------------------+ *) let arg_bool r = Arg.Symbol (["true"; "false"], function | "true" -> r := true | "false" -> r := false | _ -> assert false) let () = let args = [ "-ocamlc", Arg.Set_string ocamlc, " ocamlc"; "-ext-obj", Arg.Set_string ext_obj, " C object files extension"; "-exec-name", Arg.Set_string exec_name, " name of the executable produced by ocamlc"; "-use-libev", arg_bool use_libev, " whether to check for libev"; "-use-glib", arg_bool use_glib, " whether to check for glib"; "-use-pthread", arg_bool use_pthread, " whether to use pthread"; "-use-unix", arg_bool use_unix, " whether to build lwt.unix"; "-os-type", Arg.Set_string os_type, " type of the target os"; "-android-target", arg_bool android_target, " compiles for Android"; "-ccomp-type", Arg.Set_string ccomp_type, " C compiler type"; "-libev_default", arg_bool libev_default, " whether to use the libev backend by default"; ] in Arg.parse args ignore "check for external C libraries and available features\noptions are:"; (* Check nothing if we do not build lwt.unix. *) if not !use_unix then exit 0; (* Put the caml code into a temporary file. *) let file, oc = Filename.open_temp_file "lwt_caml" ".ml" in caml_file := file; output_string oc caml_code; close_out oc; log_file := Filename.temp_file "lwt_output" ".log"; (* Cleanup things on exit. *) at_exit (fun () -> (try close_out config with _ -> ()); (try close_out config_ml with _ -> ()); safe_remove !log_file; safe_remove !exec_name; safe_remove !caml_file; safe_remove (Filename.chop_extension !caml_file ^ ".cmi"); safe_remove (Filename.chop_extension !caml_file ^ ".cmo")); let setup_data = ref [] in (* Test for pkg-config. *) test_feature ~do_check:(!use_libev || !use_glib) "pkg-config" "" (fun () -> ksprintf Sys.command "pkg-config --version > %s 2>&1" !log_file = 0); (* Not having pkg-config is not fatal. *) let have_pkg_config = !not_available = [] in not_available := []; let test_libev () = let opt, lib = lib_flags "LIBEV" (fun () -> match if have_pkg_config then pkg_config_flags "libev" else None with | Some (opt, lib) -> (opt, lib) | None -> match search_header "ev.h" with | Some (dir_i, dir_l) -> (["-I" ^ dir_i], ["-L" ^ dir_l; "-lev"]) | None -> ([], ["-lev"])) in setup_data := ("libev_opt", opt) :: ("libev_lib", lib) :: !setup_data; test_code (opt, lib) libev_code in let test_pthread () = let opt, lib = if !android_target then ([], []) else lib_flags "PTHREAD" (fun () -> match search_header "pthread.h" with | Some (dir_i, dir_l) -> (["-I" ^ dir_i], ["-L" ^ dir_l; "-lpthread"]) | None -> ([], ["-lpthread"])) in setup_data := ("pthread_opt", opt) :: ("pthread_lib", lib) :: !setup_data; test_code (opt, lib) pthread_code in let test_glib () = let opt, lib = lib_flags "GLIB" (fun () -> match if have_pkg_config then pkg_config_flags "glib-2.0" else None with | Some (opt, lib) -> (opt, lib) | None -> ([], ["-lglib-2.0"])) in setup_data := ("glib_opt", opt) :: ("glib_lib", lib) :: !setup_data; test_code (opt, lib) glib_code in let test_nanosecond_stat () = printf "testing for nanosecond stat support:%!"; let conversions = [ ("(buf, field) buf->st_##field##tim.tv_nsec", "*tim.tv_nsec"); ("(buf, field) buf->st_##field##timespec.tv_nsec", "*timespec.tv_nsec"); ("(buf, field) buf->st_##field##timensec", "*timensec"); ] in let fallback = "(buf, field) 0.0" in let conversion = try let (conversion, desc) = List.find (fun (conversion, _desc) -> test_code ([], []) (struct_ns_code conversion) ) conversions in printf " %s %s\n%!" (String.make 11 '.') desc; conversion with Not_found -> begin printf " %s unavailable\n%!" (String.make 11 '.'); fprintf config "#define NANOSEC%s\n" fallback; fallback end in fprintf config "#define NANOSEC%s\n" conversion in test_feature ~do_check:!use_libev "libev" "HAVE_LIBEV" test_libev; test_feature ~do_check:!use_pthread "pthread" "HAVE_PTHREAD" test_pthread; test_feature ~do_check:!use_glib "glib" "" test_glib; if !not_available <> [] then begin if not have_pkg_config then printf "Warning: the 'pkg-config' command is not available."; printf " The following recquired C libraries are missing: %s. Please install them and retry. If they are installed in a non-standard location or need special flags, set the environment variables _CFLAGS and _LIBS accordingly and retry. For example, if libev is installed in /opt/local, you can type: export LIBEV_CFLAGS=-I/opt/local/include export LIBEV_LIBS=-L/opt/local/lib To compile without libev support, use ./configure --disable-libev ... " (String.concat ", " !not_available); exit 1 end; if !os_type <> "Win32" && not !use_pthread then begin printf " No threading library available! One is needed if you want to build lwt.unix. Lwt can use pthread or the win32 API. "; exit 1 end; let do_check = !os_type <> "Win32" in test_feature ~do_check "eventfd" "HAVE_EVENTFD" (fun () -> test_code ([], []) eventfd_code); test_feature ~do_check "fd passing" "HAVE_FD_PASSING" (fun () -> test_code ([], []) fd_passing_code); test_feature ~do_check:(do_check && not !android_target) "sched_getcpu" "HAVE_GETCPU" (fun () -> test_code ([], []) getcpu_code); test_feature ~do_check:(do_check && not !android_target) "affinity getting/setting" "HAVE_AFFINITY" (fun () -> test_code ([], []) affinity_code); test_feature ~do_check "credentials getting (Linux)" "HAVE_GET_CREDENTIALS_LINUX" (fun () -> test_code ([], []) (get_credentials_code "ucred")); test_feature ~do_check "credentials getting (NetBSD)" "HAVE_GET_CREDENTIALS_NETBSD" (fun () -> test_code ([], []) (get_credentials_code "sockcred")); test_feature ~do_check "credentials getting (OpenBSD)" "HAVE_GET_CREDENTIALS_OPENBSD" (fun () -> test_code ([], []) (get_credentials_code "sockpeercred")); test_feature ~do_check "credentials getting (FreeBSD)" "HAVE_GET_CREDENTIALS_FREEBSD" (fun () -> test_code ([], []) (get_credentials_code "cmsgcred")); test_feature ~do_check "credentials getting (getpeereid)" "HAVE_GETPEEREID" (fun () -> test_code ([], []) get_peereid_code); test_feature ~do_check "fdatasync" "HAVE_FDATASYNC" (fun () -> test_code ([], []) fdatasync_code); test_feature ~do_check:(do_check && not !android_target) "netdb_reentrant" "HAVE_NETDB_REENTRANT" (fun () -> test_code ([], []) netdb_reentrant_code); test_feature ~do_check "reentrant gethost*" "HAVE_REENTRANT_HOSTENT" (fun () -> test_code ([], []) hostent_reentrant_code); test_nanosecond_stat (); let get_cred_vars = [ "HAVE_GET_CREDENTIALS_LINUX"; "HAVE_GET_CREDENTIALS_NETBSD"; "HAVE_GET_CREDENTIALS_OPENBSD"; "HAVE_GET_CREDENTIALS_FREEBSD"; "HAVE_GETPEEREID"; ] in Printf.fprintf config "\ #if %s # define HAVE_GET_CREDENTIALS #endif " (String.concat " || " (List.map (Printf.sprintf "defined(%s)") get_cred_vars)); Printf.fprintf config_ml "let _HAVE_GET_CREDENTIALS = %s\n" (String.concat " || " (List.map (fun s -> "_" ^ s) get_cred_vars)); if !os_type = "Win32" then begin output_string config "#define LWT_ON_WINDOWS\n"; end else begin output_string config "//#define LWT_ON_WINDOWS\n"; end; if !android_target then begin output_string config_ml "let android = true\n" end else begin output_string config_ml "let android = false\n" end; if !libev_default then begin output_string config_ml "let libev_default = true\n" end else begin output_string config_ml "let libev_default = false\n" end; fprintf config "#endif\n"; (* Our setup.data keys. *) let setup_data_keys = [ "libev_opt"; "libev_lib"; "pthread_lib"; "pthread_opt"; "glib_opt"; "glib_lib"; ] in (* Load setup.data *) let setup_data_lines = match try Some (open_in "setup.data") with Sys_error _ -> None with | Some ic -> let rec aux acc = match try Some (input_line ic) with End_of_file -> None with | None -> close_in ic; acc | Some line -> match try Some(String.index line '=') with Not_found -> None with | Some idx -> let key = String.sub line 0 idx in if List.mem key setup_data_keys then aux acc else aux (line :: acc) | None -> aux (line :: acc) in aux [] | None -> [] in (* Add flags to setup.data *) let setup_data_lines = List.fold_left (fun lines (name, args) -> sprintf "%s=%S" name (String.concat " " args) :: lines) setup_data_lines !setup_data in let oc = open_out "setup.data" in List.iter (fun str -> output_string oc str; output_char oc '\n') (List.rev setup_data_lines); close_out oc; close_out config; close_out config_ml; (* Generate stubs. *) print_endline "Generating C stubs..."; exit (Sys.command "ocaml src/unix/gen_stubs.ml") lwt-2.5.2/examples/000077500000000000000000000000001270742521300141475ustar00rootroot00000000000000lwt-2.5.2/examples/gtk/000077500000000000000000000000001270742521300147345ustar00rootroot00000000000000lwt-2.5.2/examples/gtk/Makefile000066400000000000000000000002041270742521300163700ustar00rootroot00000000000000all: ocamlbuild -use-ocamlfind -classic-display -tag 'syntax(camlp4o)' -package lwt.unix,lwt.glib,lwt.syntax,lablgtk2 connect.byte lwt-2.5.2/examples/gtk/connect.ml000066400000000000000000000203631270742521300167230ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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.Infix (* +-----------------------------------------------------------------+ | 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); Lwt.return_unit (* 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 = Lwt.wait () in (* Wakeup the thread when the popup is closed. *) ignore (dialog#connect#response (Lwt.wakeup wakener)); dialog#show (); ignore ( match_lwt waiter with | `DELETE_EVENT -> Lwt.return_unit | `CANCEL -> dialog#destroy (); Lwt.return_unit | `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; Lwt.return_unit 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 -> Lwt.return_unit | Some (ic, oc, thread) -> Lwt.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); Lwt.return_unit in (* Clear the buffer. *) view#buffer#delete view#buffer#start_iter view#buffer#end_iter; connection := Some (ic, oc, read ic view); Lwt.return_unit end with | Unix.Unix_error (error, _, _) -> show_error "cannot establish the connection: %s" (Unix.error_message error); Lwt.return_unit | Not_found -> show_error "host %S not found" host; Lwt.return_unit ) (* 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); Lwt.return_unit ) | 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 = Lwt.wait () in (* Setup callbacks. *) ignore (window#connect#destroy (Lwt.wakeup wakener)); ignore (menu_quit#connect#activate (Lwt.wakeup wakener)); ignore (menu_connect#connect#activate (fun () -> connect view)); ignore (entry#connect#activate (fun () -> write view entry)); ignore (send#connect#clicked (fun () -> write view entry)); window#show (); (* Wait for the main window to be closed. *) waiter lwt-2.5.2/examples/unix/000077500000000000000000000000001270742521300151325ustar00rootroot00000000000000lwt-2.5.2/examples/unix/logging.ml000066400000000000000000000044511270742521300171160ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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_unit with exn -> Lwt_log.error ~section ~exn "h failed with" in let logger = Lwt_log.channel ~template:"$(name): $(section): $(loc-file): $(loc-line): $(loc-column): $(message)" ~close_mode:`Keep ~channel:Lwt_io.stderr () in Lwt_log.info ~section ~logger "this message will appear with a location" lwt-2.5.2/examples/unix/parallelize.ml000066400000000000000000000036071270742521300177760ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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.Infix (* 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 -> Lwt.return_unit | 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 -> Lwt.return_unit | n -> launch () <&> create_threads (n - 1) (* Counts the number of CPUs using "/proc/cpuinfo": *) let cpus_count () = Lwt_stream.fold (fun _ n -> succ n) (Lwt_stream.filter (fun line -> try Scanf.sscanf line "processor :" true with _ -> false) (Lwt_io.lines_of_file "/proc/cpuinfo")) 0 lwt () = cpus_count () >>= create_threads lwt-2.5.2/examples/unix/relay.ml000066400000000000000000000124531270742521300166050ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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.Infix (* +-----------------------------------------------------------------+ | 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. *) Lwt.return_unit 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. *) Lwt.return_unit 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. *) Lwt.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; Lwt.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 () = Lwt.pick [relay fd1 fd2; relay fd2 fd1] in ignore (Lwt_log.notice "done relayling"); Lwt.return_unit with exn -> ignore (Lwt_log.error ~exn "something went wrong"); exit 1 lwt-2.5.2/lwt-api.odocl000066400000000000000000000012671270742521300147360ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: ec7c575c209ddf74bc7299feef9302b1) 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_pqueue src/glib/Lwt_glib src/preemptive/Lwt_preemptive src/react/Lwt_react src/ssl/Lwt_ssl src/logger/Lwt_log_core src/logger/Lwt_log_rules 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 ppx/Ppx_lwt # OASIS_STOP lwt-2.5.2/manual/000077500000000000000000000000001270742521300136065ustar00rootroot00000000000000lwt-2.5.2/manual/Makefile000066400000000000000000000007471270742521300152560ustar00rootroot00000000000000# Makefile # -------- # Copyright : (c) 2010, Jérémie Dimino # Licence : BSD3 # # This file is a part of lwt. all: manual.pdf manual-wiki.tex: manual.wiki latex_of_wiki lwt-manual < manual.wiki > manual-wiki.tex.tmp mv manual-wiki.tex.tmp manual-wiki.tex manual.pdf: manual.tex manual-wiki.tex rubber --pdf manual.tex clean-aux: rm -f .latex_of_wiki_offsets *.log *.aux *.out *.toc clean: clean-aux rm -f manual.pdf manual-wiki.tex manual-wiki.tex.tmp lwt-2.5.2/manual/manual.tex000066400000000000000000000023541270742521300156110ustar00rootroot00000000000000\documentclass{article} \usepackage{fullpage} \usepackage[utf8]{inputenc} \usepackage{url} \usepackage{hyperref} \usepackage{listings} \usepackage{xcolor} \hypersetup{% a4paper=true, pdfstartview=FitH, colorlinks=false, pdfborder=0 0 0, pdftitle = {Lwt user manual}, pdfauthor = {Jérémie Dimino}, pdfkeywords = {OCaml, Lwt, Cooperative threads, Coroutines} } \lstset{ language=[Objective]Caml, extendedchars, showspaces=false, showstringspaces=false, showtabs=false, basicstyle=\ttfamily, frame=l, framerule=1.5mm, xleftmargin=6mm, framesep=4mm, rulecolor=\color{lightgray}, emph={lwt,for\_lwt,try\_lwt,raise\_lwt}, emphstyle=\color[rgb]{0.627451, 0.125490, 0.941176}, moredelim=*[s][\itshape]{(*}{*)}, moredelim=[is][\textcolor{darkgray}]{§}{§}, escapechar=°, keywordstyle=\color[rgb]{0.627451, 0.125490, 0.941176}, stringstyle=\color[rgb]{0.545098, 0.278431, 0.364706}, commentstyle=\color[rgb]{0.698039, 0.133333, 0.133333}, numberstyle=\color[rgb]{0.372549, 0.619608, 0.627451} } \title{Lwt user manual} \author{Jérémie Dimino} \begin{document} \maketitle \tableofcontents % Remove the \chapter introduced by latex_of_wiki \newcommand{\chapter}[1]{} \include{manual-wiki} \end{document} lwt-2.5.2/manual/manual.wiki000066400000000000000000001133161270742521300157550ustar00rootroot00000000000000<>.>> = Lwt manual = == Introduction == When writing a program, a common developer's task is to handle IO operations. Indeed most software interact with several different resources, such as: * the kernel, by doing system calls * the user, by reading the keyboard, the mouse, or any input device * a graphical server, to build graphical user interface * other computers, by using the network * ... When this list contains only one item, it is pretty easy to handle. However as this list grows it becomes harder and harder to make everything works together. Several choices have been proposed to solve this problem: * using a main loop, and integrate all components we are interacting with into this main loop. * using preemptive system threads Both solutions have their advantages and their drawbacks. For the first one, it may work, but it becomes very complicated to write a piece of asynchronous sequential code. The typical example is graphical user interfaces freezing and not redrawing themselves because they are waiting for some blocking part of the code to complete. If you already wrote code using preemptive threads, you should know that doing it right with threads is a hard job. Moreover system threads consume non negligible resources, and so you can only launch a limited number of threads at the same time. Thus this is not a real solution. {{{Lwt}}} offers a new alternative. It provides very light-weight cooperative threads; ``launching'' a thread is a very fast operation, it does not require a new stack, a new process, or anything else. Moreover context switches are very fast. In fact, it is so easy that we will launch a thread for every system call. And composing cooperative threads will allow us to write highly asynchronous programs. In a first part, we will explain the concepts of {{{Lwt}}}, then we will describe the many sub-libraries of {{{Lwt}}}. == The Lwt core library == In this section we describe the basics of {{{Lwt}}}. It is advised to start an ocaml toplevel and try the given code examples. To start, launch {{{ocaml}}} in a terminal or in emacs with the tuareg mode, and type: {{{ # #use "topfind";; # #require "lwt.simple-top";; }}} {{{lwt.simple-top}}} makes sure {{{Lwt}}} threads can run while using the toplevel. You do not need it if you are using {{{utop}}}. === Lwt concepts === Let's take a classical function of the {{{Pervasives}}} module: < char = >> This function will wait for a character to come on the given input channel, and then return it. The problem with this function is that it is blocking: while it is being executed, the whole program will be blocked, and other events will not be handled until it returns. Now let's look at the lwt equivalent: < char Lwt.t = >> As you can see, it does not return a character but something of type {{{char Lwt.t}}}. The type {{{'a Lwt.t}}} is the type of threads returning a value of type {{{'a}}}. Actually the {{{Lwt_io.read_char}}} will try to read a character from the given input channel and //immediately// returns a light-weight thread. Now, let's see what we can do with a {{{Lwt}}} thread. The following code creates a pipe, and launches a thread reading on the input side: < val oc : Lwt_io.output_channel = # let t = Lwt_io.read_char ic;; val t : char Lwt.t = >> We can now look at the state of our newly created thread: <> A thread may be in one of the following states: * {{{Return x}}}, which means that the thread has terminated successfully and returned the value {{{x}}} * {{{Fail exn}}}, which means that the thread has terminated, but instead of returning a value, it failed with the exception {{{exn}}} * {{{Sleep}}}, which means that the thread is currently sleeping and has not yet returned a value or an exception The thread {{{t}}} is sleeping because there is currently nothing to read from the pipe. Let's write something: < # Lwt.state t;; - : char Lwt.state = Lwt.Return 'a' >> So, after we write something, the reading thread has been awoken and has returned the value {{{'a'}}}. === Primitives for thread creation === There are several primitives for creating {{{Lwt}}} threads. These functions are located in the module {{{Lwt}}}. Here are the main primitives: * {{{Lwt.return : 'a -> 'a Lwt.t}}} \\ creates a thread which has already terminated and returned a value * {{{Lwt.fail : exn -> 'a Lwt.t}}} \\ creates a thread which has already terminated and failed with an exception * {{{Lwt.wait : unit -> 'a Lwt.t * 'a Lwt.u}}} \\ creates a sleeping thread and returns this thread plus a wakener (of type {{{'a Lwt.u}}}) which must be used to wakeup the sleeping thread. To wake up a sleeping thread, you must use one of the following functions: * {{{Lwt.wakeup : 'a Lwt.u -> 'a -> unit}}} \\ wakes up the thread with a value. * {{{Lwt.wakeup_exn : 'a Lwt.u -> exn -> unit}}} \\ wakes up the thread with an exception. Note that it is an error to wakeup the same thread twice. {{{Lwt}}} will raise {{{Invalid_argument}}} if you try to do so. With this information, try to guess the result of each of the following expression: <> ==== Primitives for thread composition ==== The most important operation you need to know is {{{bind}}}: < ('a -> 'b Lwt.t) -> 'b Lwt.t >> {{{bind t f}}} creates a thread which waits for {{{t}}} to terminate, then passes the result to {{{f}}}. If {{{t}}} is a sleeping thread, then {{{bind t f}}} will be a sleeping thread too, until {{{t}}} terminates. If {{{t}}} fails, then the resulting thread will fail with the same exception. For example, consider the following expression: < Lwt_io.printlf "You typed %S" str) >> This code will first wait for the user to enter a line of text, then print a message on the standard output. Similarly to {{{bind}}}, there is a function to handle the case when {{{t}}} fails: < 'a Lwt.t) -> (exn -> 'a Lwt.t) -> 'a Lwt.t >> {{{catch f g}}} will call {{{f ()}}}, then waits for its termination, and if it fails with an exception {{{exn}}}, calls {{{g exn}}} to handle it. Note that both exceptions raised with {{{Pervasives.raise}}} and {{{Lwt.fail}}} are caught by {{{catch}}}. ==== Cancelable threads ==== In some case, we may want to cancel a thread. For example, because it has not terminated after a timeout. This can be done with cancelable threads. To create a cancelable thread, you must use the {{{Lwt.task}}} function: < 'a Lwt.t * 'a Lwt.u >> It has the same semantics as {{{Lwt.wait}}} except that the sleeping thread can be canceled with {{{Lwt.cancel}}}: < unit >> The thread will then fail with the exception {{{Lwt.Canceled}}}. To execute a function when the thread is canceled, you must use {{{Lwt.on_cancel}}}: < (unit -> unit) -> unit >> Note that it is also possible to cancel a thread which has not been created with {{{Lwt.task}}}. In this case, the deepest cancelable thread connected with the given thread will be cancelled. For example, consider the following code: < val wakener : '_a Lwt.u = # let t = Lwt.bind waiter (fun x -> Lwt.return (x + 1));; val t : int Lwt.t = >> Here, cancelling {{{t}}} will in fact cancel {{{waiter}}}. {{{t}}} will then fail with the exception {{{Lwt.Canceled}}}: <> By the way, it is possible to prevent a thread from being canceled by using the function {{{Lwt.protected}}}: < 'a Lwt.t >> Canceling {{{(proctected t)}}} will have no effect on {{{t}}}. ==== Primitives for multi-thread composition ==== We now show how to compose several concurrent threads. The main functions for this are in the {{{Lwt}}} module: {{{join}}}, {{{choose}}} and {{{pick}}}. The first one, {{{join}}} takes a list of threads and waits for all of them to terminate: < unit Lwt.t >> Moreover, if at least one thread fails, {{{join l}}} will fail with the same exception as the first to fail, after all threads terminate. Similarly {{{choose}}} waits for at least one thread to terminate, then returns the same value or exception: < 'a Lwt.t >> For example: < val wakener1 : '_a Lwt.u = # let waiter2, wakener2 = Lwt.wait ();; val waiter2 : '_a Lwt.t = val wakener : '_a Lwt.u = # let t = Lwt.choose [waiter1; waiter2];; val t : '_a Lwt.t = # Lwt.state t;; - : '_a Lwt.state = Lwt.Sleep # Lwt.wakeup wakener2 42;; - : unit = () # Lwt.state t;; - : int Lwt.state = Lwt.Return 42 >> The last one, {{{pick}}}, is the same as {{{choose}}} except that it cancels all other threads when one terminates. ==== Threads local storage ==== Lwt can store variables with different values on different threads. This is called threads local storage. For example, this can be used to store contexts or thread identifiers. The contents of a variable can be read with: < 'a option >> which takes a key to identify the variable we want to read and returns either {{{None}}} if the variable is not set, or {{{Some x}}} if it is. The value returned is the value of the variable in the current thread. New keys can be created with: < 'a Lwt.key >> To set a variable, you must use: < 'a option -> (unit -> 'b) -> 'b >> {{{with_value key value f}}} will execute {{{f}}} with the binding {{{key -> value}}}. The old value associated to {{{key}}} is restored after {{{f}}} terminates. For example, you can use local storage to store thread identifiers and use them in logs: < id | None -> "main" in Lwt_io.printlf "%s: %s" thread_id msg lwt () = Lwt.join [ Lwt.with_value id_key (Some "thread 1") (fun () -> log "foo"); Lwt.with_value id_key (Some "thread 2") (fun () -> log "bar"); ] >> ==== Rules ==== {{{Lwt}}} will always try to execute as much as possible before yielding and switching to another cooperative thread. In order to make it work well, you must follow the following rules: * do not write functions that may take 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 two syntax extensions which increases code readability and makes coding using {{{Lwt}}} easier. ==== Ppx ==== The Ppx syntax extension is documented <>. This syntax extension is more recent and is recommended. ==== Camlp4 ==== To use it add the {{{lwt.syntax}}} package when compiling: <> Or in the toplevel (after loading topfind): <> The following constructions are added to the language: * {{{lwt}}} //pattern,,1,,// {{{=}}} //expr,,1,,// [ {{{and}}} //pattern,,2,,// {{{=}}} //expr,,2,,// ... ] {{{in}}} //expr// \\ which is a parallel let-binding construction. For example in the following code: <> the thread {{{f ()}}} and {{{g ()}}} are launched concurrently and their results are then bound to {{{x}}} and {{{y}}} in the expression //expr//. Of course you can also launch the two threads sequentially by writing your code like that: <> * {{{try_lwt}}} //expr// [ {{{with}}} //pattern,,1,,// {{{->}}} //expr,,1,,// ... ] [ {{{finally}}} //expr'// ] \\ which is the equivalent of the standard {{{try-with}}} construction but for {{{Lwt}}}. Both exceptions raised by {{{Pervasives.raise}}} and {{{Lwt.fail}}} are caught. * {{{for_lwt}}} //ident// {{{=}}} //expr,,init,,// ( {{{to}}} {{{|}}} {{{downto}}} ) //expr,,final,,// {{{do}}} //expr// {{{done}}} \\ which is the equivalent of the standard {{{for}}} construction but for {{{Lwt}}}. * {{{raise_lwt}}} //exn// \\ which is the same as {{{Lwt.fail}}} //exn// but with backtrace support. ==== Correspondence table ==== You might appreciate the following table to write code using lwt: |= without {{{Lwt}}} |= with {{{Lwt}}} | | | | | {{{let}}} //pattern,,1,,// {{{=}}} //expr,,1,,// | {{{lwt}}} //pattern,,1,,// {{{=}}} //expr,,1,,// | | {{{and}}} //pattern,,2,,// {{{=}}} //expr,,2,,// | {{{and}}} //pattern,,2,,// {{{=}}} //expr,,2,,// | | ... | ... | | {{{and}}} //pattern,,n,,// {{{=}}} //expr,,n,,// {{{in}}} | {{{and}}} //pattern,,n,,// {{{=}}} //expr,,n,,// {{{in}}} | | //expr// | //expr// | | | | | {{{try}}} | {{{try_lwt}}} | | // expr// | // expr// | | {{{with}}} | {{{with}}} | | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | | // // ... | // // ... | | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | | | | | {{{for}}} //ident// {{{=}}} //expr,,init,,// {{{to}}} //expr,,final,,// {{{do}}} | {{{for_lwt}}} //ident// {{{=}}} //expr,,init,,// {{{to}}} //expr,,final,,// {{{do}}} | | // expr// | // expr// | | {{{done}}} | {{{done}}} | | | | | {{{raise}}} //exn// | {{{raise_lwt}}} //exn// | | | | | {{{assert}}} //expr// | {{{assert_lwt}}} //expr// | | | | | {{{match}}} //expr// {{{with}}} | {{{match_lwt}}} //expr// {{{with}}} | | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | // // {{{|}}} //pattern,,1,,// {{{->}}} //expr,,1,,// | | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | // // {{{|}}} //pattern,,2,,// {{{->}}} //expr,,2,,// | | // // ... | // // ... | | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | // // {{{|}}} //pattern,,n,,// {{{->}}} //expr,,n,,// | | | | | {{{while}}} //expr// {{{do}}} | {{{while_lwt}}} //expr// {{{do}}} | | // expr// | // expr// | | {{{done}}} | {{{done}}} | === Backtrace support === If an exception is raised inside an Lwt thread, the backtrace provided by OCaml will not be very useful. It will end inside the Lwt scheduler instead of continuing into the code that started the thread. To avoid this, and get good backtraces from Lwt, use one of the syntax extensions in debug mode. In debug mode, the {{{lwt}}} and {{{let%lwt}}} constructs will properly propagate backtraces. In the <>, the debug mode is enabled by default. This has a small performance impact, so you can disable it by passing {{{-no-debug}}}. In the {{{camlp4 syntax extension}}}, you need to pass the {{{-lwt-debug}}} switch: {{{ $ ocamlfind ocamlc -syntax camlp4o -package lwt.syntax \ -ppopt -lwt-debug -linkpkg -o foo foo.ml }}} As always, to get backtraces from an OCaml program, you need to either declare the environment variable {{{OCAMLRUNPARAM=b}}} or call {{{Printexc.record_backtrace true}}} at the start of your program. === Other modules of the core library === The core library contains several modules that only depend on {{{Lwt}}}. The following naming convention is used in {{{Lwt}}}: when a function takes as argument a function returning a thread that is going to be executed sequentially, it is suffixed with ``{{{_s}}}''. And when it is going to be executed concurrently, it is suffixed with ``{{{_p}}}''. For example, in the {{{Lwt_list}}} module we have: < 'b Lwt.t) -> 'a list -> 'b list Lwt.t val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t >> ==== Mutexes ==== {{{Lwt_mutex}}} provides mutexes for {{{Lwt}}}. Its use is almost the same as the {{{Mutex}}} module of the thread library shipped with OCaml. In general, programs using {{{Lwt}}} do not need a lot of mutexes. They are only useful for serialising operations. ==== Lists ==== The {{{Lwt_list}}} module defines iteration and scanning functions over lists, similar to the ones of the {{{List}}} module, but using functions that return a thread. For example: < unit Lwt.t) -> 'a list -> unit Lwt.t val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t >> In {{{iter_s f l}}}, {{{iter_s}}} will call f on each elements of {{{l}}}, waiting for completion between each element. On the contrary, in {{{iter_p f l}}}, {{{iter_p}}} will call f on all elements of {{{l}}}, then wait for all the threads to terminate. ==== Data streams ==== {{{Lwt}}} streams are used in a lot of places in {{{Lwt}}} and its sub libraries. They offer a high-level interface to manipulate data flows. A stream is an object which returns elements sequentially and lazily. Lazily means that the source of the stream is touched only for new elements when needed. This module contains a lot of stream transformation, iteration, and scanning functions. The common way of creating a stream is by using {{{Lwt_stream.from}}} or by using {{{Lwt_stream.create}}}: < 'a option Lwt.t) -> 'a Lwt_stream.t val create : unit -> 'a Lwt_stream.t * ('a option -> unit) >> As for streams of the standard library, {{{from}}} takes as argument a function which is used to create new elements. {{{create}}} returns a function used to push new elements into the stream and the stream which will receive them. For example: < val push : '_a option -> unit = # push (Some 1);; - : unit = () # push (Some 2);; - : unit = () # push (Some 3);; - : unit = () # Lwt.state (Lwt_stream.next stream);; - : int Lwt.state = Lwt.Return 1 # Lwt.state (Lwt_stream.next stream);; - : int Lwt.state = Lwt.Return 2 # Lwt.state (Lwt_stream.next stream);; - : int Lwt.state = Lwt.Return 3 # Lwt.state (Lwt_stream.next stream);; - : int Lwt.state = Lwt.Sleep >> Note that streams are consumable. Once you take an element from a stream, it is removed from it. So, if you want to iterate two times over a stream, you may consider ``cloning'' it, with {{{Lwt_stream.clone}}}. Cloned stream will return the same elements in the same order. Consuming one will not consume the other. For example: < # let s' = Lwt_stream.clone s;; val s' : int Lwt_stream.t = # Lwt.state (Lwt_stream.next s);; - : int Lwt.state = Lwt.Return 1 # Lwt.state (Lwt_stream.next s);; - : int Lwt.state = Lwt.Return 2 # Lwt.state (Lwt_stream.next s');; - : int Lwt.state = Lwt.Return 1 # Lwt.state (Lwt_stream.next s');; - : int Lwt.state = Lwt.Return 2 >> ==== Mailbox variables ==== The {{{Lwt_mvar}}} module provides mailbox variables. A mailbox variable, also called a ``mvar'', is a cell which may contain 0 or 1 element. If it contains no elements, we say that the mvar is empty, if it contains one, we say that it is full. Adding an element to a full mvar will block until one is taken. Taking an element from an empty mvar will block until one is added. Mailbox variables are commonly used to pass messages between threads. Note that a mailbox variable can be seen as a pushable stream with a limited memory. == Running a Lwt program == Threads you create with {{{Lwt}}} always have the type {{{Lwt.t}}}. If you want to write a program and run it this is not enough. Indeed you don't know when a {{{Lwt}}} thread is terminated. For example if your program is just: <> you have no guarantee that the thread writing {{{"Hello, world!"}}} on the terminal will be terminated when the program exit. In order to wait for a thread to terminate, you have to call the function {{{Lwt_main.run}}}: < 'a >> This functions wait for the given thread to terminate and returns its result. In fact it does more than that; it also runs the scheduler which is responsible for making threads progress when events are received from the outside world. So basically, when you write a {{{Lwt}}} program you must call the toplevel the function {{{Lwt_main.run}}}. For instance: <> Note that you must call {{{Lwt_main.run}}} only once at a time. It cannot be used anywhere to get the result of a thread. It must only be used in the entry point of your program. == The {{{lwt.unix}}} library == The package {{{lwt.unix}}} contains all {{{unix}}} dependent modules of {{{Lwt}}}. Among all its features, it implements cooperative versions of functions of the standard library and the unix library. === Unix primitives === The {{{Lwt_unix}}} provides cooperative system calls. For example, the {{{Lwt}}} counterpart of {{{Unix.read}}} is: < string -> int -> int -> int Lwt.t >> {{{Lwt_io}}} provides features similar to buffered channels of the standard library (of type {{{in_channel}}} or {{{out_channel}}}) but cooperatively. {{{Lwt_gc}}} allows you to register a finaliser that returns a thread. At the end of the program, {{{Lwt}}} will wait for all the finaliser to terminate. === The Lwt scheduler === Threads doing IO may be put to sleep 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 immediately available on it. {{{Lwt}}} contains a scheduler 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 implementations. {{{Lwt}}} supports 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 work 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}}} needs 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 runs the scheduler until the thread passed as argument terminates. === The logging facility === The package {{{lwt.unix}}} contains a module {{{Lwt_log}}} providing loggers. It supports logging to a file, a channel, or to the syslog daemon. You can also define your own logger by providing the appropriate functions (function {{{Lwt_log.make}}}). Several loggers can be merged into one. Sending logs on the merged logger will send these logs to all its components. For example to redirect all logs to {{{stderr}}} and to the syslog daemon: <> {{{Lwt}}} also provides a syntax extension, in the package {{{lwt.syntax.log}}}. It does not modify the language but it replaces log statements of the form: <> by: <> The advantages of using the syntax extension are the following: * it checks the log level before calling the logging function, so the arguments are not computed if not needed * debugging logs can be removed at parsing time By default, the syntax extension removes all logs with the level {{{debug}}}. To keep them, pass the command line option {{{-lwt-debug}}} to camlp4. == The Lwt.react library == The {{{Lwt_react}}} module provides helpers for using the {{{react}}} library with {{{Lwt}}}. It extends the {{{React}}} module by adding {{{Lwt}}} specific functions. It can be used as a replacement of {{{React}}}. For example you can add at the beginning of your program: <> instead of: <> or: <> Among the added functionalities we have {{{Lwt_react.E.next}}}, which takes an event and returns a thread which will wait until the next occurence of this event. For example: < val push : '_a -> unit = # let t = E.next event;; val t : '_a Lwt.t = # Lwt.state t;; - : '_a Lwt.state = Lwt.Sleep # push 42;; - : unit = () # Lwt.state t;; - : int Lwt.state = Lwt.Return 42 >> Another interesting feature is the ability to limit events (resp. signals) from occurring (resp. changing) too often. For example, suppose you are doing a program which displays something on the screeen each time a signal changes. If at some point the signal changes 1000 times per second, you probably don't want 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 separated by a call to {{{f}}}. For example if {{{f}}} returns a thread which sleeps 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' >> == 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}}} allows you to //detach// the computation to a preemptive thread. This is done by the module {{{Lwt_preemptive}}} of the {{{lwt.preemptive}}} package which maintains a pool of system threads. The main function is: < 'b) -> 'a -> 'b Lwt.t >> {{{detach f x}}} will execute {{{f x}}} in another thread and asynchronously wait for the result. If you have to run {{{Lwt}}} code in another thread, you must use the function {{{Lwt_preemptive.run_in_main}}}: < 'a Lwt.t) -> 'a >> It works as follow: * it sends the function to the main thread and wait * the main thread execute the function * when it terminates the main thread sends back the result * the result is returned Note that you cannot call {{{Lwt_main.run}}} in another system thread, so you must use this function. === SSL support === The package {{{lwt.ssl}}} provides the module {{{Lwt_ssl}}} which allows use of SSL asynchronously. === Glib integration === The {{{lwt.glib}}} embeds the {{{glib}}} main loop into the {{{Lwt}}} one. This allows you to write GTK applications using {{{Lwt}}}. The one thing you have to do is to call {{{Lwt_glib.install}}} at the beginning of your program. == Writing stubs using {{{Lwt}}} == === Thread-safe notifications === If you want to notify the main thread from another thread, you can use the {{{Lwt}}} thread safe notification system. First you need to create a notification identifier (which is just an integer) from the OCaml side using the {{{Lwt_unix.make_notification}}} function, then you can send it from either the OCaml code with {{{Lwt_unix.send_notification}}} function, or from the C code using the function {{{lwt_unix_send_notification}}} (defined in {{{lwt_unix_.h}}}). Notifications are received and processed asynchronously by the main thread. === Jobs === For operations that cannot be executed asynchronously, {{{Lwt}}} uses a system of jobs that can be executed in a different threads. A job is composed of three functions: * A stub function to create the job. It must allocate a new job structure and fill its [worker] and [result] fields. This function is executed in the main thread. The return type for the OCaml external must be of the form {{{'a job}}}. * A function which executes the job. This one may be executed asynchronously in another thread. This function must not: ** access or allocate OCaml block values (tuples, strings, ...), ** call OCaml code. * A function which reads the result of the job, frees resources and returns the result as an OCaml value. This function is executed in the main thread. With {{{Lwt < 2.3.3}}}, 4 functions (including 3 stubs) were required. It is still possible to use this mode but it is deprecated. We show as example the implementation of {{{Lwt_unix.mkdir}}}. On the C side we have: <result = mkdir(job->path, job->mode); /* Save the value of errno. */ job->errno_copy = errno; } /* The function building the caml result. */ static value result_mkdir(struct job_mkdir* job) { /* Check for errors. */ if (job->result < 0) { /* Save the value of errno so we can use it once the job has been freed. */ int error = job->errno_copy; /* Copy the contents of job->path into a caml string. */ value string_argument = caml_copy_string(job->path); /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Raise the error. */ unix_error(error, "mkdir", string_argument); } /* Free the job structure. */ lwt_unix_free_job(&job->job); /* Return the result. */ return Val_unit; } /* The stub creating the job structure. */ CAMLprim value lwt_unix_mkdir_job(value path, value mode) { /* Get the length of the path parameter. */ mlsize_t len_path = caml_string_length(path) + 1; /* Allocate a new job. */ struct job_mkdir* job = (struct job_mkdir*)lwt_unix_new_plus(struct job_mkdir, len_path); /* Set the offset of the path parameter inside the job structure. */ job->path = job->data; /* Copy the path parameter inside the job structure. */ memcpy(job->path, String_val(path), len_path); /* Initialize function fields. */ job->job.worker = (lwt_unix_job_worker)worker_mkdir; job->job.result = (lwt_unix_job_result)result_mkdir; /* Copy the mode parameter. */ job->mode = Int_val(mode); /* Wrap the structure into a caml value. */ return lwt_unix_alloc_job(&job->job); } >> and on the ocaml side: < int -> unit job = "lwt_unix_mkdir_job" (* The ocaml function. *) let mkdir name perms = Lwt_unix.run_job (mkdir_job name perms) >> lwt-2.5.2/manual/menu.wiki000066400000000000000000000000331270742521300154330ustar00rootroot00000000000000= Lwt ==[[manual|Overview]]lwt-2.5.2/myocamlbuild.ml000066400000000000000000000635161270742521300153570ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Myocamlbuild * Copyright (C) 2010 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (* OASIS_START *) (* DO NOT EDIT (digest: 23325e1ff6f105e9e3ed2ec405436035) *) module OASISGettext = struct (* # 22 "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 (* # 22 "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 # 132 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "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 rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 237 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "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 type conf = { no_automatic_syntax: bool; } (* 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 exec_from_conf exec = let exec = let env_filename = Pathname.basename BaseEnvLight.default_filename in let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in try BaseEnvLight.var_get exec env with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" exec; exec in let fix_win32 str = if Sys.os_type = "Win32" then begin let buff = Buffer.create (String.length str) in (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. *) String.iter (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) str; Buffer.contents buff end else begin str end in fix_win32 exec let split s ch = let buf = Buffer.create 13 in let x = ref [] in let flush () = x := (Buffer.contents buf) :: !x; Buffer.clear buf in String.iter (fun c -> if c = ch then flush () else Buffer.add_char buf c) s; flush (); List.rev !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* ocamlfind command *) let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] (* This lists all supported packages. *) let find_packages () = List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] let well_known_syntax = [ "camlp4.quotations.o"; "camlp4.quotations.r"; "camlp4.exceptiontracer"; "camlp4.extend"; "camlp4.foldgenerator"; "camlp4.listcomprehension"; "camlp4.locationstripper"; "camlp4.macro"; "camlp4.mapgenerator"; "camlp4.metagenerator"; "camlp4.profiler"; "camlp4.tracer" ] let dispatch conf = function | After_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"; Options.ocamlmklib := ocamlfind & A"ocamlmklib" | After_rules -> (* When one link an OCaml library/binary/package, one should use * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; if not (conf.no_automatic_syntax) then begin (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> let base_args = [A"-package"; A pkg] in (* TODO: consider how to really choose camlp4o or camlp4r. *) let syn_args = [A"-syntax"; A "camlp4o"] in let (args, pargs) = (* Heuristic to identify syntax extensions: whether they end in ".syntax"; some might not. *) if Filename.check_suffix pkg "syntax" || List.mem pkg well_known_syntax then (syn_args @ base_args, syn_args) else (base_args, []) in flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; (* TODO: Check if this is allowed for OCaml < 3.12.1 *) flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; end (find_packages ()); end; (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); | _ -> () end module MyOCamlbuildBase = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall *) open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler type dir = string type file = string type name = string type tag = string (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { lib_ocaml: (name * dir list * string list) list; lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) includes: (dir * dir list) list; } let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = fun e -> List.iter (fun dispatch -> dispatch e) lst let tag_libstubs nm = "use_lib"^nm^"_stubs" let nm_libstubs nm = nm^"_stubs" let dispatch t e = let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then String.sub s 1 ((String.length s) - 1) else s in List.iter (fun (opt, var) -> try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] | After_rules -> (* Declare OCaml libraries *) List.iter (function | nm, [], intf_modules -> ocaml_lib nm; let cmis = List.map (fun m -> (String.uncapitalize m) ^ ".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis | nm, dir :: tl, intf_modules -> ocaml_lib ~dir:dir (dir^"/"^nm); List.iter (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) tl; let cmis = List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] cmis) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; (* Declare C libraries *) List.iter (fun (lib, dir, headers) -> (* Handle C part of library *) flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. This holds both for programs and for libraries. *) dep ["link"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) dep ["compile"; "c"] headers; (* Setup search path for lib *) flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; (* Add flags *) List.iter (fun (tags, cond_specs) -> let spec = BaseEnvLight.var_choose cond_specs env in let rec eval_specs = function | S lst -> S (List.map eval_specs lst) | A str -> A (BaseEnvLight.var_expand str env) | spec -> spec in flag tags & (eval_specs spec)) t.flags | _ -> () let dispatch_default conf t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch conf; ] end # 606 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [ ("lwt", ["src/core"], []); ("lwt-log", ["src/logger"], []); ("lwt-unix", ["src/unix"], []); ("lwt-simple-top", ["src/simple_top"], []); ("lwt-react", ["src/react"], []); ("lwt-preemptive", ["src/preemptive"], []); ("lwt-glib", ["src/glib"], []); ("lwt-ssl", ["src/ssl"], []); ("lwt-syntax", ["syntax"], []); ("lwt-syntax-options", ["syntax"], []); ("lwt-syntax-log", ["syntax"], []); ("ppx", ["ppx"], []); ("test", ["tests"], []) ]; lib_c = [ ("lwt-unix", "src/unix", ["src/unix/lwt_config.h"; "src/unix/lwt_unix.h"]); ("lwt-glib", "src/glib", []) ]; flags = [ (["oasis_library_lwt_unix_cclib"; "link"], [ (OASISExpr.EBool true, S []); (OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32")), S [A "-cclib"; A "-lws2_32"]); (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), S [A "-cclib"; A "ws2_32.lib"]); (OASISExpr.EAnd (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32"))), S [A "-cclib"; A "ws2_32.lib"; A "-cclib"; A "-lws2_32"]) ]); (["oasis_library_lwt_unix_cclib"; "ocamlmklib"; "c"], [ (OASISExpr.EBool true, S []); (OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32")), S [A "-lws2_32"]); (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), S [A "ws2_32.lib"]); (OASISExpr.EAnd (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32"))), S [A "ws2_32.lib"; A "-lws2_32"]) ]) ]; includes = [ ("tests/unix", ["src/core"; "src/unix"; "tests"]); ("tests/react", ["src/core"; "src/react"; "src/unix"; "tests"]); ("tests/preemptive", ["src/core"; "src/preemptive"; "src/unix"; "tests"]); ("tests/ppx", ["src/core"; "src/unix"; "tests"]); ("tests/core", ["src/core"; "src/unix"; "tests"]); ("tests", ["src/core"; "src/unix"]); ("src/unix", ["src/core"; "src/logger"]); ("src/ssl", ["src/unix"]); ("src/simple_top", ["src/core"; "src/unix"]); ("src/react", ["src/core"]); ("src/preemptive", ["src/core"; "src/unix"]); ("src/logger", ["src/core"]); ("src/glib", ["src/core"; "src/unix"]); ("examples/unix", ["src/unix"; "syntax"]) ] } ;; let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; # 714 "myocamlbuild.ml" (* OASIS_STOP *) open Ocamlbuild_plugin let split str = let rec skip_spaces i = if i = String.length str then [] else if str.[i] = ' ' then skip_spaces (i + 1) else extract i (i + 1) and extract i j = if j = String.length str then [String.sub str i (j - i)] else if str.[j] = ' ' then String.sub str i (j - i) :: skip_spaces (j + 1) else extract i (j + 1) in skip_spaces 0 let define_c_library name env = if BaseEnvLight.var_get name env = "true" then begin let tag = Printf.sprintf "use_C_%s" name in let opt = List.map (fun x -> A x) (split (BaseEnvLight.var_get (name ^ "_opt") env)) and lib = List.map (fun x -> A x) (split (BaseEnvLight.var_get (name ^ "_lib") env)) in (* Add flags for linking with the C library: *) flag ["ocamlmklib"; "c"; tag] & S lib; (* C stubs using the C library must be compiled with the library specifics flags: *) flag ["c"; "compile"; tag] & S (List.map (fun arg -> S[A"-ccopt"; arg]) opt); (* OCaml libraries must depends on the C library: *) flag ["link"; "ocaml"; tag] & S (List.map (fun arg -> S[A"-cclib"; arg]) lib) end let () = dispatch (fun hook -> dispatch_default hook; match hook with | Before_options -> Options.make_links := false | After_rules -> let env = BaseEnvLight.load ~allow_empty:true ~filename:MyOCamlbuildBase.env_filename () in (* Determine extension of CompiledObject: best *) let native_suffix = if BaseEnvLight.var_get "is_native" env = "true" then "native" else "byte" in (* 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"]; flag ["ocaml"; "compile"; "ppx_lwt"] & S [A "-ppx"; A ("ppx/ppx_lwt_ex." ^ native_suffix)]; (* Use an introduction page with categories *) tag_file "lwt-api.docdir/index.html" ["apiref"]; dep ["apiref"] ["apiref-intro"]; flag ["apiref"] & S[A "-intro"; P "apiref-intro"; A"-colorize-code"]; (* Stubs: *) dep ["file:src/unix/lwt_unix_stubs.c"] ["src/unix/lwt_unix_unix.c"; "src/unix/lwt_unix_windows.c"]; (* Check for "unix" because other variables are not present in the setup.data file if lwt.unix is disabled. *) if BaseEnvLight.var_get "unix" env = "true" then begin define_c_library "glib" env; define_c_library "libev" env; define_c_library "pthread" env; flag ["c"; "compile"; "use_lwt_headers"] & S [A"-ccopt"; A"-Isrc/unix"]; end | _ -> ()) (* Compile the wiki version of the Ocamldoc. Thanks to Till Varoquaux on usenet: http://www.digipedia.pl/usenet/thread/14273/231/ *) let ocamldoc_wiki tags deps docout docdir = let tags = tags -- "extension:html" in Ocamlbuild_pack.Ocaml_tools.ocamldoc_l_dir tags deps docout docdir let () = try let wikidoc_dir = let base = Ocamlbuild_pack.My_unix.run_and_read "ocamlfind query wikidoc" in String.sub base 0 (String.length base - 1) in Ocamlbuild_pack.Rule.rule "ocamldoc: document ocaml project odocl & *odoc -> wikidocdir" ~insert:`top ~prod:"%.wikidocdir/index.wiki" ~stamp:"%.wikidocdir/wiki.stamp" ~dep:"%.odocl" (Ocamlbuild_pack.Ocaml_tools.document_ocaml_project ~ocamldoc:ocamldoc_wiki "%.odocl" "%.wikidocdir/index.wiki" "%.wikidocdir"); tag_file "lwt-api.wikidocdir/index.wiki" ["apiref";"wikidoc"]; flag ["wikidoc"] & S[A"-i";A wikidoc_dir;A"-g";A"odoc_wiki.cma"] with Failure e -> () (* Silently fail if the package wikidoc isn't available *) lwt-2.5.2/ppx/000077500000000000000000000000001270742521300131405ustar00rootroot00000000000000lwt-2.5.2/ppx/.merlin000066400000000000000000000000511270742521300144230ustar00rootroot00000000000000PKG ppx_tools PKG ppx_tools.metaquot REClwt-2.5.2/ppx/ppx.mldylib000066400000000000000000000001341270742521300153230ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: d62cd5ddc27d99b3e4e5b16e801ef038) Ppx_lwt # OASIS_STOP lwt-2.5.2/ppx/ppx.mllib000066400000000000000000000001341270742521300147660ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: d62cd5ddc27d99b3e4e5b16e801ef038) Ppx_lwt # OASIS_STOP lwt-2.5.2/ppx/ppx_lwt.ml000066400000000000000000000001131270742521300151620ustar00rootroot00000000000000(* Dummy ML file to workaround https://github.com/ocsigen/lwt/issues/91 *) lwt-2.5.2/ppx/ppx_lwt.mli000066400000000000000000000110501270742521300153350ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Ppx_lwt * Copyright (C) 2014 Gabriel Radanne, Peter Zotov. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (** Ppx syntax extension for Lwt *) (** {2 Ppx extensions} This Ppx extension adds various syntactic shortcut for lwt programming. It needs OCaml >= 4.02 and {{:https://github.com/alainfrisch/ppx_tools}ppx_tools}. To use it, simply use the ocamlfind package [lwt.ppx]. This extension adds the following syntax: - lwt-binding: {[ let%lwt ch = get_char stdin in code ]} is the same as [bind (get_char stdin) (fun ch -> code)]. Moreover, it supports parallel binding: {[ let%lwt x = do_something1 () and y = do_something2 in code ]} will run [do_something1 ()] and [do_something2 ()], then bind their results 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 with ]} 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 added when needed. - finalizer: {[ () [%finally ] ]} You can use [[%lwt.finally ...]] instead of [[%finally ...]]. - assertion: {[ assert%lwt ]} - for loop: {[ for%lwt i = to do done ]} and: {[ for%lwt i = downto do done ]} - while loop: {[ while%lwt do done ]} - pattern matching: {[ match%lwt with | -> ... | -> ]} Exception cases are also supported: {[ match%lwt with | exception -> | -> ... | -> ]} - conditional: {[ if%lwt then else ]} and {[ if%lwt then ]} - exception raising: For all other expression, the construct {[ [%lwt ] ]} is expanded to: {[ Lwt.catch (fun () -> ) Lwt.fail ]} It allows to encode the old [raise_lwt ] as [[%lwt raise ]], and offers a convenient way to interact with non-Lwt code. {2 Debug} By default, the debug mode is enabled. This means that the [backtrace] versions of the [bind], [finalize] and [catch] functions are used, enabling proper backtraces for the Lwt exceptions. The debug mode can be disabled with the option [-no-debug]: {[ $ ocamlfind ocamlc -package lwt.ppx \ -ppxopt lwt.ppx,-no-debug -linkpkg -o foo foo.ml ]} {2 Sequence} It is also possible to sequence Lwt operations with the [>>] operator: {[ write stdio "Hello, " >> write stdio "world!" ]} By default, each operation must return [unit Lwt.t]. This constraint can be lifted with the option [-no-strict-sequence]. The operator can be disabled with the option [-no-sequence]. Note that unlike [>>=], [>>] is not an OCaml value. it is a piece of syntax added by the ppx rewriter - i.e., you cannot refer to [(>>)]. {2 Logging} The logging syntax extension is enabled with [-log]. It will replace expressions 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 () ]} Notes: - The application must be complete. For example: [Log.info "%d"] will make compilation fail. - Debug messages are removed if the option [-no-debug] is passed. *) lwt-2.5.2/ppx/ppx_lwt_ex.ml000066400000000000000000000323131270742521300156650ustar00rootroot00000000000000open Ast_mapper open Ast_helper open Asttypes open Parsetree open Ast_convenience (** {2 Convenient stuff} *) let with_loc f { txt ; loc } = (f txt) [@metaloc loc] let def_loc txt = { txt; loc = !default_loc } (** Test if a case is a catchall. *) let is_catchall case = let rec is_catchall_pat p = match p.ppat_desc with | Ppat_any | Ppat_var _ -> true | Ppat_alias (p, _) -> is_catchall_pat p | _ -> false in case.pc_guard = None && is_catchall_pat case.pc_lhs (** Add a wildcard case in there is none. Useful for exception handlers. *) let add_wildcard_case cases = let has_wildcard = List.exists is_catchall cases in if not has_wildcard then cases @ [Exp.case [%pat? exn] [%expr Lwt.fail exn]] else cases (** {3 Internal names} *) let lwt_prefix = "__ppx_lwt_" (** {2 Here we go!} *) let warn_let_lwt_rec loc attrs = let attr = attribute_of_warning loc "\"let%lwt rec\" is not a recursive Lwt binding" in attr :: attrs let debug = ref true let log = ref false let sequence = ref true let strict_seq = ref true (** let%lwt related functions *) let gen_name i = lwt_prefix ^ string_of_int i (** [p = x] ≡ [__ppx_lwt_$i = x] *) let gen_bindings l = let aux i binding = { binding with pvb_pat = (pvar @@ gen_name i) [@metaloc binding.pvb_expr.pexp_loc] } in List.mapi aux l (** [p = x] and e ≡ [Lwt.bind __ppx_lwt_$i (fun p -> e)] *) let gen_binds e_loc l e = let rec aux i bindings = match bindings with | [] -> e | binding :: t -> let name = (* __ppx_lwt_$i, at the position of $x$ *) (evar @@ gen_name i) [@metaloc binding.pvb_expr.pexp_loc] in let fun_ = [%expr (fun [%p binding.pvb_pat] -> [%e aux (i+1) t])] [@metaloc binding.pvb_loc] in let new_exp = if !debug then [%expr Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) [%e name] [%e fun_]] [@metaloc e_loc] else [%expr Lwt.bind [%e name] [%e fun_]] [@metaloc e_loc] in { new_exp with pexp_attributes = binding.pvb_attributes } in aux 0 l (** [p = x and p' = x' and ...] ≡ [p, p', ... = Lwt_main.run ( Lwt.bind x (fun __ppx_lwt_$i -> Lwt.bind x' (fun __ppx_lwt_$i' -> ... Lwt.return (__ppx_lwt_$i, __ppx_lwt_$i', ...))))] *) let gen_top_binds vbs = let gen_exp vbs i = match vbs with | { pvb_expr } :: rest -> if !debug then [%expr Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) [%e pvb_expr] (fun [%p pvar (gen_name i)] -> gen_exp rest (i + 1))] else [%expr Lwt.bind [%e pvb_expr] (fun [%p pvar (gen_name i)] -> gen_exp rest (i + 1))] | [] -> let rec names i = if i >= 0 then evar (gen_name i) :: names (i - 1) else [] in Exp.tuple (names i) in [Vb.mk (Pat.tuple (vbs |> List.map (fun { pvb_pat } -> pvb_pat))) [%expr Lwt_main.run [%e gen_exp vbs 0]]] (** For expressions only *) (* We only expand the first level after a %lwt. After that, we call the mapper to expand sub-expressions. *) let lwt_expression mapper exp attributes = default_loc := exp.pexp_loc; let pexp_attributes = attributes @ exp.pexp_attributes in match exp.pexp_desc with (** [let%lwt $p$ = $e$ in $e'$] ≡ [Lwt.bind $e$ (fun $p$ -> $e'$)] *) | Pexp_let (Nonrecursive, vbl , e) -> let new_exp = Exp.let_ Nonrecursive (gen_bindings vbl) (gen_binds exp.pexp_loc vbl e) in mapper.expr mapper { new_exp with pexp_attributes } (** [match%lwt $e$ with $c$] ≡ [Lwt.bind $e$ (function $c$)] [match%lwt $e$ with exception $x$ | $c$] ≡ [Lwt.try_bind (fun () -> $e$) (function $c$) (function $x$)] *) | Pexp_match (e, cases) -> let exns, cases = cases |> List.partition ( function | { pc_lhs = [%pat? exception [%p? _]]} -> true | _ -> false) in let exns = exns |> List.map ( function | { pc_lhs = [%pat? exception [%p? pat]]} as case -> { case with pc_lhs = pat } | _ -> assert false) in let exns = add_wildcard_case exns in let new_exp = match exns with | [] -> [%expr Lwt.bind [%e e] [%e Exp.function_ cases]] | _ -> [%expr Lwt.try_bind (fun () -> [%e e]) [%e Exp.function_ cases] [%e Exp.function_ exns]] in mapper.expr mapper { new_exp with pexp_attributes } (** [assert%lwt $e$] ≡ [try Lwt.return (assert $e$) with exn -> Lwt.fail exn] *) | Pexp_assert e -> let new_exp = [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.fail exn] in mapper.expr mapper { new_exp with pexp_attributes } (** [while%lwt $cond$ do $body$ done] ≡ [let rec __ppx_lwt_loop () = if $cond$ then Lwt.bind $body$ __ppx_lwt_loop else Lwt.return () in __ppx_lwt_loop] *) | Pexp_while (cond, body) -> let new_exp = [%expr let rec __ppx_lwt_loop () = if [%e cond] then Lwt.bind [%e body] __ppx_lwt_loop else Lwt.return () in __ppx_lwt_loop () ] in mapper.expr mapper { new_exp with pexp_attributes } (** [for%lwt $p$ = $start$ (to|downto) $end$ do $body$ done] ≡ [let __ppx_lwt_bound = $end$ in let rec __ppx_lwt_loop $p$ = if $p$ COMP __ppx_lwt_bound then Lwt.return () else Lwt.bind $body$ (fun () -> __ppx_lwt_loop ($p$ OP 1)) in __ppx_lwt_loop $start$] *) | Pexp_for (({ ppat_desc = Ppat_var p_var} as p), start, bound, dir, body) -> let comp, op = match dir with | Upto -> evar ">", evar "+" | Downto -> evar "<", evar "-" in let p' = with_loc evar p_var in let exp_bound = [%expr __ppx_lwt_bound] [@metaloc bound.pexp_loc] in let pat_bound = [%pat? __ppx_lwt_bound] [@metaloc bound.pexp_loc] in let new_exp = [%expr let [%p pat_bound] : int = [%e bound] in let rec __ppx_lwt_loop [%p p] = if [%e comp] [%e p'] [%e exp_bound] then Lwt.return () else Lwt.bind [%e body] (fun () -> __ppx_lwt_loop ([%e op] [%e p'] 1)) in __ppx_lwt_loop [%e start] ] in mapper.expr mapper { new_exp with pexp_attributes } (** [try%lwt $e$ with $c$] ≡ [Lwt.catch (fun () -> $e$) (function $c$)] *) | Pexp_try (expr, cases) -> let cases = add_wildcard_case cases in let new_exp = if !debug then [%expr Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> [%e expr]) [%e Exp.function_ cases]] else [%expr Lwt.catch (fun () -> [%e expr]) [%e Exp.function_ cases]] in mapper.expr mapper { new_exp with pexp_attributes } (** [if%lwt $c$ then $e1$ else $e2$] ≡ [match%lwt $c$ with true -> $e1$ | false -> $e2$] [if%lwt $c$ then $e1$] ≡ [match%lwt $c$ with true -> $e1$ | false -> Lwt.return_unit] *) | Pexp_ifthenelse (cond, e1, e2) -> let e2 = match e2 with None -> [%expr Lwt.return_unit] | Some e -> e in let cases = [ Exp.case [%pat? true] e1 ; Exp.case [%pat? false] e2 ; ] in let new_exp = [%expr Lwt.bind [%e cond] [%e Exp.function_ cases]] in mapper.expr mapper { new_exp with pexp_attributes } (** [[%lwt $e$]] ≡ [Lwt.catch (fun () -> $e$) Lwt.fail] *) | _ -> let exp = match exp with | { pexp_loc; pexp_desc=Pexp_let (Recursive, _, _); pexp_attributes } -> let attr = attribute_of_warning pexp_loc "\"let%lwt rec\" is not a recursive Lwt binding" in { exp with pexp_attributes = attr :: pexp_attributes } | _ -> exp in let new_exp = if !debug then [%expr Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> [%e exp]) Lwt.fail] else [%expr Lwt.catch (fun () -> [%e exp]) Lwt.fail] in mapper.expr mapper { new_exp with pexp_attributes } let make_loc { Location.loc_start } = let (file, line, char) = Location.get_pos_info loc_start in [%expr ([%e str file], [%e int line], [%e int char])] (** [Lwt_log.error "message"] ≡ [let __pa_log_section = Lwt_log.Section.main in if Lwt_log.Error >= (Lwt_log.Section.level __pa_log_section) then Lwt_log.error ~location:("foo.ml", 1, 0) ~section:__pa_log_section "message" else Lwt.return_unit]; [Lwt_log.error ~section "message"] ≡ [let __pa_log_section = section in ...]. Additionally, remove debug-level statements if -no-debug is given. **) let lwt_log mapper fn args attrs loc = let open Longident in match fn with | { pexp_desc = Pexp_ident { txt = Ldot (Lident "Lwt_log", func) } } -> let len = String.length func in let fmt = len >= 2 && func.[len - 2] = '_' && func.[len - 1] = 'f' and ign = len >= 4 && func.[0] = 'i' && func.[1] = 'g' && func.[2] = 'n' && func.[3] = '_' in let level = match fmt, ign with | false, false -> func | true, false -> String.sub func 0 (len - 2) | false, true -> String.sub func 4 (len - 4) | true, true -> String.sub func 4 (len - 6) in let level = String.capitalize level in if level = "Debug" && (not !debug) then let new_exp = if ign then [%expr ()] else [%expr Lwt.return_unit] in mapper.expr mapper { new_exp with pexp_attributes = attrs } else if List.mem level ["Fatal"; "Error"; "Warning"; "Notice"; "Info"; "Debug"] then let args = List.map (fun (l,e) -> l, mapper.expr mapper e) args in let new_exp = let args = (Label.labelled "location", make_loc loc) :: (Label.labelled "section", [%expr __pa_log_section]) :: List.remove_assoc (Label.labelled "section") args in [%expr if [%e Exp.construct (def_loc (Ldot (Lident "Lwt_log", level))) None] >= Lwt_log.Section.level __pa_log_section then [%e Exp.apply (Exp.ident (def_loc (Ldot (Lident "Lwt_log", func)))) args] else [%e if ign then [%expr ()] else [%expr Lwt.return_unit]]] in try let section = List.assoc (Label.labelled "section") args in [%expr let __pa_log_section = [%e section] in [%e new_exp]] with Not_found -> [%expr let __pa_log_section = Lwt_log.Section.main in [%e new_exp]] else default_mapper.expr mapper (Exp.apply ~attrs fn args) | _ -> default_mapper.expr mapper (Exp.apply ~attrs fn args) let lwt_mapper args = args |> List.iter (fun arg -> match arg with | "-no-debug" -> debug := false | "-log" -> log := true | "-no-log" -> log := false | "-no-sequence" -> sequence := false | "-no-strict-sequence" -> strict_seq := false | _ -> raise (Location.Error (Location.errorf "Unknown lwt.ppx argument: %s" arg))); { default_mapper with expr = (fun mapper expr -> match expr with | [%expr [%lwt [%e? exp]]] -> lwt_expression mapper exp expr.pexp_attributes (** [($e$)[%finally $f$]] ≡ [Lwt.finalize (fun () -> $e$) (fun () -> $f$)] *) | [%expr [%e? exp ] [%finally [%e? finally]] ] | [%expr [%e? exp ] [%lwt.finally [%e? finally]] ] -> let new_exp = if !debug then [%expr Lwt.backtrace_finalize (fun exn -> try raise exn with exn -> exn) (fun () -> [%e exp]) (fun () -> [%e finally])] else [%expr Lwt.finalize (fun () -> [%e exp]) (fun () -> [%e finally])] in mapper.expr mapper { new_exp with pexp_attributes = expr.pexp_attributes @ exp.pexp_attributes } | [%expr [%finally [%e? _ ]]] | [%expr [%lwt.finally [%e? _ ]]] -> raise (Location.Error ( Location.errorf ~loc:expr.pexp_loc "Lwt's finally should be used only with the syntax: \"()[%%finally ...]\"." )) | [%expr [%e? lhs] >> [%e? rhs]] -> if !sequence then let pat = if !strict_seq then [%pat? ()] else [%pat? _] in let lhs, rhs = mapper.expr mapper lhs, mapper.expr mapper rhs in if !debug then [%expr Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) [%e lhs] (fun [%p pat] -> [%e rhs])] else [%expr Lwt.bind [%e lhs] (fun [%p pat] -> [%e rhs])] else default_mapper.expr mapper expr | { pexp_desc = Pexp_apply (fn, args); pexp_attributes; pexp_loc } when !log -> default_loc := pexp_loc; lwt_log mapper fn args pexp_attributes pexp_loc | _ -> default_mapper.expr mapper expr); structure_item = (fun mapper stri -> default_loc := stri.pstr_loc; match stri with | [%stri let%lwt [%p? var] = [%e? exp]] -> [%stri let [%p var] = Lwt_main.run [%e mapper.expr mapper exp]] | { pstr_desc = Pstr_extension (({ txt = "lwt" }, PStr [ { pstr_desc = Pstr_value (Recursive, vbs) }]) as content, attrs); pstr_loc } -> { stri with pstr_desc = Pstr_extension (content, warn_let_lwt_rec pstr_loc attrs) } | { pstr_desc = Pstr_extension (({ txt = "lwt" }, PStr [ { pstr_desc = Pstr_value (Nonrecursive, vbs) }]), _) } -> mapper.structure_item mapper (Str.value Nonrecursive (gen_top_binds vbs)) | x -> default_mapper.structure_item mapper x); } let () = run_main lwt_mapper lwt-2.5.2/setup.ml000066400000000000000000007473001270742521300140360ustar00rootroot00000000000000(* * setup.ml * -------- * Copyright : (c) 2011, Jérémie Dimino * Licence : BSD3 * * This file is a part of lwt. *) (* OASIS_START *) (* DO NOT EDIT (digest: 13a9c966497f2b6a6f07ba3388dc24a9) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "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 (* # 22 "src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; } let quiet = {!default with quiet = true} let fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), s_ " Output debug message"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", (* TODO: remove this chdir. *) Arg.String (fun str -> Sys.chdir str), s_ "dir Change directory before running."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct (* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; if !what_idx = String.length what then true else false let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; if !what_idx = -1 then true else false let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) 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) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in String.lowercase buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt end module PropList = struct (* # 22 "src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 78 "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 (* # 22 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 22 "src/oasis/OASISVersion.ml" *) open OASISGettext type s = string type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let version_compare_string s1 s2 = version_compare (version_of_string s1) (version_of_string s2) let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) let rec comparator_ge v' = let cmp v = version_compare v v' >= 0 in function | VEqual v | VGreaterEqual v | VGreater v -> cmp v | VLesserEqual _ | VLesser _ -> false | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 end module OASISLicense = struct (* # 22 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 22 "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 OASISText = struct (* # 22 "src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISTypes = struct (* # 22 "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 (* # 115 "src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; } 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 | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; 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: OASISText.t 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; disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version t.oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" t.name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem t.name features in if not has_feature then match origin with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some str -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "It compiles the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allows the OASIS section comments and digest to be omitted in \ generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha (fun () -> s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") end module OASISUnixPath = struct (* # 22 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) end module OASISHostPath = struct (* # 22 "src/oasis/OASISHostPath.ml" *) open Filename module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = if Sys.os_type = "Unix" then ufn else make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) end module OASISSection = struct (* # 22 "src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section sct = let k, nm = section_id sct in (match k with | `Library -> "library" | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc") ^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 22 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 22 "src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 22 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) [modul; OASISUnixPath.uncapitalize_file modul; OASISUnixPath.capitalize_file modul] in (* TODO: we should be able to be able to determine the source for every * files. Hence we should introduce a Module(source: fn) for the fields * Modules and InternalModules *) List.fold_left (fun acc base_fn -> match acc with | `No_sources _ -> begin let file_found = List.fold_left (fun acc ext -> if source_file_exists (base_fn^ext) then (base_fn^ext) :: acc else acc) [] [".ml"; ".mli"; ".mll"; ".mly"] in match file_found with | [] -> acc | lst -> `Sources (base_fn, lst) end | `Sources _ -> acc) (`No_sources possible_base_fn) possible_base_fn let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module source_file_exists bs modul with | `Sources (base_fn, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* The headers and annot/cmt files that should be compiled along *) let headers = let sufx = if lib.lib_pack then [".cmti"; ".cmt"; ".annot"] else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map begin List.fold_left begin fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in List.map ((^) base) sufx @ accu end [] end (find_modules lib.lib_modules "cmi") in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath end else acc_nopath in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) end module OASISObject = struct (* # 22 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name; acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name ; lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "src/oasis/OASISFindlib.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * [`Library of library | `Object of object_] * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let rec group_of_tree mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> Package (nm, cs, bs, lib, group_of_tree children) | Node (None, children) -> Container (nm, group_of_tree children) | Leaf (cs, bs, lib) -> Package (nm, cs, bs, lib, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = lazy begin (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty end in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 22 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 22 "src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a, b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") tgt end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 2893 "setup.ml" module BaseEnvLight = struct (* # 22 "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 rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 2998 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 22 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (o, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (e: unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = BaseEnvLight.default_filename let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () let unload () = env_from_file := MapString.empty; Data.clear env let dump ?(filename=default_filename) () = let chn = open_out_bin filename in let output nm value = Printf.fprintf chn "%s=%S\n" nm value in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try let value = Schema.get schema env nm in output nm value with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; (* End of the dump *) close_out chn let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration: \n"; List.iter (fun (name, value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 22 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 22 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 22 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 22 "src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open OASISExpr open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> let _s: string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" | "Cygwin" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 22 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage let to_filename fn = let fn = OASISHostPath.of_unix fn in if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; Filename.chop_extension fn let replace fn_lst = let buff = Buffer.create 13 in List.iter (fun fn -> let fn = OASISHostPath.of_unix fn in let chn_in = open_in fn in let chn_out = open_out (to_filename fn) in ( try while true do Buffer.add_string buff (var_expand (input_line chn_in)); Buffer.add_char buff '\n' done with End_of_file -> () ); Buffer.output_buffer chn_out buff; Buffer.clear buff; close_in chn_in; close_out chn_out) fn_lst end module BaseLog = struct (* # 22 "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 (* # 22 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register t nm lst = BaseLog.register (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else registered) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister t nm = List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [to_log_event_file t nm; to_log_event_done t nm]) let fold t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BObj -> (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter [to_log_event_file t nm]) let is_built t nm = List.fold_left (fun is_built (_, d) -> (try bool_of_string d with _ -> false)) false (BaseLog.filter [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 22 "src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, exec) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISExpr open OASISGettext let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let failed, n = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 22 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISSection open OASISGettext open OASISUtils type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load (); with _ -> () end; (* Run plugin's configure *) t.configure t.package args; (* Dump to allow postconf to change it *) dump ()) (); (* Reload environment *) unload (); load (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace t.package.files_ab let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args let doc t args = BaseDoc.doc (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test t args = BaseTest.test (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all t args = let rno_doc = ref false in let rno_test = ref false in let arg_rest = ref [] 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"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t (Array.of_list (List.rev !arg_rest)); 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 _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f t.package) args) mains) () in let clean t args = generic_clean t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean t args = (* Call clean *) clean t args; (* Call distclean code *) generic_clean t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated file *) List.iter (fun fn -> if Sys.file_exists fn then begin info (f_ "Remove '%s'") fn; Sys.remove fn end) (BaseEnv.default_filename :: BaseLog.default_filename :: (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version t _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") let default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | n -> failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file default_oasis_fn then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in try let act_ref = ref (fun _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n"); (* Build initial environment *) load ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init t.package; if t.setup_update && update_setup_ml t then () else !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end # 5409 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall *) open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = let var_ignore_eval var = let _s: string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf (fun b -> errors := SetString.add (Buffer.contents b) !errors; Buffer.clear b) buff fmt in let warn_exception e = warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = List.iter (function | ExternalTool tool -> begin try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; add_errors (f_ "Cannot find external tool '%s'") tool end | InternalExecutable nm1 -> (* Check that matching tool is built *) List.iter (function | Executable ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal executable \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) lst in let build_checks sct bs = if var_choose bs.bs_build then begin if bs.bs_compiled_object = Native then begin try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; add_errors (f_ "Section %s requires native compilation") (OASISSection.string_of_section sct) end; (* Check tools *) check_tools bs.bs_build_tools; (* Check depends *) List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> warn_exception e; match version_comparator with | None -> add_errors (f_ "Cannot find findlib package %s") findlib_pkg | Some ver_cmp -> add_errors (f_ "Cannot find findlib package %s (%s)") findlib_pkg (OASISVersion.string_of_comparator ver_cmp) end | InternalLibrary nm1 -> (* Check that matching library is built *) List.iter (function | Library ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal library \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) bs.bs_build_depends end in (* Parse command line *) BaseArgExt.parse argv (BaseEnv.args ()); (* OCaml version *) begin match pkg.ocaml_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "ocaml" ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "findlib" ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Make sure the findlib version is fine for the OCaml compiler. *) begin let ocaml_ge4 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) (OASISVersion.version_of_string "1.3.2") < 0 in if findlib_lt132 then add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || BaseStandardVar.os_type () = "Cygwin" then begin try var_ignore_eval BaseStandardVar.flexlink with e -> warn_exception e; add_errors (f_ "Cannot find 'flexlink'") end; (* Check build depends *) List.iter (function | Executable (_, bs, _) | Library (_, bs, _) as sct -> build_checks sct bs | Doc (_, doc) -> if var_choose doc.doc_build then check_tools doc.doc_build_tools | Test (_, test) -> if var_choose test.test_run then check_tools test.test_tools | _ -> ()) pkg.sections; (* Check if we need native dynlink (presence of libraries that compile to * native) *) begin let has_cmxa = List.exists (function | Library (_, bs, _) -> var_choose bs.bs_build && (bs.bs_compiled_object = Native || (bs.bs_compiled_object = Best && bool_of_string (BaseStandardVar.is_native ()))) | _ -> false) pkg.sections in if has_cmxa then var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) if SetString.empty != !errors then begin List.iter (fun e -> error "%s" e) (SetString.elements !errors); failwithf (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) (SetString.cardinal !errors) end end module InternalInstallPlugin = struct (* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISFindlib 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 obj_hook = ref (fun (cs, bs, obj) -> cs, bs, obj, []) let doc_hook = ref (fun (cs, doc) -> cs, doc) let install_file_ev = "install-file" let install_dir_ev = "install-dir" let install_findlib_ev = "install-findlib" let win32_max_command_line_length = 8000 let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) let first_args = ["install"; findlib_name; meta] in (* Arguments for remaining commands: *) let other_args = ["install"; findlib_name; "-add"] in (* Extract as much files as possible from [files], [len] is the current command line length: *) let rec get_files len acc files = match files with | [] -> (List.rev acc, []) | file :: rest -> let len = len + 1 + String.length file in if len > win32_max_command_line_length then (List.rev acc, files) else get_files len (file :: acc) rest in (* Split the command into several commands. *) let rec split args files = match files with | [] -> [] | _ -> (* Length of "ocamlfind install [META|-add]" *) let len = List.fold_left (fun len arg -> len + 1 (* for the space *) + String.length arg) (String.length ocamlfind) args in match get_files len [] files with | ([], _) -> failwith (s_ "Command line too long.") | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) let () = let findlib_ge_132 = OASISVersion.comparator_apply (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf (f_ "Installing the library %s require to use the \ flag '-add' of ocamlfind because the command \ line is too long. This flag is only available \ for findlib 1.3.2. Please upgrade findlib from \ %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in cmd :: cmds in (* The first command does not use -add: *) split first_args files else ["install" :: findlib_name :: meta :: files] let install pkg argv = let in_destdir = try let destdir = destdir () in (* Practically speaking destdir is prepended * at the beginning of the target filename *) fun fn -> destdir^fn with PropList.Not_set _ -> fun fn -> fn in let install_file ?tgt_fn src_file envdir = let tgt_dir = in_destdir (envdir ()) in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) OASISFileUtil.mkdir_parent ~ctxt:!BaseContext.default (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register install_dir_ev dn) tgt_dir; (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; BaseLog.register install_file_ev tgt_file in (* Install data into defined directory *) let install_data srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file fn (fun () -> match tgt_opt with | Some s -> OASISHostPath.of_unix (var_expand s) | None -> tgtdir)) real_srcs) lst in let make_fnames modul sufx = List.fold_right begin fun sufx accu -> (String.capitalize modul ^ sufx) :: (String.uncapitalize modul ^ sufx) :: accu end sufx [] in (** Install all libraries *) let install_libs pkg = let files_of_library (f_data, acc) data_lib = let cs, bs, lib, lib_extra = !lib_hook data_lib in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then begin let acc = (* Start with acc + lib_extra *) List.rev_append lib_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ 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 and files_of_object (f_data, acc) data_obj = let cs, bs, obj, obj_extra = !obj_hook data_obj in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then begin let acc = (* Start with acc + obj_extra *) List.rev_append obj_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in object %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ acc end acc obj.obj_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BObj cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the object *) 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, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children | Package (_, cs, bs, `Object obj, children) -> files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux data_and_files children in (* Findlib name of the root library *) let findlib_name = findlib_of_group grp in (* Determine root library *) let root_lib = root_of_group grp in (* All files to install for this library *) let f_data, files = install_group_lib_aux (ignore, []) grp in (* Really install, if there is something to install *) if files = [] then begin warning (f_ "Nothing to install for findlib library '%s'") findlib_name end else begin let meta = (* Search META file *) let _, bs, _ = root_lib in let res = Filename.concat bs.bs_path "META" in if not (OASISFileUtil.file_exists_case res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else n in List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") findlib_name; let ocamlfind = ocamlfind () in let commands = split_install_command ocamlfind findlib_name meta files in List.iter (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) commands; BaseLog.register install_findlib_ev findlib_name end; (* Install data files *) f_data (); in let group_libs, _, _ = findlib_mapping pkg in (* We install libraries in groups *) List.iter install_group_lib group_libs in let install_execs pkg = let install_exec data_exec = let cs, bs, exec = !exec_hook data_exec in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = Filename.concat (libdir ()) pkg.name in BaseBuilt.fold BaseBuilt.BExec cs.cs_name (fun () fn -> install_file ~tgt_fn:(cs.cs_name ^ ext_program ()) fn bindir) (); BaseBuilt.fold BaseBuilt.BExecLib cs.cs_name (fun () fn -> install_file fn exec_libdir) (); install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name) end in List.iter (function | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) | _ -> ()) pkg.sections in let install_docs pkg = let install_doc data = let cs, doc = !doc_hook data in if var_choose doc.doc_install && BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then begin let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in BaseBuilt.fold BaseBuilt.BDoc cs.cs_name (fun () fn -> install_file fn (fun () -> tgt_dir)) (); install_data Filename.current_dir_name doc.doc_data_files doc.doc_install_dir end in List.iter (function | Doc (cs, doc) -> install_doc (cs, doc) | _ -> ()) pkg.sections in install_libs pkg; install_execs pkg; install_docs pkg (* Uninstall already installed data *) let uninstall _ argv = List.iter (fun (ev, data) -> if ev = install_file_ev then begin if OASISFileUtil.file_exists_case data then begin info (f_ "Removing file '%s'") data; Sys.remove data end else begin warning (f_ "File '%s' doesn't exist anymore") data end end else if ev = install_dir_ev then begin if Sys.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin info (f_ "Removing directory '%s'") data; OASISFileUtil.rmdir ~ctxt:!BaseContext.default data end else begin warning (f_ "Directory '%s' is not empty (%s)") data (String.concat ", " (Array.to_list (Sys.readdir data))) end end else begin warning (f_ "Directory '%s' doesn't exist anymore") data end end else if ev = install_findlib_ev then begin info (f_ "Removing findlib library '%s'") data; OASISExec.run ~ctxt:!BaseContext.default (ocamlfind ()) ["remove"; data] end else failwithf (f_ "Unknown log event '%s'") ev; BaseLog.unregister ev data) (* We process event in reverse order *) (List.rev (BaseLog.filter [install_file_ev; install_dir_ev; install_findlib_ev])) end # 6273 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar open OASISTypes type extra_args = string list let ocamlbuild_clean_ev = "ocamlbuild-clean" let ocamlbuildflags = var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" (fun () -> "") (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten [ if (os_type ()) = "Win32" then [ "-classic-display"; "-no-log"; "-no-links"; "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] else []; if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then [ "-byte-plugin" ] else []; args; if bool_of_string (debug ()) then ["-tag"; "debug"] else []; if bool_of_string (tests ()) then ["-tag"; "tests"] else []; if bool_of_string (profile ()) then ["-tag"; "profile"] else []; OASISString.nsplit (ocamlbuildflags ()) ' '; Array.to_list extra_argv; ] (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in (* Run if never called with these args *) if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then begin OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args ["-clean"] extra_argv); BaseLog.register ocamlbuild_clean_ev extra_cli; at_exit (fun () -> try BaseLog.unregister ocamlbuild_clean_ev extra_cli with _ -> ()) end (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html *) OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = function | "-build-dir" :: dir :: tl -> search_args dir tl | _ :: tl -> search_args dir tl | [] -> dir in search_args "_build" (fix_args [] extra_argv) end module OCamlbuildPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage let cond_targets_hook = ref (fun lst -> lst) let build extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat (build_dir argv) fn in (* Return the unix filename in host build directory *) let in_build_dir_of_unix fn = in_build_dir (OASISHostPath.of_unix fn) in let cond_targets = List.fold_left (fun acc -> function | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_library in_build_dir_of_unix (cs, bs, lib) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ~what:".cma" fn || ends_with ~what:".cmxs" fn || ends_with ~what:".cmxa" fn || ends_with ~what:(ext_lib ()) fn || ends_with ~what:(ext_dll ()) fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for library %s") cs.cs_name end | Object (cs, bs, obj) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_object in_build_dir_of_unix (cs, bs, obj) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cmo" fn || ends_with ".cmx" fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for object %s") cs.cs_name end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in let target ext = let unix_tgt = (OASISUnixPath.concat bs.bs_path (OASISUnixPath.chop_extension exec.exec_main_is))^ext in let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs in evs, [unix_tgt] in (* Add executable *) let acc = match bs.bs_compiled_object with | Native -> (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte | Best -> (target ".byte") :: acc in acc end | Library _ | Object _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] (* Keep the pkg.sections ordered *) (List.rev pkg.sections); in (* Check and register built files *) let check_and_register (bt, bnm, lst) = List.iter (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf (fn_ "Expected built file %s doesn't exist." "None of expected built files %s exists." (List.length fns)) (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in (* Run the hook *) let cond_targets = !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = run_clean extra_args; List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections end module OCamlbuildDocPlugin = struct (* # 22 "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 type run_t = { extra_args: string list; run_path: unix_filename; } let doc_build run pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ run.run_path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix run.run_path; cs.cs_name^".docdir"; ] in run_ocamlbuild (index_html :: run.extra_args) argv; List.iter (fun glb -> BaseBuilt.register BaseBuilt.BDoc cs.cs_name [OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] let doc_clean run pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end # 6651 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author *) open BaseEnv open OASISGettext open OASISTypes type t = { cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; } let run = BaseCustom.run let main t _ extra_args = let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in run cmd args extra_args let clean t pkg extra_args = match var_choose t.cmd_clean with | Some (cmd, args) -> run cmd args extra_args | _ -> () let distclean t pkg extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> run cmd args extra_args | _ -> () module Build = struct let main t pkg extra_args = main t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, _ = BaseBuilt.of_library OASISHostPath.of_unix (cs, bs, lib) in evs end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable OASISHostPath.of_unix (cs, bs, exec) in evs end | _ -> [] in List.iter (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) evs) pkg.sections let clean t pkg extra_args = clean t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections let distclean t pkg extra_args = distclean t pkg extra_args end module Test = struct let main t pkg (cs, test) extra_args = try main t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; 1.0 let clean t pkg (cs, test) extra_args = clean t pkg extra_args let distclean t pkg (cs, test) extra_args = distclean t pkg extra_args end module Doc = struct let main t pkg (cs, _) extra_args = main t pkg extra_args; BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] let clean t pkg (cs, _) extra_args = clean t pkg extra_args; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name let distclean t pkg (cs, _) extra_args = distclean t pkg extra_args end end # 6799 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build ["-use-ocamlfind"]; test = [ ("core", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_core", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("unix", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_unix", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("react", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_react", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("preemptive", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_preemptive", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("ppx", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_ppx", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; doc = [ ("lwt-manual", CustomPlugin.Doc.main { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("make", ["-C"; "manual"; "manual.pdf"])) ]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lwt-api", OCamlbuildDocPlugin.doc_build { OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; run_path = "./" }) ]; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = [ ("core", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_core", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("unix", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_unix", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("react", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_react", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("preemptive", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_preemptive", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("ppx", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_ppx", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; clean_doc = [ ("lwt-manual", CustomPlugin.Doc.clean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("make", ["-C"; "manual"; "manual.pdf"])) ]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lwt-api", OCamlbuildDocPlugin.doc_clean { OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; run_path = "./" }) ]; distclean = []; distclean_test = [ ("core", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_core", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("unix", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_unix", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("react", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_react", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("preemptive", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_preemptive", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("ppx", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_ppx", []))]; 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.4"; ocaml_version = Some (OASISVersion.VGreaterEqual "4.01"); findlib_version = None; alpha_features = ["pure_interface"]; beta_features = []; name = "lwt"; version = "2.5.2"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "LGPL"; excption = Some "OCaml linking"; version = OASISLicense.Version "2.1" }); license_file = Some "COPYING"; copyrights = []; maintainers = []; authors = [ "J\195\169r\195\180me Vouillon"; "Vincent Balat"; "Nataliya Guts"; "Pierre Clairambault"; "St\195\169phane Glondu"; "J\195\169r\195\169mie Dimino"; "Warren Harris"; "Pierre Chambart"; "Mauricio Fernandez"; "Gr\195\169goire Henri"; "Gabriel Radanne"; "Peter Zotov"; "Hugo Heuzard"; "Vincent Bernardoff"; "Romain Slootmaekers" ]; homepage = Some "http://ocsigen.org/lwt/"; synopsis = "Lightweight thread library for OCaml"; description = Some [ OASISText.Para "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." ]; categories = []; conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [ (OASISExpr.EBool true, Some (("ocaml", [ "discover.ml"; "-ext-obj"; "$ext_obj"; "-exec-name"; "$default_executable_name"; "-use-libev"; "$libev"; "-os-type"; "$os_type"; "-use-glib"; "$glib"; "-ccomp-type"; "$ccomp_type"; "-use-pthread"; "$pthread"; "-use-unix"; "$unix"; "-android-target"; "$android_target"; "-libev_default"; "$libev_default" ]))) ] }; build_type = (`Build, "ocamlbuild", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "internal", Some "0.4"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [ (OASISExpr.EBool true, Some (("$rm", [ "src/unix/lwt_config.h"; "src/unix/lwt_config.ml"; "src/unix/lwt_unix_jobs_generated.ml"; "src/unix/jobs-unix/*" ]))) ] }; files_ab = []; sections = [ Flag ({ cs_name = "android_target"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Compiles for Android"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "all"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "build and install everything"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "camlp4"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Build the syntax extension"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "all", true) ] }); Flag ({ cs_name = "ppx"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Build the ppx syntax extension"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "all", true) ] }); Flag ({ cs_name = "unix"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Unix support"; flag_default = [(OASISExpr.EBool true, true)] }); Flag ({ cs_name = "react"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "React helpers"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "all", true) ] }); Flag ({ cs_name = "glib"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Glib integration"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "all", true) ] }); Flag ({ cs_name = "ssl"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "SSL support"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "all", true) ] }); Flag ({ cs_name = "preemptive"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Preemptive threads support"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "unix", OASISExpr.ENot (OASISExpr.EFlag "android_target")), true) ] }); Flag ({ cs_name = "libev"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Compile with libev support"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), OASISExpr.ENot (OASISExpr.EFlag "android_target")), true) ] }); Flag ({ cs_name = "libev_default"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Use the libev backend by default"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.ETest ("system", "linux"), OASISExpr.EOr (OASISExpr.ETest ("system", "linux_elf"), OASISExpr.EOr (OASISExpr.ETest ("system", "linux_aout"), OASISExpr.EOr (OASISExpr.ETest ("system", "linux_eabi"), OASISExpr.ETest ("system", "linux_eabihf"))))), true) ] }); Flag ({ cs_name = "pthread"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Use pthread"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")), true) ] }); Library ({ cs_name = "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 = [FindlibPackage ("bytes", 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_condition"; "Lwt_list"; "Lwt"; "Lwt_mutex"; "Lwt_mvar"; "Lwt_pool"; "Lwt_sequence"; "Lwt_stream"; "Lwt_switch"; "Lwt_pqueue" ]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "lwt-log"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/logger"; bs_compiled_object = Best; bs_build_depends = [InternalLibrary "lwt"]; 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_log_core"; "Lwt_log_rules"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "log"; 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"; InternalLibrary "lwt-log"; FindlibPackage ("unix", None); FindlibPackage ("bigarray", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = [ "lwt_config.h"; "lwt_unix.h"; "lwt_unix_stubs.c"; "lwt_libev_stubs.c"; "lwt_process_stubs.c"; "jobs-unix/lwt_unix_job_access.c"; "jobs-unix/lwt_unix_job_chdir.c"; "jobs-unix/lwt_unix_job_chmod.c"; "jobs-unix/lwt_unix_job_chown.c"; "jobs-unix/lwt_unix_job_chroot.c"; "jobs-unix/lwt_unix_job_close.c"; "jobs-unix/lwt_unix_job_fchmod.c"; "jobs-unix/lwt_unix_job_fchown.c"; "jobs-unix/lwt_unix_job_fdatasync.c"; "jobs-unix/lwt_unix_job_fsync.c"; "jobs-unix/lwt_unix_job_ftruncate.c"; "jobs-unix/lwt_unix_job_link.c"; "jobs-unix/lwt_unix_job_lseek.c"; "jobs-unix/lwt_unix_job_mkdir.c"; "jobs-unix/lwt_unix_job_mkfifo.c"; "jobs-unix/lwt_unix_job_rename.c"; "jobs-unix/lwt_unix_job_rmdir.c"; "jobs-unix/lwt_unix_job_symlink.c"; "jobs-unix/lwt_unix_job_tcdrain.c"; "jobs-unix/lwt_unix_job_tcflow.c"; "jobs-unix/lwt_unix_job_tcflush.c"; "jobs-unix/lwt_unix_job_tcsendbreak.c"; "jobs-unix/lwt_unix_job_truncate.c"; "jobs-unix/lwt_unix_job_unlink.c" ]; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [ (OASISExpr.EBool true, []); (OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32")), ["-lws2_32"]); (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), ["ws2_32.lib"]); (OASISExpr.EAnd (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc")), OASISExpr.EAnd (OASISExpr.ENot (OASISExpr.EAnd (OASISExpr.ETest ("os_type", "Win32"), OASISExpr.ETest ("ccomp_type", "msvc"))), OASISExpr.ETest ("os_type", "Win32"))), ["ws2_32.lib"; "-lws2_32"]) ]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = [ "Lwt_chan"; "Lwt_daemon"; "Lwt_gc"; "Lwt_io"; "Lwt_log"; "Lwt_main"; "Lwt_process"; "Lwt_throttle"; "Lwt_timeout"; "Lwt_unix"; "Lwt_sys"; "Lwt_engine"; "Lwt_bytes" ]; lib_pack = false; lib_internal_modules = ["Lwt_unix_jobs_generated"; "Lwt_config"]; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "unix"; lib_findlib_containers = [] }); Library ({ cs_name = "lwt-simple-top"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"), true) ]; bs_path = "src/simple_top"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lwt"; InternalLibrary "lwt-unix"; FindlibPackage ("compiler-libs.common", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = ["Lwt_simple_top"]; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "simple-top"; lib_findlib_containers = [] }); Library ({ cs_name = "lwt-react"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "react", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "react", OASISExpr.EFlag "all"), true) ]; bs_path = "src/react"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lwt"; FindlibPackage ("react", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Lwt_react"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "react"; lib_findlib_containers = [] }); Library ({ cs_name = "lwt-preemptive"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "preemptive", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "preemptive", OASISExpr.EFlag "all"), true) ]; bs_path = "src/preemptive"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lwt"; InternalLibrary "lwt-unix"; FindlibPackage ("threads", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Lwt_preemptive"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "preemptive"; lib_findlib_containers = [] }); Library ({ cs_name = "lwt-glib"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "glib", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "glib", OASISExpr.EFlag "all"), true) ]; bs_path = "src/glib"; bs_compiled_object = Best; bs_build_depends = [InternalLibrary "lwt"; InternalLibrary "lwt-unix"]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = ["lwt_glib_stubs.c"]; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Lwt_glib"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "glib"; lib_findlib_containers = [] }); Library ({ cs_name = "lwt-ssl"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "ssl", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "ssl", OASISExpr.EFlag "all"), true) ]; bs_path = "src/ssl"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("ssl", None); InternalLibrary "lwt-unix" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Lwt_ssl"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "ssl"; lib_findlib_containers = [] }); Library ({ cs_name = "lwt-syntax"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "camlp4", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "camlp4", OASISExpr.EFlag "all"), true) ]; bs_path = "syntax"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("camlp4", None); FindlibPackage ("camlp4.quotations.o", None); FindlibPackage ("camlp4.extend", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Pa_lwt"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "syntax"; lib_findlib_containers = [] }); Library ({ cs_name = "lwt-syntax-options"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "camlp4", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "camlp4", OASISExpr.EFlag "all"), true) ]; bs_path = "syntax"; bs_compiled_object = Best; bs_build_depends = [FindlibPackage ("camlp4", None)]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = ["Pa_lwt_options"]; lib_findlib_parent = Some "lwt-syntax"; lib_findlib_name = Some "options"; lib_findlib_containers = [] }); Library ({ cs_name = "lwt-syntax-log"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "camlp4", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "camlp4", OASISExpr.EFlag "all"), true) ]; bs_path = "syntax"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("camlp4", None); FindlibPackage ("camlp4.quotations.o", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Pa_lwt_log"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt-syntax"; lib_findlib_name = Some "log"; lib_findlib_containers = [] }); Library ({ cs_name = "ppx"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "ppx", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "ppx", OASISExpr.EFlag "all"), true) ]; bs_path = "ppx"; 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 = ["Ppx_lwt"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "lwt"; lib_findlib_name = Some "ppx"; lib_findlib_containers = [] }); Executable ({ cs_name = "ppx_lwt"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "ppx", OASISExpr.EFlag "all"), true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "ppx", OASISExpr.EFlag "all"), true) ]; bs_path = "ppx"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("compiler-libs.common", None); FindlibPackage ("ppx_tools.metaquot", 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 = "ppx_lwt_ex.ml"}); Doc ({ cs_name = "lwt-manual"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "custom", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$pdfdir"; doc_title = "Lwt user manual"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("manual/manual.pdf", None)]; doc_build_tools = [ExternalTool "ocamlbuild"] }); Doc ({ cs_name = "lwt-api"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$htmldir/api"; doc_title = "API reference for Lwt"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("utils/style.css", None)]; doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] }); Executable ({ cs_name = "logging"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "unix", OASISExpr.EFlag "camlp4"), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples/unix"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lwt-unix"; InternalLibrary "lwt-syntax" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "logging.ml"}); Executable ({ cs_name = "relay"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "unix", OASISExpr.EFlag "camlp4"), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples/unix"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lwt-unix"; InternalLibrary "lwt-syntax" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "relay.ml"}); Executable ({ cs_name = "parallelize"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "unix", OASISExpr.EFlag "camlp4"), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples/unix"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lwt-unix"; InternalLibrary "lwt-syntax" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "parallelize.ml"}); Library ({ cs_name = "test"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EFlag "unix", OASISExpr.EFlag "all")), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "tests"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lwt"; FindlibPackage ("unix", None); InternalLibrary "lwt-unix" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Test"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Executable ({ cs_name = "test_core"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EFlag "unix", OASISExpr.EFlag "all")), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "tests/core"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "test"; InternalLibrary "lwt"; FindlibPackage ("unix", None); InternalLibrary "lwt-unix" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "main.ml"}); Executable ({ cs_name = "test_unix"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EFlag "unix", OASISExpr.EFlag "all")), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "tests/unix"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "test"; InternalLibrary "lwt"; FindlibPackage ("unix", None); InternalLibrary "lwt-unix" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "main.ml"}); Executable ({ cs_name = "test_react"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EAnd (OASISExpr.EFlag "unix", OASISExpr.EFlag "react"), OASISExpr.EFlag "all")), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "tests/react"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "test"; InternalLibrary "lwt"; FindlibPackage ("unix", None); InternalLibrary "lwt-unix"; FindlibPackage ("react", None); InternalLibrary "lwt-react" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "main.ml"}); Executable ({ cs_name = "test_preemptive"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EAnd (OASISExpr.EFlag "preemptive", OASISExpr.EFlag "unix"), OASISExpr.EFlag "all")), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "tests/preemptive"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "test"; InternalLibrary "lwt"; FindlibPackage ("unix", None); InternalLibrary "lwt-unix"; InternalLibrary "lwt-preemptive"; FindlibPackage ("threads", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "main.ml"}); Executable ({ cs_name = "test_ppx"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EAnd (OASISExpr.EFlag "ppx", OASISExpr.EFlag "unix"), OASISExpr.EFlag "all")), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "tests/ppx"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "test"; InternalLibrary "lwt"; InternalLibrary "lwt-unix" ]; bs_build_tools = [ ExternalTool "ocamlbuild"; InternalExecutable "ppx_lwt" ]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "main.ml"}); Test ({ cs_name = "core"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("$test_core", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; test_working_directory = None; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"))), true) ]; test_tools = [ ExternalTool "ocamlbuild"; InternalExecutable "test_core" ] }); Test ({ cs_name = "unix"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("$test_unix", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; test_working_directory = None; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EFlag "unix", OASISExpr.EFlag "all"))), true) ]; test_tools = [ ExternalTool "ocamlbuild"; InternalExecutable "test_unix" ] }); Test ({ cs_name = "react"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("$test_react", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; test_working_directory = None; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EAnd (OASISExpr.EFlag "unix", OASISExpr.EFlag "react"), OASISExpr.EFlag "all"))), true) ]; test_tools = [ ExternalTool "ocamlbuild"; InternalExecutable "test_react" ] }); Test ({ cs_name = "preemptive"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("$test_preemptive", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; test_working_directory = None; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EAnd (OASISExpr.EFlag "preemptive", OASISExpr.EFlag "unix"), OASISExpr.EFlag "all"))), true) ]; test_tools = [ ExternalTool "ocamlbuild"; InternalExecutable "test_preemptive" ] }); Test ({ cs_name = "ppx"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("$test_ppx", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; test_working_directory = None; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EOr (OASISExpr.EAnd (OASISExpr.EFlag "ppx", OASISExpr.EFlag "unix"), OASISExpr.EFlag "all"))), true) ]; test_tools = [ ExternalTool "ocamlbuild"; InternalExecutable "test_ppx" ] }); SrcRepo ({ cs_name = "head"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { src_repo_type = Git; src_repo_location = "git://github.com/ocsigen/lwt"; src_repo_browser = Some "https://github.com/ocsigen/lwt"; src_repo_module = None; src_repo_branch = None; src_repo_tag = None; src_repo_subdir = None }) ]; plugins = [(`Extra, "DevFiles", Some "0.4"); (`Extra, "META", Some "0.4")]; disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; oasis_digest = Some "\219\156\247\014n\250\252\159\001!\136\197:E=\223"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 8562 "setup.ml" (* OASIS_STOP *) let () = InternalInstallPlugin.lib_hook := fun (cs, bs, lib) -> match lib.OASISTypes.lib_findlib_name with | Some "unix" -> (cs, bs, lib, ["src/unix/lwt_config.h"; "src/unix/lwt_unix.h"]) | _ -> (cs, bs, lib, []) ;; let () = setup ();; lwt-2.5.2/src/000077500000000000000000000000001270742521300131205ustar00rootroot00000000000000lwt-2.5.2/src/core/000077500000000000000000000000001270742521300140505ustar00rootroot00000000000000lwt-2.5.2/src/core/META000066400000000000000000000074541270742521300145330ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: bc8d6fff062fa1a39ca89d01e9e1c40c) version = "2.5.2" description = "Lightweight thread library for OCaml (core library)" requires = "bytes" archive(byte) = "lwt.cma" archive(byte, plugin) = "lwt.cma" archive(native) = "lwt.cmxa" archive(native, plugin) = "lwt.cmxs" exists_if = "lwt.cma" package "unix" ( version = "2.5.2" description = "Unix support for lwt" requires = "lwt lwt.log unix bigarray" archive(byte) = "lwt-unix.cma" archive(byte, plugin) = "lwt-unix.cma" archive(native) = "lwt-unix.cmxa" archive(native, plugin) = "lwt-unix.cmxs" exists_if = "lwt-unix.cma" ) package "syntax" ( version = "2.5.2" description = "Syntactic sugars for Lwt" requires = "camlp4 lwt.syntax.options" archive(syntax, preprocessor) = "lwt-syntax.cma" archive(syntax, toploop) = "lwt-syntax.cma" archive(syntax, preprocessor, native) = "lwt-syntax.cmxa" archive(syntax, preprocessor, native, plugin) = "lwt-syntax.cmxs" exists_if = "lwt-syntax.cma" package "options" ( version = "2.5.2" description = "Options for syntax extensions" requires = "camlp4" archive(syntax, preprocessor) = "lwt-syntax-options.cma" archive(syntax, toploop) = "lwt-syntax-options.cma" archive(syntax, preprocessor, native) = "lwt-syntax-options.cmxa" archive(syntax, preprocessor, native, plugin) = "lwt-syntax-options.cmxs" exists_if = "lwt-syntax-options.cma" ) package "log" ( version = "2.5.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" archive(syntax, preprocessor, native) = "lwt-syntax-log.cmxa" archive(syntax, preprocessor, native, plugin) = "lwt-syntax-log.cmxs" exists_if = "lwt-syntax-log.cma" ) ) package "ssl" ( version = "2.5.2" description = "SSL support for Lwt" requires = "ssl lwt.unix" archive(byte) = "lwt-ssl.cma" archive(byte, plugin) = "lwt-ssl.cma" archive(native) = "lwt-ssl.cmxa" archive(native, plugin) = "lwt-ssl.cmxs" exists_if = "lwt-ssl.cma" ) package "simple-top" ( version = "2.5.2" description = "Unix support for lwt" requires = "lwt lwt.unix compiler-libs.common" archive(byte) = "lwt-simple-top.cma" archive(byte, plugin) = "lwt-simple-top.cma" archive(native) = "lwt-simple-top.cmxa" archive(native, plugin) = "lwt-simple-top.cmxs" exists_if = "lwt-simple-top.cma" ) package "react" ( version = "2.5.2" description = "Reactive programming helpers" requires = "lwt react" archive(byte) = "lwt-react.cma" archive(byte, plugin) = "lwt-react.cma" archive(native) = "lwt-react.cmxa" archive(native, plugin) = "lwt-react.cmxs" exists_if = "lwt-react.cma" ) package "preemptive" ( version = "2.5.2" description = "Preemptive threads support for Lwt" requires = "lwt lwt.unix threads" archive(byte) = "lwt-preemptive.cma" archive(byte, plugin) = "lwt-preemptive.cma" archive(native) = "lwt-preemptive.cmxa" archive(native, plugin) = "lwt-preemptive.cmxs" exists_if = "lwt-preemptive.cma" ) package "ppx" ( version = "2.5.2" description = "New-style (ppx) syntax extension" requires = "lwt" archive(byte) = "ppx.cma" archive(byte, plugin) = "ppx.cma" archive(native) = "ppx.cmxa" archive(native, plugin) = "ppx.cmxs" ppx = "ppx_lwt" exists_if = "ppx.cma" ) package "log" ( version = "2.5.2" description = "Logger for lwt" requires = "lwt" archive(byte) = "lwt-log.cma" archive(byte, plugin) = "lwt-log.cma" archive(native) = "lwt-log.cmxa" archive(native, plugin) = "lwt-log.cmxs" exists_if = "lwt-log.cma" ) package "glib" ( version = "2.5.2" description = "Glib integration" requires = "lwt lwt.unix" archive(byte) = "lwt-glib.cma" archive(byte, plugin) = "lwt-glib.cma" archive(native) = "lwt-glib.cmxa" archive(native, plugin) = "lwt-glib.cmxs" exists_if = "lwt-glib.cma" ) # OASIS_STOP lwt-2.5.2/src/core/lwt.ml000066400000000000000000001105501270742521300152120ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt * Copyright (C) 2005-2008 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * 2009-2012 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) exception Canceled module Int_map = Map.Make(struct type t = int let compare = compare end) type data = (unit -> unit) Int_map.t (* Type of data carried by threads *) type +'a t type -'a u (* A type + a thread of this type. *) module type A_thread = sig type a val thread : a t end type a_thread = (module A_thread) (* a_thread = exists 'a. 'a t *) (* Pack a thread into a A_thread module. *) let pack_thread (type x) t = let module M = struct type a = x let thread = t end in (module M : A_thread) (* A type + a list of threads of this type. *) module type A_threads = sig type a val threads : a t list end type a_threads = (module A_threads) (* a_threads = exists 'a. 'a t list *) (* Pack a list of threads into a A_threads module. *) let pack_threads (type x) l = let module M = struct type a = x let threads = l end in (module M : A_threads) type 'a thread_state = | Return of 'a (* [Return v] a terminated thread which has successfully terminated with the value [v] *) | Fail of exn (* [Fail exn] a terminated thread which has failed with the exception [exn]. *) | Sleep of 'a sleeper (* [Sleep sleeper] is a sleeping thread *) | Repr of 'a thread_repr (* [Repr t] a thread which behaves the same as [t] *) and 'a thread_repr = { mutable state : 'a thread_state; (* The state of the thread *) } and 'a sleeper = { mutable cancel : cancel; (* How to cancel this thread. *) mutable waiters : 'a waiter_set; (* All thunk functions. These functions are always called inside a enter_wakeup/leave_wakeup block. *) mutable removed : int; (* Number of waiter that have been disabled. When this number reaches [max_removed], they are effectively removed from [waiters]. *) mutable cancel_handlers : 'a cancel_handler_set; (* Functions to execute when this thread is canceled. Theses functions must be executed before waiters. *) } and cancel = | Cancel_no (* This thread cannot be canceled, it was created with [wait]. *) | Cancel_me (* Restart this thread with [Fail Canceled]. It was created with [task]. *) | Cancel_link of a_thread (* Cancel this thread. *) | Cancel_links of a_threads (* Cancel all these threads. *) (* Type of set of waiters: *) and 'a waiter_set = | Empty | Removable of ('a thread_state -> unit) option ref | Immutable of ('a thread_state -> unit) | Append of 'a waiter_set * 'a waiter_set and 'a cancel_handler_set = | Chs_empty | Chs_func of data * (unit -> unit) (* The callback may raise an exception. *) | Chs_node of 'a u Lwt_sequence.node (* This is the same as: {[ Chs_func (fun () -> Lwt_sequence.remove node) ]} but it is the common case so it is inlined. *) | Chs_append of 'a cancel_handler_set * 'a cancel_handler_set external thread_repr : 'a t -> 'a thread_repr = "%identity" external thread : 'a thread_repr -> 'a t = "%identity" external wakener : 'a thread_repr -> 'a u = "%identity" external wakener_repr : 'a u -> 'a thread_repr = "%identity" (* Maximum number of disabled waiters a waiter set can contains before being cleaned: *) let max_removed = 42 (* +-----------------------------------------------------------------+ | Local storage | +-----------------------------------------------------------------+ *) type 'a key = { id : int; mutable store : 'a option; } let next_key_id = ref 0 let new_key () = let id = !next_key_id in next_key_id := id + 1; { id = id; store = None } let current_data = ref Int_map.empty let get key = try Int_map.find key.id !current_data (); let value = key.store in key.store <- None; value with Not_found -> None (* +-----------------------------------------------------------------+ | Restarting/connecting threads | +-----------------------------------------------------------------+ *) (* Returns the representative of a thread, updating non-direct references: *) let rec repr_rec t = match t.state with | Repr t' -> let t'' = repr_rec t' in if t'' != t' then t.state <- Repr t''; t'' | _ -> t let repr t = repr_rec (thread_repr t) let async_exception_hook = ref (fun exn -> prerr_string "Fatal error: exception "; prerr_string (Printexc.to_string exn); prerr_char '\n'; Printexc.print_backtrace stderr; flush stderr; exit 2) (* Execute [f x] and handle any raised exception with [async_exception_hook]. *) let call_unsafe f x = try f x with exn -> !async_exception_hook exn let rec run_waiters_rec state ws rem = match ws with | Empty -> run_waiters_rec_next state rem | Immutable f -> f state; run_waiters_rec_next state rem | Removable { contents = None } -> run_waiters_rec_next state rem | Removable { contents = Some f } -> f state; run_waiters_rec_next state rem | Append (ws1, ws2) -> run_waiters_rec state ws1 (ws2 :: rem) and run_waiters_rec_next state rem = match rem with | [] -> () | ws :: rem -> run_waiters_rec state ws rem let rec run_cancel_handlers_rec chs rem = match chs with | Chs_empty -> run_cancel_handlers_rec_next rem | Chs_func (data, f) -> current_data := data; call_unsafe f (); run_cancel_handlers_rec_next rem | Chs_node n -> Lwt_sequence.remove n; run_cancel_handlers_rec_next rem | Chs_append (chs1, chs2) -> run_cancel_handlers_rec chs1 (chs2 :: rem) and run_cancel_handlers_rec_next rem = match rem with | [] -> () | chs :: rem -> run_cancel_handlers_rec chs rem (* Run all waiters waiting on [t]. This must always be done inside a enter_wakeup/leave_wakeup block. This function must never raise an exception. *) let unsafe_run_waiters sleeper state = (* Call cancel handlers if this is a thread cancellation. *) (match state with | Fail Canceled -> run_cancel_handlers_rec sleeper.cancel_handlers [] | _ -> ()); (* Restart waiters. *) run_waiters_rec state sleeper.waiters [] (* [true] if we are in a wakeup. *) let wakening = ref false (* A sleeper + its state. *) module type A_closure = sig type a val sleeper : a sleeper val state : a thread_state end (* Queue of sleepers to wakeup. *) let to_wakeup = Queue.create () (* Enter a wakeup operation. *) let enter_wakeup () = let snapshot = !current_data in let already_wakening = if !wakening then (* If we are already in a wakeup, do nothing. *) true else begin (* Otherwise mark that a wakeup operation has started. *) wakening := true; false end in (already_wakening, snapshot) (* Leave a wakeup operation. *) let leave_wakeup (already_wakening, snapshot) = if not already_wakening then begin (* This was the first wakeup on the call stack, wakeup remaining sleeping threads. *) while not (Queue.is_empty to_wakeup) do let closure = Queue.pop to_wakeup in let module M = (val closure : A_closure) in unsafe_run_waiters M.sleeper M.state done; (* We are done wakening threads. *) wakening := false; current_data := snapshot end else current_data := snapshot let safe_run_waiters sleeper state = let ctx = enter_wakeup () in unsafe_run_waiters sleeper state; leave_wakeup ctx (* A ['a result] is either [Return of 'a] or [Fail of exn] so it is covariant. *) type +'a result (* = 'a thread_state *) external result_of_state : 'a thread_state -> 'a result = "%identity" external state_of_result : 'a result -> 'a thread_state = "%identity" let make_value v = result_of_state (Return v) let make_error e = result_of_state (Fail e) let wakeup_result t result = let t = repr_rec (wakener_repr t) in match t.state with | Sleep sleeper -> let state = state_of_result result in t.state <- state; safe_run_waiters sleeper state | Fail Canceled -> (* Do not fail if the thread has been canceled: *) () | _ -> invalid_arg "Lwt.wakeup_result" let wakeup t v = wakeup_result t (make_value v) let wakeup_exn t e = wakeup_result t (make_error e) let wakeup_later_result (type x) t result = let t = repr_rec (wakener_repr t) in match t.state with | Sleep sleeper -> let state = state_of_result result in t.state <- state; if !wakening then begin (* Already wakening => create the closure for later wakening. *) let module M = struct type a = x let sleeper = sleeper let state = state end in Queue.push (module M : A_closure) to_wakeup end else (* Otherwise restart threads now. *) safe_run_waiters sleeper state | Fail Canceled -> () | _ -> invalid_arg "Lwt.wakeup_later_result" let wakeup_later t v = wakeup_later_result t (make_value v) let wakeup_later_exn t e = wakeup_later_result t (make_error e) module type A_sleeper = sig type a val sleeper : a sleeper end type a_sleeper = (module A_sleeper) let pack_sleeper (type x) sleeper = let module M = struct type a = x let sleeper = sleeper end in (module M : A_sleeper) let cancel (type x) t = let state = Fail Canceled in (* - collect all sleepers to restart - set the state of all threads to cancel to [Fail Canceled] *) let rec collect : 'a. a_sleeper list -> 'a t -> a_sleeper list = fun acc t -> let t = repr t in match t.state with | Sleep ({ cancel } as sleeper) -> begin match cancel with | Cancel_no -> acc | Cancel_me -> (* Set the state of [t] immediately so it won't be collected again. *) t.state <- state; (pack_sleeper sleeper) :: acc | Cancel_link m -> let module M = (val m : A_thread) in collect acc M.thread | Cancel_links m -> let module M = (val m : A_threads) in List.fold_left collect acc M.threads end | _ -> acc in let sleepers = collect [] t in (* Restart all sleepers. *) let ctx = enter_wakeup () in List.iter (fun sleeper -> let module M = (val sleeper : A_sleeper) in run_cancel_handlers_rec M.sleeper.cancel_handlers []; run_waiters_rec state M.sleeper.waiters []) sleepers; leave_wakeup ctx let append l1 l2 = match l1, l2 with | Empty, _ -> l2 | _, Empty -> l1 | _ -> Append (l1, l2) let chs_append l1 l2 = match l1, l2 with | Chs_empty, _ -> l2 | _, Chs_empty -> l1 | _ -> Chs_append (l1, l2) (* Remove all disbaled waiters of a waiter set: *) let rec cleanup = function | Removable { contents = None } -> Empty | Append (l1, l2) -> append (cleanup l1) (cleanup l2) | ws -> ws (* Make [t1] and [t2] behave the same way, where [t1] is a sleeping thread. This means that they must share the same representation. [connect] assumes it is called inside a enter_wakeup/leave_wakeup block. *) let connect t1 t2 = let t1 = repr t1 and t2 = repr t2 in match t1.state with | Sleep sleeper1 -> if t1 == t2 then (* Do nothing if the two threads already have the same representation *) () else begin match t2.state with | Sleep sleeper2 -> (* If [t2] is sleeping, then makes it behave as [t1]: *) t2.state <- Repr t1; (* Note that the order is important: the user have no access to [t2] but may keep a reference to [t1]. If we inverse the order, i.e. we do: [t1.state <- Repr t2] then we have a possible leak. For example: {[ let rec loop ()== lwt () = Lwt_unix.yield () in loop () lwt () = let t = loop () in ... ]} Here, after [n] iterations, [t] will contains: [ref(Repr(ref(Repr(ref(Repr ... ref Sleep)))))] \-------------[n]--------------/ *) (* Cancelling [t1] is now the same as canceling [t2]: *) sleeper1.cancel <- sleeper2.cancel; (* Merge the two sets of waiters: *) let waiters = append sleeper1.waiters sleeper2.waiters and removed = sleeper1.removed + sleeper2.removed in if removed > max_removed then begin (* Remove disabled threads *) sleeper1.removed <- 0; sleeper1.waiters <- cleanup waiters end else begin sleeper1.removed <- removed; sleeper1.waiters <- waiters end; sleeper1.cancel_handlers <- chs_append sleeper1.cancel_handlers sleeper2.cancel_handlers | state2 -> (* [t2] is already terminated, assing its state to [t1]: *) t1.state <- state2; (* and run all the waiters of [t1]: *) unsafe_run_waiters sleeper1 state2 end | _ -> (* [t1] is not asleep: *) assert false (* Same as [connect] except that we know that [t2] has alreayd terminated. *) let fast_connect t state = let t = repr t in match t.state with | Sleep sleeper -> t.state <- state; unsafe_run_waiters sleeper state | _ -> assert false (* Same as [fast_connect] except that it does nothing if [t] has terminated. *) let fast_connect_if t state = let t = repr t in match t.state with | Sleep sleeper -> t.state <- state; unsafe_run_waiters sleeper state | _ -> () (* +-----------------------------------------------------------------+ | Threads conctruction and combining | +-----------------------------------------------------------------+ *) let return v = thread { state = Return v } let state_return_unit = Return () let return_unit = thread { state = state_return_unit } let return_none = return None let return_some x = return (Some x) let return_nil = return [] let return_true = return true let return_false = return false let of_result result = thread { state = state_of_result result } let fail e = thread { state = Fail e } let fail_with msg = thread { state = Fail (Failure msg) } let fail_invalid_arg msg = thread { state = Fail (Invalid_argument msg) } let temp t = thread { state = Sleep { cancel = Cancel_link (pack_thread (thread t)); waiters = Empty; removed = 0; cancel_handlers = Chs_empty } } let temp_many l = thread { state = Sleep { cancel = Cancel_links (pack_threads l); waiters = Empty; removed = 0; cancel_handlers = Chs_empty } } let wait_aux () = { state = Sleep { cancel = Cancel_no; waiters = Empty; removed = 0; cancel_handlers = Chs_empty } } let wait () = let t = wait_aux () in (thread t, wakener t) let task_aux () = { state = Sleep { cancel = Cancel_me; waiters = Empty; removed = 0; cancel_handlers = Chs_empty } } let task () = let t = task_aux () in (thread t, wakener t) let add_task_r seq = let sleeper = { cancel = Cancel_me; waiters = Empty; removed = 0; cancel_handlers = Chs_empty } in let t = { state = Sleep sleeper } in let node = Lwt_sequence.add_r (wakener t) seq in sleeper.cancel_handlers <- Chs_node node; thread t let add_task_l seq = let sleeper = { cancel = Cancel_me; waiters = Empty; removed = 0; cancel_handlers = Chs_empty }in let t = { state = Sleep sleeper } in let node = Lwt_sequence.add_l (wakener t) seq in sleeper.cancel_handlers <- Chs_node node; thread t let waiter_of_wakener wakener = thread (wakener_repr wakener) (* apply function, reifying explicit exceptions into the thread type apply: ('a -(exn)-> 'b t) -> ('a -(n)-> 'b t) semantically a natural transformation TE -> T, where T is the thread monad, which is layered over exception monad E. *) let apply f x = try f x with e -> fail e let wrap f = try return (f ()) with exn -> fail exn let wrap1 f x1 = try return (f x1) with exn -> fail exn let wrap2 f x1 x2 = try return (f x1 x2) with exn -> fail exn let wrap3 f x1 x2 x3 = try return (f x1 x2 x3) with exn -> fail exn let wrap4 f x1 x2 x3 x4 = try return (f x1 x2 x3 x4) with exn -> fail exn let wrap5 f x1 x2 x3 x4 x5 = try return (f x1 x2 x3 x4 x5) with exn -> fail exn let wrap6 f x1 x2 x3 x4 x5 x6 = try return (f x1 x2 x3 x4 x5 x6) with exn -> fail exn let wrap7 f x1 x2 x3 x4 x5 x6 x7 = try return (f x1 x2 x3 x4 x5 x6 x7) with exn -> fail exn let add_waiter sleeper waiter = sleeper.waiters <- (match sleeper.waiters with | Empty -> waiter | ws -> Append (waiter, ws)) let add_immutable_waiter sleeper waiter = add_waiter sleeper (Immutable waiter) let on_cancel t f = match (repr t).state with | Sleep sleeper -> let handler = Chs_func (!current_data, f) in sleeper.cancel_handlers <- ( match sleeper.cancel_handlers with | Chs_empty -> handler | chs -> Chs_append (handler, chs) ) | Fail Canceled -> call_unsafe f () | _ -> () let bind t f = let t = repr t in match t.state with | Return v -> f v | Fail _ as state -> thread { state } | Sleep sleeper -> let res = temp t in let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; connect res (try f v with exn -> fail exn) | Fail _ as state -> fast_connect res state | _ -> assert false); res | Repr _ -> assert false let (>>=) t f = bind t f let (=<<) f t = bind t f let map f t = let t = repr t in match t.state with | Return v -> thread { state = try Return (f v) with exn -> Fail exn } | Fail _ as state -> thread { state } | Sleep sleeper -> let res = temp t in let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; fast_connect res (try Return (f v) with exn -> Fail exn) | Fail _ as state -> fast_connect res state | _ -> assert false); res | Repr _ -> assert false let (>|=) t f = map f t let (=|<) f t = map f t let catch x f = let t = repr (try x () with exn -> fail exn) in match t.state with | Return _ -> thread t | Fail exn -> f exn | Sleep sleeper -> let res = temp t in let data = !current_data in add_immutable_waiter sleeper (function | Return _ as state -> fast_connect res state | Fail exn -> current_data := data; connect res (try f exn with exn -> fail exn) | _ -> assert false); res | Repr _ -> assert false let on_success t f = match (repr t).state with | Return v -> call_unsafe f v | Fail exn -> () | Sleep sleeper -> let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; call_unsafe f v | Fail exn -> () | _ -> assert false) | Repr _ -> assert false let on_failure t f = match (repr t).state with | Return v -> () | Fail exn -> call_unsafe f exn | Sleep sleeper -> let data = !current_data in add_immutable_waiter sleeper (function | Return v -> () | Fail exn -> current_data := data; call_unsafe f exn | _ -> assert false) | Repr _ -> assert false let on_termination t f = match (repr t).state with | Return v -> call_unsafe f () | Fail exn -> call_unsafe f () | Sleep sleeper -> let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; call_unsafe f () | Fail exn -> current_data := data; call_unsafe f () | _ -> assert false) | Repr _ -> assert false let on_any t f g = match (repr t).state with | Return v -> call_unsafe f v | Fail exn -> call_unsafe g exn | Sleep sleeper -> let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; call_unsafe f v | Fail exn -> current_data := data; call_unsafe g exn | _ -> assert false) | Repr _ -> assert false let try_bind x f g = let t = repr (try x () with exn -> fail exn) in match t.state with | Return v -> f v | Fail exn -> g exn | Sleep sleeper -> let res = temp t in let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; connect res (try f v with exn -> fail exn) | Fail exn -> current_data := data; connect res (try g exn with exn -> fail exn) | _ -> assert false); res | Repr _ -> assert false let poll t = match (repr t).state with | Fail e -> raise e | Return v -> Some v | Sleep _ -> None | Repr _ -> assert false let async f = let t = repr (try f () with exn -> fail exn) in match t.state with | Return _ -> () | Fail exn -> !async_exception_hook exn | Sleep sleeper -> add_immutable_waiter sleeper (function | Return _ -> () | Fail exn -> !async_exception_hook exn | _ -> assert false) | Repr _ -> assert false let ignore_result t = match (repr t).state with | Return _ -> () | Fail e -> raise e | Sleep sleeper -> add_immutable_waiter sleeper (function | Return _ -> () | Fail exn -> !async_exception_hook exn | _ -> assert false) | Repr _ -> assert false let protected t = match (repr t).state with | Sleep sleeper -> let res = thread (task_aux ()) in (* We use [fact_connect_if] because when [res] is canceled, it will always terminate before [t]. *) add_immutable_waiter sleeper (fast_connect_if res); res | Return _ | Fail _ -> t | Repr _ -> assert false let no_cancel t = match (repr t).state with | Sleep sleeper -> let res = thread (wait_aux ()) in add_immutable_waiter sleeper (fast_connect res); res | Return _ | Fail _ -> t | Repr _ -> assert false let rec nth_ready l n = match l with | [] -> assert false | t :: l -> match (repr t).state with | Sleep _ -> nth_ready l n | _ -> if n > 0 then nth_ready l (n - 1) else t let ready_count l = List.fold_left (fun acc x -> match (repr x).state with Sleep _ -> acc | _ -> acc + 1) 0 l let remove_waiters l = List.iter (fun t -> match (repr t).state with | Sleep ({ waiters = Removable _ } as sleeper) -> (* There is only one waiter, it is the removed one. *) sleeper.waiters <- Empty | Sleep sleeper -> let removed = sleeper.removed + 1 in if removed > max_removed then begin sleeper.removed <- 0; sleeper.waiters <- cleanup sleeper.waiters end else sleeper.removed <- removed | _ -> ()) l let add_removable_waiter threads waiter = let node = Removable waiter in List.iter (fun t -> match (repr t).state with | Sleep sleeper -> add_waiter sleeper node | _ -> assert false) threads (* The PRNG state is initialized with a constant to make non-IO-based programs deterministic. *) let random_state = lazy (Random.State.make [||]) let choose l = let ready = ready_count l in if ready > 0 then if ready = 1 then (* Optimisation for the common case: *) nth_ready l 0 else nth_ready l (Random.State.int (Lazy.force random_state) ready) else begin let res = temp_many l in let rec waiter = ref (Some handle_result) and handle_result state = (* Disable the waiter now: *) waiter := None; (* Removes all waiters so we do not leak memory: *) remove_waiters l; (* This will not fail because it is called at most one time, since all other waiters have been removed: *) fast_connect res state in add_removable_waiter l waiter; res end let rec nchoose_terminate res acc = function | [] -> fast_connect res (Return (List.rev acc)) | t :: l -> match (repr t).state with | Return x -> nchoose_terminate res (x :: acc) l | Fail _ as state -> fast_connect res state | _ -> nchoose_terminate res acc l let nchoose_sleep l = let res = temp_many l in let rec waiter = ref (Some handle_result) and handle_result state = waiter := None; remove_waiters l; nchoose_terminate res [] l in add_removable_waiter l waiter; res let nchoose l = let rec init = function | [] -> nchoose_sleep l | t :: l -> match (repr t).state with | Return x -> collect [x] l | Fail _ as state -> thread { state } | _ -> init l and collect acc = function | [] -> return (List.rev acc) | t :: l -> match (repr t).state with | Return x -> collect (x :: acc) l | Fail _ as state -> thread { state } | _ -> collect acc l in init l let rec nchoose_split_terminate res acc_terminated acc_sleeping = function | [] -> fast_connect res (Return (List.rev acc_terminated, List.rev acc_sleeping)) | t :: l -> match (repr t).state with | Return x -> nchoose_split_terminate res (x :: acc_terminated) acc_sleeping l | Fail _ as state -> fast_connect res state | _ -> nchoose_split_terminate res acc_terminated (t :: acc_sleeping) l let nchoose_split_sleep l = let res = temp_many l in let rec waiter = ref (Some handle_result) and handle_result state = waiter := None; remove_waiters l; nchoose_split_terminate res [] [] l in add_removable_waiter l waiter; res let nchoose_split l = let rec init acc_sleeping = function | [] -> nchoose_split_sleep l | t :: l -> match (repr t).state with | Return x -> collect [x] acc_sleeping l | Fail _ as state -> thread { state } | _ -> init (t :: acc_sleeping) l and collect acc_terminated acc_sleeping = function | [] -> return (List.rev acc_terminated, acc_sleeping) | t :: l -> match (repr t).state with | Return x -> collect (x :: acc_terminated) acc_sleeping l | Fail _ as state -> thread { state } | _ -> collect acc_terminated (t :: acc_sleeping) l in init [] l (* Return the nth ready thread, and cancel all others *) let rec cancel_and_nth_ready l n = match l with | [] -> assert false | t :: l -> match (repr t).state with | Sleep _ -> cancel t; cancel_and_nth_ready l n | _ -> if n > 0 then cancel_and_nth_ready l (n - 1) else begin List.iter cancel l; t end let pick l = let ready = ready_count l in if ready > 0 then if ready = 1 then (* Optimisation for the common case: *) cancel_and_nth_ready l 0 else cancel_and_nth_ready l (Random.State.int (Lazy.force random_state) ready) else begin let res = temp_many l in let rec waiter = ref (Some handle_result) and handle_result state = waiter := None; remove_waiters l; (* Cancel all other threads: *) List.iter cancel l; fast_connect res state in add_removable_waiter l waiter; res end let npick_sleep l = let res = temp_many l in let rec waiter = ref (Some handle_result) and handle_result state = waiter := None; remove_waiters l; List.iter cancel l; nchoose_terminate res [] l in add_removable_waiter l waiter; res let npick threads = let rec init = function | [] -> npick_sleep threads | t :: l -> match (repr t).state with | Return x -> collect [x] l | Fail _ as state -> List.iter cancel threads; thread { state } | _ -> init l and collect acc = function | [] -> List.iter cancel threads; return (List.rev acc) | t :: l -> match (repr t).state with | Return x -> collect (x :: acc) l | Fail _ as state -> List.iter cancel threads; thread { state } | _ -> collect acc l in init threads let join l = let res = temp_many l (* Number of threads still sleeping: *) and sleeping = ref 0 (* The state that must be returned: *) and return_state = ref state_return_unit in let handle_result state = begin match !return_state, state with | Return _, Fail _ -> return_state := state | _ -> () end; decr sleeping; (* All threads are terminated, we can wakeup the result: *) if !sleeping = 0 then fast_connect res !return_state in let rec init = function | [] -> if !sleeping = 0 then (* No thread is sleeping, returns immediately: *) thread { state = !return_state } else res | t :: rest -> match (repr t).state with | Sleep sleeper -> incr sleeping; add_immutable_waiter sleeper handle_result; init rest | Fail _ as state -> begin match !return_state with | Return _ -> return_state := state; init rest | _ -> init rest end | _ -> init rest in init l let ( ) t1 t2 = choose [t1; t2] let ( <&> ) t1 t2 = join [t1; t2] let finalize f g = try_bind f (fun x -> g () >>= fun () -> return x) (fun e -> g () >>= fun () -> fail e) let update_data key = function | Some _ as value -> current_data := Int_map.add key.id (fun () -> key.store <- value) !current_data | None -> current_data := Int_map.remove key.id !current_data let with_value key value f = let save = !current_data in let data = match value with | Some _ -> Int_map.add key.id (fun () -> key.store <- value) save | None -> Int_map.remove key.id save in current_data := data; try let result = f () in current_data := save; result with exn -> current_data := save; raise exn (* +-----------------------------------------------------------------+ | Paused threads | +-----------------------------------------------------------------+ *) let pause_hook = ref ignore let paused = Lwt_sequence.create () let paused_count = ref 0 let pause () = let waiter = add_task_r paused in incr paused_count; !pause_hook !paused_count; waiter let wakeup_paused () = if Lwt_sequence.is_empty paused then paused_count := 0 else begin let tmp = Lwt_sequence.create () in Lwt_sequence.transfer_r paused tmp; paused_count := 0; Lwt_sequence.iter_l (fun wakener -> wakeup wakener ()) tmp end let register_pause_notifier f = pause_hook := f let paused_count () = !paused_count (* +-----------------------------------------------------------------+ | Bakctrace support | +-----------------------------------------------------------------+ *) let backtrace_bind add_loc t f = let t = repr t in match t.state with | Return v -> f v | Fail exn -> thread { state = Fail(add_loc exn) } | Sleep sleeper -> let res = temp t in let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; connect res (try f v with exn -> fail (add_loc exn)) | Fail exn -> fast_connect res (Fail(add_loc exn)) | _ -> assert false); res | Repr _ -> assert false let backtrace_catch add_loc x f = let t = repr (try x () with exn -> fail exn) in match t.state with | Return _ -> thread t | Fail exn -> f (add_loc exn) | Sleep sleeper -> let res = temp t in let data = !current_data in add_immutable_waiter sleeper (function | Return _ as state -> fast_connect res state | Fail exn -> current_data := data; connect res (try f exn with exn -> fail (add_loc exn)) | _ -> assert false); res | Repr _ -> assert false let backtrace_try_bind add_loc x f g = let t = repr (try x () with exn -> fail exn) in match t.state with | Return v -> f v | Fail exn -> g (add_loc exn) | Sleep sleeper -> let res = temp t in let data = !current_data in add_immutable_waiter sleeper (function | Return v -> current_data := data; connect res (try f v with exn -> fail (add_loc exn)) | Fail exn -> current_data := data; connect res (try g exn with exn -> fail (add_loc exn)) | _ -> assert false); res | Repr _ -> assert false let backtrace_finalize add_loc f g = backtrace_try_bind add_loc f (fun x -> g () >>= fun () -> return x) (fun e -> g () >>= fun () -> fail (add_loc e)) (* +-----------------------------------------------------------------+ | Threads state query | +-----------------------------------------------------------------+ *) let rec is_sleeping_rec t = match t.state with | Return _ | Fail _ -> false | Sleep _ -> true | Repr t -> is_sleeping_rec t let is_sleeping t = is_sleeping_rec (thread_repr t) module State = struct type 'a state = | Return of 'a | Fail of exn | Sleep end let state t = match (repr t).state with | Return v -> State.Return v | Fail exn -> State.Fail exn | Sleep _ -> State.Sleep | Repr _ -> assert false include State module Infix = struct let (>>=) = (>>=) let (=<<) = (=<<) let (>|=) = (>|=) let (=|<) = (=|<) let (<&>) = (<&>) let () = () end lwt-2.5.2/src/core/lwt.mldylib000066400000000000000000000002711270742521300162340ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 88e56eb3d5ada92a39ce67a55de800cb) Lwt_condition Lwt_list Lwt Lwt_mutex Lwt_mvar Lwt_pool Lwt_sequence Lwt_stream Lwt_switch Lwt_pqueue # OASIS_STOP lwt-2.5.2/src/core/lwt.mli000066400000000000000000000417241270742521300153710ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt * Copyright (C) 2005-2008 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * 2009-2012 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (** 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 {!wakeup_exn}). When a thread is running, it executes as much as possible, and then returns (a value or an error) 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. *) (** {2 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 fail_with : string -> 'a t (** [fail_with msg] is a thread that fails with the exception [Failure msg]. *) val fail_invalid_arg : string -> 'a t (** [fail_invalid_arg msg] is a thread that fails with the exception [Invalid_argument msg]. *) 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 times. Note that [bind] will not propagate backtraces correctly. See <> for how to enable backtraces. *) 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] maps 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] *) (** {3 Pre-allocated threads} *) val return_unit : unit t (** [return_unit = return ()] *) val return_none : 'a option t (** [return_none = return None] *) val return_some : 'a -> 'a option t (** [return_some x = return (Some x)] *) val return_nil : 'a list t (** [return_nil = return \[\]] *) val return_true : bool t (** [return_true = return true] *) val return_false : bool t (** [return_false = return false] *) (** {2 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]. [key] is restored to its previous value after [f] terminates. *) (** {2 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 transforms the result into an Lwt thread. If [f] raises an exception, it is caught and converted to an Lwt exception. 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 incorrect: {[ wrap1 f (Hashtbl.find table key) ]} and should be written as: {[ 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 (** {2 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 chosen at random. Note: {!choose} leaves the local values of the current thread unchanged. *) val nchoose : 'a t list -> 'a list t (** [nchoose l] returns the value of all that have succcessfully terminated. If all threads are sleeping, it waits for at least one to terminates. If one the threads of [l] fails, [nchoose] fails with the same exception. Note: {!nchoose} leaves the local values of the current thread unchanged. *) val nchoose_split : 'a t list -> ('a list * 'a t list) t (** [nchoose_split l] does the same as {!nchoose} but also retrurns the list of threads that have not yet terminated. *) val join : unit t list -> unit t (** [join l] waits for all threads in [l] to terminate. If one of the threads fails, then [join l] will fails with the same exception as the first one to terminate. Note: {!join} leaves the local values of the current thread unchanged. *) val ( ) : 'a t -> 'a t -> 'a t (** [t t'] is the same as [choose [t; t']] *) val ( <&> ) : unit t -> unit t -> unit t (** [t <&> t'] is the same as [join [t; t']] *) val async : (unit -> 'a t) -> unit (** [async f] starts a thread without waiting for the result. If it fails (now or later), the exception is given to {!async_exception_hook}. You should use this function if you want to start a thread that might fail and don't care what its return value is, nor when it terminates (for instance, because it is looping). *) val ignore_result : 'a t -> unit (** [ignore_result t] is like [Pervasives.ignore t] except that: - if [t] already failed, it raises the exception now, - if [t] is sleeping and fails later, the exception will be given to {!async_exception_hook}. *) val async_exception_hook : (exn -> unit) ref (** Function called when a asynchronous exception is thrown. The default behavior is to print an error message with a backtrace if available and to exit the program. The behavior is undefined if this function raise an exception. See <> for how to enable backtraces. *) (** {2 Sleeping and resuming} *) type 'a u (** The type of thread wakeners. *) val wait : unit -> 'a t * 'a u (** [wait ()] is a pair of a thread which sleeps forever (unless it is resumed by one of the functions [wakeup], [wakeup_exn] below) and the corresponding wakener. This thread does not block the execution of the remainder of the program (except of course, if another thread tries to wait for its termination). *) val wakeup : 'a u -> 'a -> unit (** [wakeup t e] makes the sleeping thread [t] terminate and return the value of the expression [e]. *) val wakeup_exn : 'a u -> exn -> unit (** [wakeup_exn t e] makes the sleeping thread [t] fail with the exception [e]. *) val wakeup_later : 'a u -> 'a -> unit (** Same as {!wakeup} but it is not guaranteed that the thread will be woken up immediately. *) val wakeup_later_exn : 'a u -> exn -> unit (** Same as {!wakeup_exn} but it is not guaranteed that the thread will be woken up immediately. *) val waiter_of_wakener : 'a u -> 'a t (** Returns the thread associated to a wakener. *) type +'a result (** Either a value of type ['a], either an exception. *) val make_value : 'a -> 'a result (** [value x] creates a result containing the value [x]. *) val make_error : exn -> 'a result (** [error e] creates a result containing the exception [e]. *) val of_result : 'a result -> 'a t (** Returns a thread from a result. *) val wakeup_result : 'a u -> 'a result -> unit (** [wakeup_result t r] makes the sleeping thread [t] terminate with the result [r]. *) val wakeup_later_result : 'a u -> 'a result -> unit (** Same as {!wakeup_result} but it is not guaranteed that the thread will be woken up immediately. *) (** {2 Threads state} *) (** State of a thread *) type 'a state = | Return of 'a (** The thread which has successfully terminated *) | Fail of exn (** The thread raised an exception *) | Sleep (** The thread is sleeping *) val state : 'a t -> 'a state (** [state t] returns the state of a thread *) val is_sleeping : 'a t -> bool (** [is_sleeping t] returns [true] iff [t] is sleeping. *) (** {2 Cancelable threads} *) (** Cancelable threads are the same as regular threads except that they can be canceled. *) exception Canceled (** Canceled threads fails with this exception *) val task : unit -> 'a t * 'a u (** [task ()] is the same as [wait ()] except that threads created with [task] can be canceled. *) val on_cancel : 'a t -> (unit -> unit) -> unit (** [on_cancel t f] executes [f] when [t] is canceled. [f] will be executed before all other threads waiting on [t]. If [f] raises an exception it is given to {!async_exception_hook}. *) val add_task_r : 'a u Lwt_sequence.t -> 'a t (** [add_task_r seq] creates a sleeping thread, adds its wakener to the right of [seq] and returns its waiter. When the thread is canceled, it is removed from [seq]. *) val add_task_l : 'a u Lwt_sequence.t -> 'a t (** [add_task_l seq] creates a sleeping thread, adds its wakener to the left of [seq] and returns its waiter. When the thread is canceled, it is removed from [seq]. *) val cancel : 'a t -> unit (** [cancel t] cancels the threads [t]. This means that the deepest sleeping thread created with [task] and connected to [t] is woken up with the exception {!Canceled}. For example, in the following code: {[ let waiter, wakener = task () in cancel (waiter >> printl "plop") ]} [waiter] will be woken up with {!Canceled}. *) val pick : 'a t list -> 'a t (** [pick l] is the same as {!choose}, except that it cancels all sleeping threads when one terminates. Note: {!pick} leaves the local values of the current thread unchanged. *) val npick : 'a t list -> 'a list t (** [npick l] is the same as {!nchoose}, except that it cancels all sleeping threads when one terminates. Note: {!npick} leaves the local values of the current thread unchanged. *) val protected : 'a t -> 'a t (** [protected thread] creates a new cancelable thread which behave as [thread] except that cancelling it does not cancel [thread]. *) val no_cancel : 'a t -> 'a t (** [no_cancel thread] creates a thread which behave as [thread] except that it cannot be canceled. *) (** {2 Pause} *) val pause : unit -> unit t (** [pause ()] is a sleeping thread which is wake up on the next call to {!wakeup_paused}. A thread created with [pause] can be canceled. *) val wakeup_paused : unit -> unit (** [wakeup_paused ()] wakes up all threads which suspended themselves with {!pause}. This function is called by the scheduler, before entering the main loop. You usually do not have to call it directly, except if you are writing a custom scheduler. Note that if a paused thread resumes and pauses again, it will not be woken up at this point. *) val paused_count : unit -> int (** [paused_count ()] returns the number of currently paused threads. *) val register_pause_notifier : (int -> unit) -> unit (** [register_pause_notifier f] register a function [f] that will be called each time pause is called. The parameter passed to [f] is the new number of threads paused. It is usefull to be able to call {!wakeup_paused} when there is no scheduler *) (** {2 Misc} *) val on_success : 'a t -> ('a -> unit) -> unit (** [on_success t f] executes [f] when [t] terminates without failing. If [f] raises an exception it is given to {!async_exception_hook}. *) val on_failure : 'a t -> (exn -> unit) -> unit (** [on_failure t f] executes [f] when [t] terminates and fails. If [f] raises an exception it is given to {!async_exception_hook}. *) val on_termination : 'a t -> (unit -> unit) -> unit (** [on_termination t f] executes [f] when [t] terminates. If [f] raises an exception it is given to {!async_exception_hook}. *) val on_any : 'a t -> ('a -> unit) -> (exn -> unit) -> unit (** [on_any t f g] executes [f] or [g] when [t] terminates. If [f] or [g] raises an exception it is given to {!async_exception_hook}. *) (** Infix operators. You should open only this module. *) module Infix : sig 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 (>|=) : '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] *) 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']] *) end (**/**) (* The functions below are probably not useful for the casual user. They provide the basic primitives on which can be built multi- threaded libraries such as Lwt_unix. *) val poll : 'a t -> 'a option (* [poll e] returns [Some v] if the thread [e] is terminated and returned the value [v]. If the thread failed with some exception, this exception is raised. If the thread is still running, [poll e] returns [None] without blocking. *) val apply : ('a -> 'b t) -> 'a -> 'b t (* [apply f e] apply the function [f] to the expression [e]. If an exception is raised during this application, it is caught and the resulting thread fails with this exception. *) (* Q: Could be called 'glue' or 'trap' or something? *) val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t lwt-2.5.2/src/core/lwt.mllib000066400000000000000000000002711270742521300156770ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 88e56eb3d5ada92a39ce67a55de800cb) Lwt_condition Lwt_list Lwt Lwt_mutex Lwt_mvar Lwt_pool Lwt_sequence Lwt_stream Lwt_switch Lwt_pqueue # OASIS_STOP lwt-2.5.2/src/core/lwt_condition.ml000066400000000000000000000045771270742521300172730ustar00rootroot00000000000000(******************************************************************************) (* Lightweight thread library for OCaml * 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.Infix type 'a t = 'a Lwt.u Lwt_sequence.t let create = Lwt_sequence.create let wait ?mutex cvar = let waiter = Lwt.add_task_r cvar in let () = match mutex with | Some m -> Lwt_mutex.unlock m | None -> () in Lwt.finalize (fun () -> waiter) (fun () -> match mutex with | Some m -> Lwt_mutex.lock m | None -> Lwt.return_unit) let signal cvar arg = try Lwt.wakeup_later (Lwt_sequence.take_l cvar) arg with Lwt_sequence.Empty -> () let broadcast cvar arg = let wakeners = Lwt_sequence.fold_r (fun x l -> x :: l) cvar [] in Lwt_sequence.iter_node_l Lwt_sequence.remove cvar; List.iter (fun wakener -> Lwt.wakeup_later wakener arg) wakeners lwt-2.5.2/src/core/lwt_condition.mli000066400000000000000000000062011270742521300174260ustar00rootroot00000000000000(******************************************************************************) (* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_condition ****************************************************************************** * Copyright (c) 2009, Metaweb Technologies, Inc. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (** Conditions *) (** Condition variables to synchronize between threads. *) type 'a t (** Condition variable type. The type parameter denotes the type of value propagated from notifier to waiter. *) val create : unit -> 'a t (** [create ()] creates a new condition variable. *) val wait : ?mutex:Lwt_mutex.t -> 'a t -> 'a Lwt.t (** [wait mutex condvar] will cause the current thread to block, awaiting notification for a condition variable, [condvar]. If provided, the [mutex] must have been previously locked (within the scope of [Lwt_mutex.with_lock], for example) and is temporarily unlocked until the condition is notified. Upon notification, [mutex] is re-locked before [wait] returns and the thread's activity is resumed. When the awaited condition is notified, the value parameter passed to [notify] is returned. *) val signal : 'a t -> 'a -> unit (** [signal condvar value] notifies that a condition is ready. A single waiting thread will be awoken and will receive the notification value which will be returned from [wait]. Note that condition notification is not "sticky", i.e. if there is no waiter when [notify] is called, the notification will be missed and the value discarded. *) val broadcast : 'a t -> 'a -> unit (** [broadcast condvar value] notifies all waiting threads. Each will be awoken in turn and will receive the same notification value. *) lwt-2.5.2/src/core/lwt_list.ml000066400000000000000000000131561270742521300162510ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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.Infix let rec iter_s f l = match l with | [] -> Lwt.return_unit | x :: l -> f x >>= fun () -> iter_s f l let rec iter_p f l = match l with | [] -> Lwt.return_unit | x :: l -> let tx = f x and tl = iter_p f l in tx >>= fun () -> tl let rec iteri_s i f l = match l with | [] -> Lwt.return_unit | x :: l -> f i x >>= fun () -> iteri_s (i + 1) f l let iteri_s f l = iteri_s 0 f l let rec iteri_p i f l = match l with | [] -> Lwt.return_unit | x :: l -> let tx = f i x and tl = iteri_p (i + 1) f l in tx >>= fun () -> tl let iteri_p f l = iteri_p 0 f l let rec map_s f l = match l with | [] -> Lwt.return_nil | x :: l -> f x >>= fun x -> map_s f l >|= fun l -> x :: l let rec map_p f l = match l with | [] -> Lwt.return_nil | x :: l -> let tx = f x and tl = map_p f l in tx >>= fun x -> tl >|= fun l -> x :: l let rec filter_map_s f l = match l with | [] -> Lwt.return_nil | x :: l -> f x >>= function | Some x -> filter_map_s f l >|= fun l -> x :: l | None -> filter_map_s f l let rec filter_map_p f l = match l with | [] -> Lwt.return_nil | x :: l -> let tx = f x and tl = filter_map_p f l in tx >>= function | Some x -> tl >|= fun l -> x :: l | None -> tl let rec mapi_s i f l = match l with | [] -> Lwt.return_nil | x :: l -> f i x >>= fun x -> mapi_s (i + 1) f l >|= fun l -> x :: l let mapi_s f l = mapi_s 0 f l let rec mapi_p i f l = match l with | [] -> Lwt.return_nil | x :: l -> let tx = f i x and tl = mapi_p (i + 1) f l in tx >>= fun x -> tl >|= fun l -> x :: l let mapi_p f l = mapi_p 0 f l let rec rev_map_append_s acc f l = match l with | [] -> Lwt.return acc | x :: l -> f x >>= fun x -> rev_map_append_s (x :: acc) f l let rev_map_s f l = rev_map_append_s [] f l let rec rev_map_append_p acc f l = match l with | [] -> acc | x :: l -> rev_map_append_p (f x >>= fun x -> acc >|= fun l -> x :: l) f l let rev_map_p f l = rev_map_append_p Lwt.return_nil f l let rec fold_left_s f acc l = match l with | [] -> Lwt.return acc | x :: l -> f acc x >>= fun acc -> fold_left_s f acc l let rec fold_right_s f l acc = match l with | [] -> Lwt.return acc | x :: l -> fold_right_s f l acc >>= fun acc -> f x acc let rec for_all_s f l = match l with | [] -> Lwt.return_true | x :: l -> f x >>= function | true -> for_all_s f l | false -> Lwt.return_false let rec for_all_p f l = match l with | [] -> Lwt.return_true | x :: l -> let tx = f x and tl = for_all_p f l in tx >>= fun bx -> tl >|= fun bl -> bx && bl let rec exists_s f l = match l with | [] -> Lwt.return_false | x :: l -> f x >>= function | true -> Lwt.return_true | false -> exists_s f l let rec exists_p f l = match l with | [] -> Lwt.return_false | x :: l -> let tx = f x and tl = exists_p f l in tx >>= fun bx -> tl >|= fun bl -> bx || bl let rec find_s f l = match l with | [] -> Lwt.fail Not_found | x :: l -> f x >>= function | true -> Lwt.return x | false -> find_s f l let rec filter_s f l = match l with | [] -> Lwt.return_nil | x :: l -> f x >>= function | true -> filter_s f l >|= fun l -> x :: l | false -> filter_s f l let rec filter_p f l = match l with | [] -> Lwt.return_nil | x :: l -> let tx = f x and tl = filter_p f l in tx >>= fun bx -> tl >|= fun l -> if bx then x :: l else l let return_nil_nil = Lwt.return ([], []) let rec partition_s f l = match l with | [] -> return_nil_nil | x :: l -> f x >>= fun bx -> partition_s f l >|= fun (l_l, l_r) -> if bx then (x :: l_l, l_r) else (l_l, x :: l_r) let rec partition_p f l = match l with | [] -> return_nil_nil | x :: l -> let tx = f x and tl = partition_p f l in tx >>= fun bx -> tl >|= fun (l_l, l_r) -> if bx then (x :: l_l, l_r) else (l_l, x :: l_r) lwt-2.5.2/src/core/lwt_list.mli000066400000000000000000000050411270742521300164140ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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}. *) (** {2 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 iteri_s : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t val iteri_p : (int -> '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 mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val mapi_p : (int -> '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 (** {2 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 (** {2 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 filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t lwt-2.5.2/src/core/lwt_mutex.ml000066400000000000000000000033351270742521300164360ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_mutex * Copyright (C) 2005-2008 Jérôme 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.Infix type t = { mutable locked : bool; mutable waiters : unit Lwt.u Lwt_sequence.t } let create () = { locked = false; waiters = Lwt_sequence.create () } let rec lock m = if m.locked then Lwt.add_task_r m.waiters else begin m.locked <- true; Lwt.return_unit end let unlock m = if m.locked then begin if Lwt_sequence.is_empty m.waiters then m.locked <- false else (* We do not use [Lwt.wakeup] here to avoid a stack overflow when unlocking a lot of threads. *) Lwt.wakeup_later (Lwt_sequence.take_l m.waiters) () end let with_lock m f = lock m >>= fun () -> Lwt.finalize f (fun () -> unlock m; Lwt.return_unit) let is_locked m = m.locked let is_empty m = Lwt_sequence.is_empty m.waiters lwt-2.5.2/src/core/lwt_mutex.mli000066400000000000000000000045111270742521300166040ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_mutex * Copyright (C) 2005-2008 Jérôme 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 immediately - 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 woken up in the same order they try to lock the mutex *) val unlock : t -> unit (** [unlock mutex] unlock the mutex if no threads is waiting on it. Otherwise it will eventually removes the first one and resumes it. *) val is_locked : t -> bool (** [locked mutex] returns whether [mutex] is currently locked *) val is_empty : t -> bool (** [is_empty mutex] returns [true] if they are no thread waiting on the mutex, and [false] otherwise *) val with_lock : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t (** [with_lock lock f] is used to lock a mutex within a block scope. The function [f ()] is called with the mutex locked, and its result is returned from the call to {with_lock}. If an exception is raised from f, the mutex is also unlocked before the scope of {with_lock} is exited. *) lwt-2.5.2/src/core/lwt_mvar.ml000066400000000000000000000056731270742521300162500ustar00rootroot00000000000000(******************************************************************************) (* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_mon ****************************************************************************** * Copyright (c) 2009, Metaweb Technologies, Inc. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) type 'a t = { mutable contents : 'a option; (* Current contents *) writers : ('a * unit Lwt.u) Lwt_sequence.t; (* Threads waiting to put a value *) readers : 'a Lwt.u Lwt_sequence.t; (* Threads waiting for a value *) } let create_empty () = { contents = None; writers = Lwt_sequence.create (); readers = Lwt_sequence.create () } let create v = { contents = Some v; writers = Lwt_sequence.create (); readers = Lwt_sequence.create () } let put mvar v = match mvar.contents with | None -> begin match Lwt_sequence.take_opt_l mvar.readers with | None -> mvar.contents <- Some v | Some w -> Lwt.wakeup_later w v end; Lwt.return_unit | Some _ -> let (res, w) = Lwt.task () in let node = Lwt_sequence.add_r (v, w) mvar.writers in Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); res let take mvar = match mvar.contents with | Some v -> begin match Lwt_sequence.take_opt_l mvar.writers with | Some(v', w) -> mvar.contents <- Some v'; Lwt.wakeup_later w () | None -> mvar.contents <- None end; Lwt.return v | None -> Lwt.add_task_r mvar.readers lwt-2.5.2/src/core/lwt_mvar.mli000066400000000000000000000055541270742521300164170ustar00rootroot00000000000000(******************************************************************************) (* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_mon ****************************************************************************** * Copyright (c) 2009, Metaweb Technologies, Inc. * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (** Mailbox variables *) (** "Mailbox" variables implement a synchronising variable, used for communication between concurrent threads. This code adapted from {{:http://eigenclass.org/hiki.rb?cmd=view&p=lightweight-threads-with-lwt}Comparing lightweight threads (eigenclass.org)} *) type 'a t (** The type of a mailbox variable. Mailbox variables are used to communicate values between threads in a synchronous way. The type parameter specifies the type of the value propagated from [put] to [take]. *) val create : 'a -> 'a t (** [create v] creates a new mailbox variable containing value [v]. *) val create_empty : unit -> 'a t (** [create ()] creates a new empty mailbox variable. *) val put : 'a t -> 'a -> unit Lwt.t (** [put mvar value] puts a value into a mailbox variable. This value will remain in the mailbox until [take] is called to remove it. If the mailbox is not empty, the current thread will block until it is emptied. *) val take : 'a t -> 'a Lwt.t (** [take mvar] will take any currently available value from the mailbox variable. If no value is currently available, the current thread will block, awaiting a value to be [put] by another thread. *) lwt-2.5.2/src/core/lwt_pool.ml000066400000000000000000000100701270742521300162370ustar00rootroot00000000000000(* Lwt * http://www.ocsigen.org * Copyright (C) 2008 Jérôme Vouillon * 2012 Jérémie Dimino * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later version. * See COPYING file for details. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Lwt.Infix (* XXX Close after some timeout ... *) type 'a t = { create : unit -> 'a Lwt.t; (* Create a new pool member. *) check : 'a -> (bool -> unit) -> unit; (* Check a member when its use failed. *) validate : 'a -> bool Lwt.t; (* Validate old pool members. *) max : int; (* Size of the pool. *) mutable count : int; (* Number of elements in hte pool. *) list : 'a Queue.t; (* Available pool members. *) waiters : 'a Lwt.u Lwt_sequence.t; (* Threads waiting for a member. *) } let create m ?(check = fun _ f -> f true) ?(validate = fun _ -> Lwt.return_true) create = { max = m; create = create; validate = validate; check = check; count = 0; list = Queue.create (); waiters = Lwt_sequence.create () } let create_member p = Lwt.catch (fun () -> (* Must be done before p.create to prevent other threads from creating new members if the limit is reached. *) p.count <- p.count + 1; p.create ()) (fun exn -> (* Creation failed, so don't increment count. *) p.count <- p.count - 1; Lwt.fail exn) (* Release a pool member. *) let release p c = match Lwt_sequence.take_opt_l p.waiters with | Some wakener -> (* A thread is waiting, give it the pool member. *) Lwt.wakeup_later wakener c | None -> (* No one is waiting, queue it. *) Queue.push c p.list (* Create a new member when one is thrown away. *) let replace_acquired p = match Lwt_sequence.take_opt_l p.waiters with | None -> (* No one is waiting, do not create a new member to avoid loosing an error if creation fails. *) p.count <- p.count - 1 | Some wakener -> Lwt.on_any (Lwt.apply p.create ()) (fun c -> Lwt.wakeup_later wakener c) (fun exn -> (* Creation failed, notify the waiter of the failure. *) p.count <- p.count - 1; Lwt.wakeup_later_exn wakener exn) let acquire p = if Queue.is_empty p.list then (* No more available member. *) if p.count < p.max then (* Limit not reached: create a new one. *) create_member p else (* Limit reached: wait for a free one. *) Lwt.add_task_r p.waiters else (* Take the first free member and validate it. *) let c = Queue.take p.list in Lwt.try_bind (fun () -> p.validate c) (function | true -> Lwt.return c | false -> (* Remove this member and create a new one. *) p.count <- p.count - 1; create_member p) (fun e -> (* Validation failed: create a new member if at least one thread is waiting. *) replace_acquired p; Lwt.fail e) (* Release a member when its use failed. *) let checked_release p c = p.check c begin fun ok -> if ok then release p c else replace_acquired p end let use p f = acquire p >>= fun c -> Lwt.catch (fun () -> let t = f c in t >>= fun _ -> release p c; t) (fun e -> checked_release p c; Lwt.fail e) lwt-2.5.2/src/core/lwt_pool.mli000066400000000000000000000037241270742521300164200ustar00rootroot00000000000000(* Lwt * http://www.ocsigen.org * Copyright (C) 2008 Jérôme Vouillon * 2012 Jérémie Dimino * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later version. * See COPYING file for details. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) (** Creating pools (for example pools of connections to a database). *) (** Instead of creating a new connection each time you need one, keep a pool of opened connections and reuse opened connections that are free. *) type 'a t (** Type of pools *) val create : int -> ?check : ('a -> (bool -> unit) -> unit) -> ?validate : ('a -> bool Lwt.t) -> (unit -> 'a Lwt.t) -> 'a t (** [create n ?check ?validate f] creates a new pool with at most [n] members. [f] is the function to use to create a new pool member. An element of the pool is validated by the optional [validate] function before its {!use}. Invalid elements are re-created. The optional function [check] is called after a [use] of an element failed. It must call its argument exactly once with [true] if the pool member is still valid and [false] otherwise. *) val use : 'a t -> ('a -> 'b Lwt.t) -> 'b Lwt.t (** [use p f] takes one free member of the pool [p] and gives it to the function [f]. *) lwt-2.5.2/src/core/lwt_pqueue.ml000066400000000000000000000061521270742521300166000ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_pqueue * Copyright (C) 1999-2004 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) module type OrderedType = sig type t val compare: t -> t -> int end module type S = sig type elt type t val empty: t val is_empty: t -> bool val add: elt -> t -> t val union: t -> t -> t val find_min: t -> elt val lookup_min: t -> elt option val remove_min: t -> t val size: t -> int end module Make(Ord: OrderedType) : (S with type elt = Ord.t) = struct type elt = Ord.t type t = tree list and tree = Node of elt * int * tree list let root (Node (x, _, _)) = x let rank (Node (_, r, _)) = r let link (Node (x1, r1, c1) as t1) (Node (x2, r2, c2) as t2) = let c = Ord.compare x1 x2 in if c <= 0 then Node (x1, r1 + 1, t2::c1) else Node(x2, r2 + 1, t1::c2) let rec ins t = function [] -> [t] | (t'::_) as ts when rank t < rank t' -> t::ts | t'::ts -> ins (link t t') ts let empty = [] let is_empty ts = ts = [] let add x ts = ins (Node (x, 0, [])) ts let rec union ts ts' = match ts, ts' with ([], _) -> ts' | (_, []) -> ts | (t1::ts1, t2::ts2) -> if rank t1 < rank t2 then t1 :: union ts1 (t2::ts2) else if rank t2 < rank t1 then t2 :: union (t1::ts1) ts2 else ins (link t1 t2) (union ts1 ts2) let rec find_min = function [] -> raise Not_found | [t] -> root t | t::ts -> let x = find_min ts in let c = Ord.compare (root t) x in if c < 0 then root t else x let lookup_min t = try Some(find_min t) with Not_found -> None let rec get_min = function [] -> assert false | [t] -> (t, []) | t::ts -> let (t', ts') = get_min ts in let c = Ord.compare (root t) (root t') in if c < 0 then (t, ts) else (t', t::ts') let remove_min = function [] -> raise Not_found | ts -> let (Node (x, r, c), ts) = get_min ts in union (List.rev c) ts let rec size l = let rec sizetree (Node (_,_,tl)) = 1 + size tl in List.fold_left (fun s t -> s + sizetree t) 0 l end lwt-2.5.2/src/core/lwt_pqueue.mli000066400000000000000000000025671270742521300167570ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_pqueue * Copyright (C) 1999-2004 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) module type OrderedType = sig type t val compare: t -> t -> int end module type S = sig type elt type t val empty: t val is_empty: t -> bool val add: elt -> t -> t val union: t -> t -> t val find_min: t -> elt val lookup_min: t -> elt option val remove_min: t -> t val size: t -> int end module Make(Ord: OrderedType) : S with type elt = Ord.t lwt-2.5.2/src/core/lwt_sequence.ml000066400000000000000000000133111270742521300170770ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 let find_node_l f seq = let rec loop curr = if curr != seq then let node = node_of_seq curr in if node.node_active then if f node.node_data then node else loop node.node_next else loop node.node_next else raise Not_found in loop seq.next let find_node_r f seq = let rec loop curr = if curr != seq then let node = node_of_seq curr in if node.node_active then if f node.node_data then node else loop node.node_prev else loop node.node_prev else raise Not_found in loop seq.prev let find_node_opt_l f seq = try Some (find_node_l f seq) with Not_found -> None let find_node_opt_r f seq = try Some (find_node_r f seq) with Not_found -> None lwt-2.5.2/src/core/lwt_sequence.mli000066400000000000000000000124131270742521300172520ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 *) (** {2 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. *) (** {2 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. *) (** {2 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] *) val find_node_opt_l : ('a -> bool) -> 'a t -> 'a node option (** [find_node_opt_l f s] returns [Some x], where [x] is the first node of [s] starting from the left that satisfies [f] or [None] if none exists. *) val find_node_opt_r : ('a -> bool) -> 'a t -> 'a node option (** [find_node_opt_r f s] returns [Some x], where [x] is the first node of [s] starting from the right that satisfies [f] or [None] if none exists. *) val find_node_l : ('a -> bool) -> 'a t -> 'a node (** [find_node_l f s] returns the first node of [s] starting from the left that satisfies [f] or raises [Not_found] if none exists. *) val find_node_r : ('a -> bool) -> 'a t -> 'a node (** [find_node_r f s] returns the first node of [s] starting from the right that satisfies [f] or raises [Not_found] if none exists. *) lwt-2.5.2/src/core/lwt_stream.ml000066400000000000000000000702061270742521300165700ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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.Infix exception Closed exception Full exception Empty type 'a result = | Value of 'a | Error of exn (* A node in a queue of pending data. *) type 'a node = { mutable next : 'a node; (* Next node in the queue. For the last node it points to itself. *) mutable data : 'a option; (* Data of this node. For the last node it is always [None]. *) } (* Note: a queue for an exhausted stream is represented by a node containing [None] followed by a node with itself as next and [None] as data. *) let new_node () = let rec node = { next = node; data = None } in node (* Type of a stream source using a function to create new elements. *) type 'a from = { from_create : unit -> 'a option Lwt.t; (* Function used to create new elements. *) mutable from_thread : unit Lwt.t; (* Thread which: - wait for the thread returned by the last call to [from_next], - add the next element to the end of the queue. If it is a sleeping thread, then it must be used instead of creating a new one with [from_create]. *) } (* Type of a stream source for push streams. *) type push = { mutable push_signal : unit Lwt.t; (* Thread signaled when a new element is added to the stream. *) mutable push_waiting : bool; (* Is a thread waiting on [push_signal] ? *) mutable push_external : Obj.t; (* Reference to an external source. *) } (* Type of a stream source for bounded-push streams. *) type 'a push_bounded = { mutable pushb_signal : unit Lwt.t; (* Thread signaled when a new element is added to the stream. *) mutable pushb_waiting : bool; (* Is a thread waiting on [pushb_signal] ? *) mutable pushb_size : int; (* Size of the queue. *) mutable pushb_count : int; (* Current length of the queue. *) mutable pushb_pending : 'a option; (* The next element to push if a thread blocked on push. We store it here to be sure it will be the first element to be added when space becomes available. *) mutable pushb_push_waiter : unit Lwt.t; mutable pushb_push_wakener : unit Lwt.u; (* Thread blocked on push. *) mutable pushb_external : Obj.t; (* Reference to an external source. *) } (* Source of a stream. *) type 'a source = | From of 'a from | From_direct of (unit -> 'a option) | Push of push | Push_bounded of 'a push_bounded type 'a t = { source : 'a source; (* The source of the stream. *) mutable node : 'a node; (* Pointer to first pending element, or to [last] if there is no pending element. *) last : 'a node ref; (* Node marking the end of the queue of pending elements. *) hooks : (unit -> unit) list ref; (* Functions called when the end of stream is reached. Hooks are shared between all clones. *) } class type ['a] bounded_push = object method size : int method resize : int -> unit method push : 'a -> unit Lwt.t method close : unit method count : int method blocked : bool method closed : bool method set_reference : 'a. 'a -> unit end (* The only difference between two clones is the pointer to the first pending element. *) let clone s = (match s.source with | Push_bounded _ -> invalid_arg "Lwt_stream.clone" | _ -> ()); { source = s.source; node = s.node; last = s.last; hooks = s.hooks; } let from f = let last = new_node () in { source = From { from_create = f; from_thread = Lwt.return_unit }; node = last; last = ref last; hooks = ref []; } let from_direct f = let last = new_node () in { source = From_direct f; node = last; last = ref last; hooks = ref []; } let on_termination s f = s.hooks := f :: !(s.hooks) let on_terminate = on_termination let of_list l = let l = ref l in from_direct (fun () -> match !l with | [] -> None | x :: l' -> l := l'; Some x) let of_array a = let len = Array.length a and i = ref 0 in from_direct (fun () -> if !i = len then None else begin let c = Array.unsafe_get a !i in incr i; Some c end) let of_string s = let len = String.length s and i = ref 0 in from_direct (fun () -> if !i = len then None else begin let c = String.unsafe_get s !i in incr i; Some c end) let create_with_reference () = (* Create the cell pointing to the end of the queue. *) let last = ref (new_node ()) in (* Create the source for notifications of new elements. *) let source, wakener_cell = let waiter, wakener = Lwt.wait () in ({ push_signal = waiter; push_waiting = false; push_external = Obj.repr () }, ref wakener) in (* Set to [true] when the end-of-stream is sent. *) let closed = ref false in let hooks = ref [] in (* The push function. It does not keep a reference to the stream. *) let push x = if !closed then raise Closed; if x = None then closed := true; (* Push the element at the end of the queue. *) let node = !last and new_last = new_node () in node.data <- x; node.next <- new_last; last := new_last; (* Send a signal if at least one thread is waiting for a new element. *) if source.push_waiting then begin source.push_waiting <- false; (* Update threads. *) let old_wakener = !wakener_cell in let new_waiter, new_wakener = Lwt.wait () in source.push_signal <- new_waiter; wakener_cell := new_wakener; (* Signal that a new value has been received. *) Lwt.wakeup_later old_wakener () end; (* Do this at the end in case one of the function raise an exception. *) if x = None then List.iter (fun f -> f ()) !hooks in ({ source = Push source; node = !last; last = last; hooks = hooks }, push, fun x -> source.push_external <- Obj.repr x) let create () = let source, push, _ = create_with_reference () in (source, push) (* Add the pending element to the queue and notify the blocked pushed. Precondition: info.pushb_pending = Some _ This does not modify info.pushb_count. *) let notify_pusher info last = (* Push the element at the end of the queue. *) let node = !last and new_last = new_node () in node.data <- info.pushb_pending; node.next <- new_last; last := new_last; (* Clear pending element. *) info.pushb_pending <- None; (* Wakeup the pusher. *) let old_wakener = info.pushb_push_wakener in let waiter, wakener = Lwt.task () in info.pushb_push_waiter <- waiter; info.pushb_push_wakener <- wakener; Lwt.wakeup_later old_wakener () class ['a] bounded_push_impl (info : 'a push_bounded) wakener_cell last hooks = object val mutable closed = false method size = info.pushb_size method resize size = if size < 0 then invalid_arg "Lwt_stream.bounded_push#resize"; info.pushb_size <- size; if info.pushb_count < info.pushb_size && info.pushb_pending <> None then begin info.pushb_count <- info.pushb_count + 1; notify_pusher info last end method push x = if closed then Lwt.fail Closed else if info.pushb_pending <> None then Lwt.fail Full else if info.pushb_count >= info.pushb_size then begin info.pushb_pending <- Some x; Lwt.catch (fun () -> info.pushb_push_waiter) (fun exn -> match exn with | Lwt.Canceled -> info.pushb_pending <- None; let waiter, wakener = Lwt.task () in info.pushb_push_waiter <- waiter; info.pushb_push_wakener <- wakener; Lwt.fail exn | _ -> Lwt.fail exn) end else begin (* Push the element at the end of the queue. *) let node = !last and new_last = new_node () in node.data <- Some x; node.next <- new_last; last := new_last; info.pushb_count <- info.pushb_count + 1; (* Send a signal if at least one thread is waiting for a new element. *) if info.pushb_waiting then begin info.pushb_waiting <- false; (* Update threads. *) let old_wakener = !wakener_cell in let new_waiter, new_wakener = Lwt.wait () in info.pushb_signal <- new_waiter; wakener_cell := new_wakener; (* Signal that a new value has been received. *) Lwt.wakeup_later old_wakener () end; Lwt.return_unit end method close = if not closed then begin closed <- true; let node = !last and new_last = new_node () in node.data <- None; node.next <- new_last; last := new_last; if info.pushb_pending <> None then begin info.pushb_pending <- None; Lwt.wakeup_later_exn info.pushb_push_wakener Closed end; (* Send a signal if at least one thread is waiting for a new element. *) if info.pushb_waiting then begin info.pushb_waiting <- false; let old_wakener = !wakener_cell in (* Signal that a new value has been received. *) Lwt.wakeup_later old_wakener () end; List.iter (fun f -> f ()) !hooks end method count = info.pushb_count method blocked = info.pushb_pending <> None method closed = closed method set_reference : 'a. 'a -> unit = fun x -> info.pushb_external <- Obj.repr x end let create_bounded size = if size < 0 then invalid_arg "Lwt_stream.create_bounded"; (* Create the cell pointing to the end of the queue. *) let last = ref (new_node ()) in let hooks = ref [] in (* Create the source for notifications of new elements. *) let info, wakener_cell = let waiter, wakener = Lwt.wait () in let push_waiter, push_wakener = Lwt.task () in ({ pushb_signal = waiter; pushb_waiting = false; pushb_size = size; pushb_count = 0; pushb_pending = None; pushb_push_waiter = push_waiter; pushb_push_wakener = push_wakener; pushb_external = Obj.repr () }, ref wakener) in ({ source = Push_bounded info; node = !last; last = last; hooks = hooks }, new bounded_push_impl info wakener_cell last hooks) (* Wait for a new element to be added to the queue of pending element of the stream. *) let feed s = match s.source with | From from -> (* There is already a thread started to create a new element, wait for this one to terminate. *) if Lwt.is_sleeping from.from_thread then Lwt.protected from.from_thread else begin (* Otherwise request a new element. *) let thread = from.from_create () >>= fun x -> (* Push the element to the end of the queue. *) let node = !(s.last) and new_last = new_node () in node.data <- x; node.next <- new_last; s.last := new_last; if x = None then List.iter (fun f -> f ()) !(s.hooks); Lwt.return_unit in (* Allow other threads to access this thread. *) from.from_thread <- thread; Lwt.protected thread end | From_direct f -> let x = f () in (* Push the element to the end of the queue. *) let node = !(s.last) and new_last = new_node () in node.data <- x; node.next <- new_last; s.last := new_last; if x = None then List.iter (fun f -> f ()) !(s.hooks); Lwt.return_unit | Push push -> push.push_waiting <- true; Lwt.protected push.push_signal | Push_bounded push -> push.pushb_waiting <- true; Lwt.protected push.pushb_signal (* Remove [node] from the top of the queue, or do nothing if it was already consumed. Precondition: node.data <> None *) let consume s node = if node == s.node then begin s.node <- node.next; match s.source with | Push_bounded info -> if info.pushb_pending = None then info.pushb_count <- info.pushb_count - 1 else notify_pusher info s.last | _ -> () end let rec peek_rec s node = if node == !(s.last) then feed s >>= fun () -> peek_rec s node else Lwt.return node.data let peek s = peek_rec s s.node let rec npeek_rec node acc n s = if n <= 0 then Lwt.return (List.rev acc) else if node == !(s.last) then feed s >>= fun () -> npeek_rec node acc n s else match node.data with | Some x -> npeek_rec node.next (x :: acc) (n - 1) s | None -> Lwt.return (List.rev acc) let npeek n s = npeek_rec s.node [] n s let rec get_rec s node = if node == !(s.last) then feed s >>= fun () -> get_rec s node else begin if node.data <> None then consume s node; Lwt.return node.data end let get s = get_rec s s.node let rec get_exn_rec s node = if node == !(s.last) then Lwt.try_bind (fun () -> feed s) (fun () -> get_exn_rec s node) (fun exn -> Lwt.return (Some (Error exn))) else match node.data with | Some value -> consume s node; Lwt.return (Some (Value value)) | None -> Lwt.return_none let map_exn s = from (fun () -> get_exn_rec s s.node) let rec nget_rec node acc n s = if n <= 0 then Lwt.return (List.rev acc) else if node == !(s.last) then feed s >>= fun () -> nget_rec node acc n s else match s.node.data with | Some x -> consume s node; nget_rec node.next (x :: acc) (n - 1) s | None -> Lwt.return (List.rev acc) let nget n s = nget_rec s.node [] n s let rec get_while_rec node acc f s = if node == !(s.last) then feed s >>= fun () -> get_while_rec node acc f s else match node.data with | Some x -> let test = f x in if test then begin consume s node; get_while_rec node.next (x :: acc) f s end else Lwt.return (List.rev acc) | None -> Lwt.return (List.rev acc) let get_while f s = get_while_rec s.node [] f s let rec get_while_s_rec node acc f s = if node == !(s.last) then feed s >>= fun () -> get_while_s_rec node acc f s else match node.data with | Some x -> begin f x >>= function | true -> consume s node; get_while_s_rec node.next (x :: acc) f s | false -> Lwt.return (List.rev acc) end | None -> Lwt.return (List.rev acc) let get_while_s f s = get_while_s_rec s.node [] f s let rec next_rec s node = if node == !(s.last) then feed s >>= fun () -> next_rec s node else match node.data with | Some x -> consume s node; Lwt.return x | None -> Lwt.fail Empty let next s = next_rec s s.node let rec last_new_rec node x s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> last_new_rec node x s | Lwt.Fail exn -> Lwt.fail exn | Lwt.Sleep -> Lwt.return x else match node.data with | Some x -> consume s node; last_new_rec node.next x s | None -> Lwt.return x let last_new s = let node = s.node in if node == !(s.last) then let thread = next s in match Lwt.state thread with | Lwt.Return x -> last_new_rec node x s | _ -> thread else match node.data with | Some x -> consume s node; last_new_rec node.next x s | None -> Lwt.fail Empty let rec to_list_rec node acc s = if node == !(s.last) then feed s >>= fun () -> to_list_rec node acc s else match node.data with | Some x -> consume s node; to_list_rec node.next (x :: acc) s | None -> Lwt.return (List.rev acc) let to_list s = to_list_rec s.node [] s let rec to_string_rec node buf s = if node == !(s.last) then feed s >>= fun () -> to_string_rec node buf s else match node.data with | Some x -> consume s node; Buffer.add_char buf x; to_string_rec node.next buf s | None -> Lwt.return (Buffer.contents buf) let to_string s = to_string_rec s.node (Buffer.create 128) s let junk s = let node = s.node in if node == !(s.last) then begin feed s >>= fun () -> if node.data <> None then consume s node; Lwt.return_unit end else begin if node.data <> None then consume s node; Lwt.return_unit end let rec njunk_rec node n s = if n <= 0 then Lwt.return_unit else if node == !(s.last) then feed s >>= fun () -> njunk_rec node n s else match node.data with | Some _ -> consume s node; njunk_rec node.next (n - 1) s | None -> Lwt.return_unit let njunk n s = njunk_rec s.node n s let rec junk_while_rec node f s = if node == !(s.last) then feed s >>= fun () -> junk_while_rec node f s else match node.data with | Some x -> let test = f x in if test then begin consume s node; junk_while_rec node.next f s end else Lwt.return_unit | None -> Lwt.return_unit let junk_while f s = junk_while_rec s.node f s let rec junk_while_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> junk_while_s_rec node f s else match node.data with | Some x -> begin f x >>= function | true -> consume s node; junk_while_s_rec node.next f s | false -> Lwt.return_unit end | None -> Lwt.return_unit let junk_while_s f s = junk_while_s_rec s.node f s let rec junk_old_rec node s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> junk_old_rec node s | Lwt.Fail exn -> Lwt.fail exn | Lwt.Sleep -> Lwt.return_unit else match node.data with | Some _ -> consume s node; junk_old_rec node.next s | None -> Lwt.return_unit let junk_old s = junk_old_rec s.node s let rec get_available_rec node acc s = if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> get_available_rec node acc s | Lwt.Fail exn -> raise exn | Lwt.Sleep -> List.rev acc else match node.data with | Some x -> consume s node; get_available_rec node.next (x :: acc) s | None -> List.rev acc let get_available s = get_available_rec s.node [] s let rec get_available_up_to_rec node acc n s = if n <= 0 then List.rev acc else if node == !(s.last) then let thread = feed s in match Lwt.state thread with | Lwt.Return _ -> get_available_up_to_rec node acc n s | Lwt.Fail exn -> raise exn | Lwt.Sleep -> List.rev acc else match s.node.data with | Some x -> consume s node; get_available_up_to_rec node.next (x :: acc) (n - 1) s | None -> List.rev acc let get_available_up_to n s = get_available_up_to_rec s.node [] n s let rec is_empty s = if s.node == !(s.last) then feed s >>= fun () -> is_empty s else Lwt.return (s.node.data = None) let map f s = from (fun () -> get s >|= function | Some x -> let x = f x in Some x | None -> None) let map_s f s = from (fun () -> get s >>= function | Some x -> f x >|= (fun x -> Some x) | None -> Lwt.return_none) let filter f s = let rec next () = let t = get s in t >>= function | Some x -> let test = f x in if test then t else next () | None -> Lwt.return_none in from next let filter_s f s = let rec next () = let t = get s in t >>= function | Some x -> begin f x >>= function | true -> t | false -> next () end | None -> t in from next let filter_map f s = let rec next () = get s >>= function | Some x -> let x = f x in (match x with | Some _ -> Lwt.return x | None -> next ()) | None -> Lwt.return_none in from next let filter_map_s f s = let rec next () = get s >>= function | Some x -> let t = f x in (t >>= function | Some _ -> t | None -> next ()) | None -> Lwt.return_none in from next let map_list f s = let pendings = ref [] in let rec next () = match !pendings with | [] -> (get s >>= function | Some x -> let l = f x in pendings := l; next () | None -> Lwt.return_none) | x :: l -> pendings := l; Lwt.return (Some x) in from next let map_list_s f s = let pendings = ref [] in let rec next () = match !pendings with | [] -> (get s >>= function | Some x -> f x >>= fun l -> pendings := l; next () | None -> Lwt.return_none) | x :: l -> pendings := l; Lwt.return (Some x) in from next let flatten s = map_list (fun l -> l) s let rec fold_rec node f s acc = if node == !(s.last) then feed s >>= fun () -> fold_rec node f s acc else match node.data with | Some x -> consume s node; let acc = f x acc in fold_rec node.next f s acc | None -> Lwt.return acc let fold f s acc = fold_rec s.node f s acc let rec fold_s_rec node f s acc = if node == !(s.last) then feed s >>= fun () -> fold_s_rec node f s acc else match node.data with | Some x -> consume s node; f x acc >>= fun acc -> fold_s_rec node.next f s acc | None -> Lwt.return acc let fold_s f s acc = fold_s_rec s.node f s acc let rec iter_rec node f s = if node == !(s.last) then feed s >>= fun () -> iter_rec node f s else match node.data with | Some x -> consume s node; let () = f x in iter_rec node.next f s | None -> Lwt.return_unit let iter f s = iter_rec s.node f s let rec iter_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> iter_s_rec node f s else match node.data with | Some x -> consume s node; f x >>= fun () -> iter_s_rec node.next f s | None -> Lwt.return_unit let iter_s f s = iter_s_rec s.node f s let rec iter_p_rec node f s = if node == !(s.last) then feed s >>= fun () -> iter_p_rec node f s else match node.data with | Some x -> consume s node; Lwt.join [f x; iter_p_rec node.next f s] | None -> Lwt.return_unit let iter_p f s = iter_p_rec s.node f s let rec find_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_rec node f s else match node.data with | Some x as opt -> consume s node; let test = f x in if test then Lwt.return opt else find_rec node.next f s | None -> Lwt.return_none let find f s = find_rec s.node f s let rec find_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_s_rec node f s else match node.data with | Some x as opt -> begin consume s node; f x >>= function | true -> Lwt.return opt | false -> find_s_rec node.next f s end | None -> Lwt.return_none let find_s f s = find_s_rec s.node f s let rec find_map_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_map_rec node f s else match node.data with | Some x -> consume s node; let x = f x in if x = None then find_map_rec node.next f s else Lwt.return x | None -> Lwt.return_none let find_map f s = find_map_rec s.node f s let rec find_map_s_rec node f s = if node == !(s.last) then feed s >>= fun () -> find_map_s_rec node f s else match node.data with | Some x -> consume s node; let t = f x in (t >>= function | None -> find_map_s_rec node.next f s | Some _ -> t) | None -> Lwt.return_none let find_map_s f s = find_map_s_rec s.node f s let rec combine s1 s2 = let next () = let t1 = get s1 and t2 = get s2 in t1 >>= fun n1 -> t2 >>= fun n2 -> match n1, n2 with | Some x1, Some x2 -> Lwt.return (Some(x1, x2)) | _ -> Lwt.return_none in from next let append s1 s2 = let current_s = ref s1 in let rec next () = let t = get !current_s in t >>= function | Some _ -> t | None -> if !current_s == s2 then Lwt.return_none else begin current_s := s2; next () end in from next let concat s_top = let current_s = ref (from (fun () -> Lwt.return_none)) in let rec next () = let t = get !current_s in t >>= function | Some _ -> t | None -> get s_top >>= function | Some s -> current_s := s; next () | None -> Lwt.return_none in from next let choose streams = let source s = (s, get s >|= fun x -> (s, x)) in let streams = ref (List.map source streams) in let rec next () = match !streams with | [] -> Lwt.return_none | l -> Lwt.choose (List.map snd l) >>= fun (s, x) -> let l = List.remove_assq s l in match x with | Some _ -> streams := source s :: l; Lwt.return x | None -> streams := l; next () in from next let parse s f = (match s.source with | Push_bounded _ -> invalid_arg "Lwt_stream.parse" | _ -> ()); let node = s.node in Lwt.catch (fun () -> f s) (fun exn -> s.node <- node; Lwt.fail exn) let hexdump stream = let buf = Buffer.create 80 and num = ref 0 in from begin fun _ -> nget 16 stream >>= function | [] -> Lwt.return_none | l -> Buffer.clear buf; Printf.bprintf buf "%08x| " !num; num := !num + 16; let rec bytes pos = function | [] -> blanks pos | x :: l -> if pos = 8 then Buffer.add_char buf ' '; Printf.bprintf buf "%02x " (Char.code x); bytes (pos + 1) l and blanks pos = if pos < 16 then begin if pos = 8 then Buffer.add_string buf " " else Buffer.add_string buf " "; blanks (pos + 1) end in bytes 0 l; Buffer.add_string buf " |"; List.iter (fun ch -> Buffer.add_char buf (if ch >= '\x20' && ch <= '\x7e' then ch else '.')) l; Buffer.add_char buf '|'; Lwt.return (Some(Buffer.contents buf)) end lwt-2.5.2/src/core/lwt_stream.mli000066400000000000000000000264051270742521300167430ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 *) (** {2 Construction} *) val from : (unit -> 'a option Lwt.t) -> 'a t (** [from f] creates an stream from the given input function. [f] is called each time more input is needed, and the stream ends when [f] returns [None]. *) val from_direct : (unit -> 'a option) -> 'a t (** [from_direct f] does the same as {!from} but with a function that does not return a thread. It is better than wrapping [f] into a function which returns a thread. *) exception Closed (** Exception raised by the push function of a push-stream when pushing an element after the end of stream ([= None]) have been pushed. *) val create : unit -> 'a t * ('a option -> unit) (** [create ()] returns a new stream and a push function. *) val create_with_reference : unit -> 'a t * ('a option -> unit) * ('b -> unit) (** [create_with_reference ()] returns a new stream and a push function. The last function allows a reference to be set to an external source. This prevents the external source from being garbage collected. For example, to convert a reactive event to a stream: {[ let stream, push, set_ref = Lwt_stream.create_with_reference () in set_ref (map_event push event) ]} *) exception Full (** Exception raised by the push function of a bounded push-stream when the stream queue is full and a thread is already waiting to push an element. *) (** Type of sources for bounded push-streams. *) class type ['a] bounded_push = object method size : int (** Size of the stream. *) method resize : int -> unit (** Change the size of the stream queue. Note that the new size can smaller than the current stream queue size. It raises [Invalid_argument] if [size < 0]. *) method push : 'a -> unit Lwt.t (** Pushes a new element to the stream. If the stream is full then it will block until one element is consumed. If another thread is already blocked on {!push}, it raises {!Full}. *) method close : unit (** Closes the stream. Any thread currently blocked on {!push} will fail with {!Closed}. *) method count : int (** Number of elements in the stream queue. *) method blocked : bool (** Is a thread is blocked on {!push} ? *) method closed : bool (** Is the stream closed ? *) method set_reference : 'a. 'a -> unit (** Set the reference to an external source. *) end val create_bounded : int -> 'a t * 'a bounded_push (** [create_bounded size] returns a new stream and a bounded push source. The stream can hold a maximum of [size] elements. When this limit is reached, pushing a new element will block until one is consumed. Note that you cannot clone or parse (with {!parse}) a bounded stream. These functions will raise [Invalid_argument] if you try to do so. It raises [Invalid_argument] if [size < 0]. *) val of_list : 'a list -> 'a t (** [of_list l] creates a stream returning all elements of [l] *) val of_array : 'a array -> 'a t (** [of_array a] creates a stream returning all elements of [a] *) val of_string : string -> char t (** [of_string str] creates a stream returning all characters of [str] *) val clone : 'a t -> 'a t (** [clone st] clone the given stream. Operations on each stream will not affect the other. For example: {[ # let st1 = Lwt_stream.of_list [1; 2; 3];; val st1 : int Lwt_stream.t = # let st2 = Lwt_stream.clone st1;; val st2 : int Lwt_stream.t = # lwt x = Lwt_stream.next st1;; val x : int = 1 # lwt y = Lwt_stream.next st2;; val y : int = 1 ]} It raises [Invalid_argument] if [st] is a bounded push-stream. *) (** {2 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 *) (** {2 Data retreival} *) exception Empty (** Exception raised when trying to retreive data from an empty stream. *) val peek : 'a t -> 'a option Lwt.t (** [peek st] returns the first element of the stream, if any, without removing it. *) val npeek : int -> 'a t -> 'a list Lwt.t (** [npeek n st] returns at most the first [n] elements of [st], without removing them. *) val get : 'a t -> 'a option Lwt.t (** [get st] remove and returns the first element of the stream, if any. *) val nget : int -> 'a t -> 'a list Lwt.t (** [nget n st] remove and returns at most the first [n] elements of [st]. *) val get_while : ('a -> bool) -> 'a t -> 'a list Lwt.t val get_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a list Lwt.t (** [get_while f st] returns the longest prefix of [st] where all elements satisfy [f]. *) val next : 'a t -> 'a Lwt.t (** [next st] remove and returns the next element of the stream, of fail with {!Empty} if the stream is empty. *) val last_new : 'a t -> 'a Lwt.t (** [last_new st] returns the last element that can be obtained without sleepping, or wait for one if no one is already available. If fails with {!Empty} if the stream has no more elements *) val junk : 'a t -> unit Lwt.t (** [junk st] remove the first element of [st]. *) val njunk : int -> 'a t -> unit Lwt.t (** [njunk n st] removes at most the first [n] elements of the stream. *) val junk_while : ('a -> bool) -> 'a t -> unit Lwt.t val junk_while_s : ('a -> bool Lwt.t) -> 'a t -> unit Lwt.t (** [junk_while f st] removes all elements at the beginning of the streams which satisfy [f]. *) val junk_old : 'a t -> unit Lwt.t (** [junk_old st] removes all elements that are ready to be read without yeilding from [st]. For example the [read_password] function of [Lwt_read_line] use that to junk key previously typed by the user. *) val get_available : 'a t -> 'a list (** [get_available st] returns all available elements of [l] without blocking *) val get_available_up_to : int -> 'a t -> 'a list (** [get_available_up_to n st] returns up to [n] elements of [l] without blocking *) val is_empty : 'a t -> bool Lwt.t (** [is_empty st] returns wether the given stream is empty *) val on_termination : 'a t -> (unit -> unit) -> unit (** [on_termination st f] executes [f] when the end of the stream [st] is reached. Note that the stream may still contains elements if {!peek} or similar was used. *) val on_terminate : 'a t -> (unit -> unit) -> unit (* Deprecated, use [on_termination] *) (** {2 Stream transversal} *) (** Note: all the following functions are destructive. For example: {[ # let st1 = Lwt_stream.of_list [1; 2; 3];; val st1 : int Lwt_stream.t = # let st2 = Lwt_stream.map string_of_int st1;; val st2 : string Lwt_stream.t = # lwt x = Lwt_stream.next st1;; val x : int = 1 # lwt y = Lwt_stream.next st2;; val y : string = "2" ]} *) val choose : 'a t list -> 'a t (** [choose l] creates an stream from a list of streams. The resulting stream will returns elements returned by any stream of [l] in an unspecified order. *) val map : ('a -> 'b) -> 'a t -> 'b t val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t (** [map f st] maps the value returned by [st] with [f] *) val filter : ('a -> bool) -> 'a t -> 'a t val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t (** [filter f st] keeps only value [x] such that [f x] is [true] *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t (** [filter_map f st] filter and map [st] at the same time *) val map_list : ('a -> 'b list) -> 'a t -> 'b t val map_list_s : ('a -> 'b list Lwt.t) -> 'a t -> 'b t (** [map_list f st] applies [f] on each element of [st] and flattens the lists returned *) val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b Lwt.t val fold_s : ('a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t (** [fold f s x] fold_like function for streams. *) val iter : ('a -> unit) -> 'a t -> unit Lwt.t val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t (** [iter f s] iterates over all elements of the stream *) val find : ('a -> bool) -> 'a t -> 'a option Lwt.t val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t (** [find f s] find an element in a stream. *) val find_map : ('a -> 'b option) -> 'a t -> 'b option Lwt.t val find_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b option Lwt.t (** [find f s] find and map at the same time. *) val combine : 'a t -> 'b t -> ('a * 'b) t (** [combine s1 s2] combine two streams. The stream will ends when the first stream ends. *) val append : 'a t -> 'a t -> 'a t (** [append s1 s2] returns a stream which returns all elements of [s1], then all elements of [s2] *) val concat : 'a t t -> 'a t (** [concat st] returns the concatenation of all streams of [st]. *) val flatten : 'a list t -> 'a t (** [flatten st = map_list (fun l -> l) st] *) (** A value or an error. *) type 'a result = | Value of 'a | Error of exn val map_exn : 'a t -> 'a result t (** [map_exn s] returns a stream that captures all exceptions raised by the source of the stream (the function passed to {!from}). Note that for push-streams (as returned by {!create}) all elements of the mapped streams are values. *) (** {2 Parsing} *) val parse : 'a t -> ('a t -> 'b Lwt.t) -> 'b Lwt.t (** [parse st f] parses [st] with [f]. If [f] raise an exception, [st] is restored to its previous state. It raises [Invalid_argument] if [st] is a bounded push-stream. *) (** {2 Misc} *) val hexdump : char t -> string t (** [hexdump byte_stream] returns a stream which is the same as the output of [hexdump -C]. Basically, here is a simple implementation of [hexdump -C]: {[ let () = Lwt_main.run (Lwt_io.write_lines Lwt_io.stdout (Lwt_stream.hexdump (Lwt_io.read_lines Lwt_io.stdin))) ]} *) lwt-2.5.2/src/core/lwt_switch.ml000066400000000000000000000036571270742521300166040ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_switch * Copyright (C) 2010 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) exception Off type on_switch = { mutable hooks : (unit -> unit Lwt.t) list; } type state = | St_on of on_switch | St_off type t = { mutable state : state } let create () = { state = St_on { hooks = [] } } let is_on switch = match switch.state with | St_on _ -> true | St_off -> false let check = function | Some{ state = St_off } -> raise Off | _ -> () let add_hook switch hook = match switch with | Some { state = St_on os } -> os.hooks <- hook :: os.hooks | Some { state = St_off } -> raise Off | None -> () let add_hook_or_exec switch hook = match switch with | Some { state = St_on os } -> os.hooks <- hook :: os.hooks; Lwt.return_unit | Some { state = St_off } -> hook () | None -> Lwt.return_unit let turn_off switch = match switch.state with | St_on { hooks = hooks } -> switch.state <- St_off; Lwt_list.iter_p (fun hook -> Lwt.apply hook ()) hooks | St_off -> Lwt.return_unit lwt-2.5.2/src/core/lwt_switch.mli000066400000000000000000000070161270742521300167460ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 has 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, consider 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 call [f], [g] and [h] in parallel. You can simply do: {[ lwt idf = f () and idg = g () and idh = h () in ... ]} However, one may want 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 if we change the interface a little bit: {[ 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 ]} 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 terminate, then returns. If one of the hooks failed, it will fail with the exception raised by the hook. If the switch is already off, 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 raises {!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, [f] is called immediately. *) lwt-2.5.2/src/glib/000077500000000000000000000000001270742521300140355ustar00rootroot00000000000000lwt-2.5.2/src/glib/liblwt-glib_stubs.clib000066400000000000000000000001451270742521300203200ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 905c14a6abfdc3cc49bbc233df66ff99) lwt_glib_stubs.o # OASIS_STOP lwt-2.5.2/src/glib/lwt-glib.mldylib000066400000000000000000000001351270742521300171330ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: dfe8b7bfa132aa66ad19dbdbf3bcbaaa) Lwt_glib # OASIS_STOP lwt-2.5.2/src/glib/lwt-glib.mllib000066400000000000000000000001351270742521300165760ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: dfe8b7bfa132aa66ad19dbdbf3bcbaaa) Lwt_glib # OASIS_STOP lwt-2.5.2/src/glib/lwt_glib.ml000066400000000000000000000115571270742521300162030ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module glib * Copyright (C) 2009-2011 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) external glib_init : unit -> unit = "lwt_glib_init" external glib_stop : unit -> unit = "lwt_glib_stop" type state = | State_none | State_glib_into_lwt of (unit -> unit) Lwt_sequence.node * (unit -> unit) Lwt_sequence.node | State_lwt_into_glib of Lwt_engine.t let state = ref State_none (* +-----------------------------------------------------------------+ | Glib-based engine | +-----------------------------------------------------------------+ *) external glib_poll : (Unix.file_descr * bool * bool) list -> int -> int -> (Unix.file_descr * bool * bool) list = "lwt_glib_poll" class engine = object inherit Lwt_engine.poll_based method private poll fds timeout = glib_poll fds (List.length fds) (max (-1) (truncate (timeout *. 1000.))) end (* +-----------------------------------------------------------------+ | Glib --> Lwt based integration | +-----------------------------------------------------------------+ *) type watch = | Watch_none | Watch_in | Watch_out | Watch_in_out external glib_get_sources : unit -> Unix.file_descr array * watch array * float = "lwt_glib_get_sources" external glib_check : unit -> unit = "lwt_glib_check" external glib_mark_readable : int -> unit = "lwt_glib_mark_readable" "noalloc" external glib_mark_writable : int -> unit = "lwt_glib_mark_readable" "noalloc" let events = ref [] let check = ref true let enter () = if !check then begin check := false; let engine = Lwt_engine.get () in assert (!events = []); let fds, watches, timeout = glib_get_sources () in for i = 0 to Array.length fds - 1 do let fd = fds.(i) in match watches.(i) with | Watch_none -> () | Watch_in -> events := engine#on_readable fd (fun _ -> glib_mark_readable i) :: !events | Watch_out -> events := engine#on_writable fd (fun _ -> glib_mark_writable i) :: !events | Watch_in_out -> events := engine#on_readable fd (fun _ -> glib_mark_readable i) :: engine#on_writable fd (fun _ -> glib_mark_writable i) :: !events done; if timeout = 0. then ignore (Lwt_main.yield ()) else if timeout > 0. then events := engine#on_timer timeout false ignore :: !events end let leave () = if not !check then begin check := true; List.iter Lwt_engine.stop_event !events; events := []; glib_check () end (* +-----------------------------------------------------------------+ | Installation/removal | +-----------------------------------------------------------------+ *) let install ?(mode=`lwt_into_glib) () = match !state with | State_lwt_into_glib _ | State_glib_into_lwt _ -> () | State_none -> glib_init (); match mode with | `glib_into_lwt -> state := State_glib_into_lwt(Lwt_sequence.add_l enter Lwt_main.enter_iter_hooks, Lwt_sequence.add_l leave Lwt_main.leave_iter_hooks) | `lwt_into_glib -> let engine = Lwt_engine.get () in Lwt_engine.set ~destroy:false (new engine); state := State_lwt_into_glib engine let remove () = match !state with | State_none -> () | State_glib_into_lwt(node_enter, node_leave) -> state := State_none; Lwt_sequence.remove node_enter; Lwt_sequence.remove node_leave; List.iter Lwt_engine.stop_event !events; events := []; glib_stop () | State_lwt_into_glib engine -> Lwt_engine.set engine (* +-----------------------------------------------------------------+ | Misc | +-----------------------------------------------------------------+ *) external iter : bool -> unit = "lwt_glib_iter" external wakeup : unit -> unit = "lwt_glib_wakeup" lwt-2.5.2/src/glib/lwt_glib.mli000066400000000000000000000063111270742521300163440ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_glib * Copyright (C) 2009 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (** Glib integration *) (** This module allow to use Lwt in GTK applications. Here is what you have to do to make Lwt and GTK work together: - call {!install} at the beginning of your program (before or after GMain.init, it does not matter) - do not call GMain.main, write your application as a normal Lwt application instead. For example: {[ let () = Lwt_main.run ( (* Initializes GTK. *) ignore (GMain.init ()); (* Install Lwt<->Glib integration. *) Lwt_glib.install (); (* Thread which is wakeup when the main window is closed. *) let waiter, wakener = Lwt.wait () in (* Create a window. *) let window = GWindow.window () in (* Display something inside the window. *) ignore (GMisc.label ~text:"Hello, world!" ~packing:window#add ()); (* Quit when the window is closed. *) ignore (window#connect#destroy (Lwt.wakeup wakener)); (* Show the window. *) window#show (); (* Wait for it to be closed. *) waiter ) ]} *) val install : ?mode : [ `glib_into_lwt | `lwt_into_glib ] -> unit -> unit (** Install the Glib<->Lwt integration. If [mode] is [`glib_into_lwt] then glib will use the Lwt main loop, and if [mode] is [`lwt_into_glib] then Lwt will use the Glib main loop. [mode] defaults to [`lwt_into_glib] because it is more portable. [`glib_into_lwt] does not work under Windows and MacOS. If the integration is already active, this function does nothing. *) val remove : unit -> unit (** Remove the Glib<->Lwt integration. *) val iter : bool -> unit (** This function is not related to Lwt. [iter may_block] does the same as [Glib.Main.iteration may_block] but can safely be called in a multi-threaded program, it will not block the whole program. For example: {[ let main () = while true do Lwt_glib.iter true done let thread = Thread.create main () ]} Note: you can call this function only from one thread at a time, otherwise it will raise [Failure]. *) val wakeup : unit -> unit (** If one thread is blocking on {!iter}, then [wakeup ()] make {!iter} to return immediately. *) lwt-2.5.2/src/glib/lwt_glib_stubs.c000066400000000000000000000202561270742521300172310ustar00rootroot00000000000000/* Lightweight thread library for OCaml * 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. */ caml_enter_blocking_section(); g_main_context_get_poll_func(gc)(gpollfds, n_fds + count, timeout); caml_leave_blocking_section(); 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)) { gpollfd = gpollfds + i; src_result = caml_alloc_tuple(3); src = Field(node, 0); Field(src_result, 0) = Field(src, 0); revents = gpollfd->revents; if (revents & G_IO_HUP) { /* Treat HUP as ready. There's no point continuing to wait on this FD. */ if (gpollfd->events & G_IO_IN) revents |= G_IO_IN; if (gpollfd->events & G_IO_OUT) revents |= G_IO_OUT; } 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(value Unit) { gint timeout; int i; int events; GPollFD *gpollfd; CAMLparam0(); CAMLlocal3(fds, watches, result); g_main_context_dispatch(gc); g_main_context_prepare(gc, &max_priority); while (fds_count < (n_fds = g_main_context_query(gc, max_priority, &timeout, gpollfds, fds_count))) { free(gpollfds); fds_count = n_fds; gpollfds = lwt_unix_malloc(fds_count * sizeof (GPollFD)); } fds = caml_alloc_tuple(n_fds); watches = caml_alloc_tuple(n_fds); for (i = 0; i < n_fds; i++) { gpollfd = gpollfds + i; gpollfd->revents = 0; events = 0; if (gpollfd->events & G_IO_IN) events |= 1; if (gpollfd->events & G_IO_OUT) events |= 2; #if defined(LWT_ON_WINDOWS) /* On windows, glib file descriptors are handles */ Field(fds, i) = alloc_fd((HANDLE)gpollfd->fd); #else Field(fds, i) = Val_int(gpollfd->fd); if (gpollfd->fd < 0) events = 0; #endif Field(watches, i) = Val_int(events); } result = caml_alloc_tuple(3); Store_field(result, 0, fds); Store_field(result, 1, watches); Store_field(result, 2, caml_copy_double(timeout * 1e-3)); CAMLreturn(result); } /* +-----------------------------------------------------------------+ | Marking | +-----------------------------------------------------------------+ */ CAMLprim value lwt_glib_mark_readable(value i) { gpollfds[Int_val(i)].revents |= G_IO_IN; return Val_unit; } CAMLprim value lwt_glib_mark_writable(value i) { gpollfds[Int_val(i)].revents |= G_IO_OUT; return Val_unit; } /* +-----------------------------------------------------------------+ | Check | +-----------------------------------------------------------------+ */ CAMLprim value lwt_glib_check(value Unit) { g_main_context_check(gc, max_priority, gpollfds, n_fds); return Val_unit; } /* +-----------------------------------------------------------------+ | Initialization/stopping | +-----------------------------------------------------------------+ */ CAMLprim value lwt_glib_init(value Unit) { gc = g_main_context_default(); g_main_context_ref(gc); return Val_unit; } CAMLprim value lwt_glib_stop(value Unit) { 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(value Unit) { g_main_context_wakeup(g_main_context_default()); return Val_unit; } lwt-2.5.2/src/logger/000077500000000000000000000000001270742521300143775ustar00rootroot00000000000000lwt-2.5.2/src/logger/lwt-log.mldylib000066400000000000000000000001571270742521300173450ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: f78950e62c61aa06d5362364dc7ac207) Lwt_log_core Lwt_log_rules # OASIS_STOP lwt-2.5.2/src/logger/lwt-log.mllib000066400000000000000000000001571270742521300170100ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: f78950e62c61aa06d5362364dc7ac207) Lwt_log_core Lwt_log_rules # OASIS_STOP lwt-2.5.2/src/logger/lwt_log_core.ml000066400000000000000000000310071270742521300174110ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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.Infix (* Errors happening in this module are always logged to [stderr]: *) let log_intern fmt = Printf.eprintf ("Lwt_log: " ^^ fmt ^^ "\n%!") (* +-----------------------------------------------------------------+ | 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 [] let load_rules 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 match Lwt_log_rules.rules (Lexing.from_string str) with | None -> Printf.eprintf "Invalid contents of the LWT_LOG variable\n%!" | Some l -> rules := loop l let _ = match try Some(Sys.getenv "LWT_LOG") with Not_found -> None with | Some str -> load_rules 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 () let reset_rules () = rules := []; 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.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:Lwt.return let dispatch f = make ~output:(fun section level lines -> (f section level).lg_output section level lines) ~close:Lwt.return (* +-----------------------------------------------------------------+ | Templates | +-----------------------------------------------------------------+ *) type template = string let location_key = Lwt.new_key () let render ~buffer ~template ~section ~level ~message = let file, line, column = match Lwt.get location_key with | Some loc -> loc | None -> ("", -1, -1) in Buffer.add_substitute buffer (function | "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 -> Lwt.return_unit) ~close:Lwt.return let default = ref null (* +-----------------------------------------------------------------+ | 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 Lwt.fail 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 bt = if Printexc.backtrace_status () then Printexc.get_backtrace () else "" in let message = message ^ ": " ^ Printexc.to_string exn in let message = if String.length bt = 0 then message else message ^ "\nbacktrace:\n" ^ bt in Lwt.with_value location_key location (fun () -> logger.lg_output section level (split message)) else Lwt.return_unit let log_f ?exn ?section ?location ?logger ~level format = Printf.ksprintf (log ?exn ?section ?location ?logger ~level) format let ign_log ?exn ?section ?location ?logger ~level message = try ignore (log ?exn ?section ?location ?logger ~level message) with _ -> () let ign_log_f ?exn ?section ?location ?logger ~level format = Printf.ksprintf (ign_log ?exn ?section ?location ?logger ~level) format let debug ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Debug msg let debug_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (debug ?exn ?section ?location ?logger) fmt let info ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Info msg let info_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (info ?exn ?section ?location ?logger) fmt let notice ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Notice msg let notice_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (notice ?exn ?section ?location ?logger) fmt let warning ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Warning msg let warning_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (warning ?exn ?section ?location ?logger) fmt let error ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Error msg let error_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (error ?exn ?section ?location ?logger) fmt let fatal ?exn ?section ?location ?logger msg = log ?exn ?section ?location ?logger ~level:Fatal msg let fatal_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (fatal ?exn ?section ?location ?logger) fmt let ign_debug ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Debug msg let ign_debug_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_debug ?exn ?section ?location ?logger) fmt let ign_info ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Info msg let ign_info_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_info ?exn ?section ?location ?logger) fmt let ign_notice ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Notice msg let ign_notice_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_notice ?exn ?section ?location ?logger) fmt let ign_warning ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Warning msg let ign_warning_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_warning ?exn ?section ?location ?logger) fmt let ign_error ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Error msg let ign_error_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_error ?exn ?section ?location ?logger) fmt let ign_fatal ?exn ?section ?location ?logger msg = ign_log ?exn ?section ?location ?logger ~level:Fatal msg let ign_fatal_f ?exn ?section ?location ?logger fmt = Printf.ksprintf (ign_fatal ?exn ?section ?location ?logger) fmt lwt-2.5.2/src/logger/lwt_log_core.mli000066400000000000000000000307351270742521300175710ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 multiple destination at the same time - filtering logs per destination *) (** {2 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. *) 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 contents of the [LWT_LOG] environment variable, which must contain 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 contain ["debug"] for instance. By default, the following rule apply : ["* -> notice"] *) val string_of_level : level -> string val load_rules : string -> unit (** Reset the rules set when parsing the [LWT_LOG] environment variable using this string. *) 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 immediately and affects all sections for which the level has not been set explicitly with {!Section.set_level}. [pattern] may contains [*]. For example: {[ Lwt_log_core.add_rule "lwt*" Lwt_log_core.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_core.append_rule "*" Lwt_log_core.Info ]} *) val reset_rules : unit -> unit (** removes all rules. *) (** {2 Logging functions} *) val log : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> level : level -> string -> unit Lwt.t (** [log ?section ?logger ~level message] logs a message. [section] defaults to {!Section.main}. If [logger] is not specified, then the default one is used instead (see {!default}). If [exn] is provided, then its string representation (= [Printexc.to_string exn]) will be append to the message, and if possible the backtrace will also be logged. [location] contains the location of the logging directive, it is of the form [(file_name, line, column)]. *) val log_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> level : level -> ('a, unit, string, unit Lwt.t) format4 -> 'a (** [log_f] is the same as [log] except that it takes a format string *) val ign_log : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> level : level -> string -> unit (** Same as {!log} but ignore the resulting thread. *) val ign_log_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> level : level -> ('a, unit, string, unit) format4 -> 'a (** Same as {!log_f} but ignore the resulting thread. *) (** The following functions are the same as {!log} except that their name determines which level is used. For example {!info msg} is the same as {!log ~level:Info msg}. *) val debug : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t val debug_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a val ign_debug : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_debug_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) format4 -> 'a val info : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t val info_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a val ign_info : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_info_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) format4 -> 'a val notice : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t val notice_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a val ign_notice : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_notice_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) format4 -> 'a val warning : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t val warning_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a val ign_warning : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_warning_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) format4 -> 'a val error : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t val error_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a val ign_error : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_error_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) format4 -> 'a val fatal : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit Lwt.t val fatal_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit Lwt.t) format4 -> 'a val ign_fatal : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> string -> unit val ign_fatal_f : ?exn : exn -> ?section : section -> ?location : (string * int * int) -> ?logger : logger -> ('a, unit, string, unit) format4 -> 'a (** Sections *) module Section : sig type t = section val make : string -> section (** [make name] creates a section with the given name. Two calls to {!make} with the same name will return the same section object. *) val name : section -> string (** [name section] returns the name of [section]. *) val main : section (** The main section. It is the section used by default when no one is provided. *) val level : section -> level (** [level section] returns the logging level of [section]. *) val set_level : section -> level -> unit (** [set_level section] sets the logging level of the given section. Modifications of rules using {!add_rule} won't affect the level of this section after this operation. *) val reset_level : section -> unit (** [reset_level section] resets the level of [section] to its default value, i.e. to the value obtained by applying rules. *) end (** {2 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: - [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)"] - ["$(name): $(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. *) (** {2 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. If {!Lwt_core} is linked (in the package [lwt.unix]) the default logger sends all messages to standard error. Otherwise the default logger is {!null}. *) 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_core.dispatch (fun section level -> match Lwt_log_core.Section.name section, level with | "access", _ -> access_logger | _, Lwt_log_core.Error -> error_logger) ]} *) (** {2 Predefined loggers} *) val null : logger (** Logger which drops everything *) lwt-2.5.2/src/logger/lwt_log_rules.mli000066400000000000000000000022131270742521300177610ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 option (** [parse lexbuf] returns the list of rules contained in [lexbuf] or None in case of parsing error *) lwt-2.5.2/src/logger/lwt_log_rules.mll000066400000000000000000000030431270742521300177660ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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. *) {exception Parse_error} 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 { [] } | "" { raise Parse_error } and semi_colon_and_rules = parse | space* ";" { rules lexbuf } | space* eof { [] } | "" { raise Parse_error } { let rules buf = try Some (rules buf) with Parse_error -> None } lwt-2.5.2/src/preemptive/000077500000000000000000000000001270742521300153005ustar00rootroot00000000000000lwt-2.5.2/src/preemptive/lwt-preemptive.mldylib000066400000000000000000000001431270742521300216400ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 7a98b43f4d640061bceed7638c0c7efd) Lwt_preemptive # OASIS_STOP lwt-2.5.2/src/preemptive/lwt-preemptive.mllib000066400000000000000000000001431270742521300213030ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 7a98b43f4d640061bceed7638c0c7efd) Lwt_preemptive # OASIS_STOP lwt-2.5.2/src/preemptive/lwt_preemptive.ml000066400000000000000000000162451270742521300207100ustar00rootroot00000000000000(* Ocsigen * http://www.ocsigen.org * Module lwt_preemptive.ml * Copyright (C) 2005 Nataliya Guts, Vincent Balat, Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * 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.Infix let section = Lwt_log.Section.make "lwt(preemptive)" (* +-----------------------------------------------------------------+ | 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 -> Lwt.wakeup w worker (* Wait for worker to be available, then return it: *) let rec get_worker () = if not (Queue.is_empty workers) then Lwt.return (Queue.take workers) else if !threads_count < !max_threads then Lwt.return (make_worker ()) else Lwt.add_task_r waiters (* +-----------------------------------------------------------------+ | Initialisation, and dynamic parameters reset | +-----------------------------------------------------------------+ *) let get_bounds () = (!min_threads, !max_threads) let set_bounds (min, max) = if min < 0 || max < min then invalid_arg "Lwt_preemptive.set_bounds"; let diff = min - !threads_count in min_threads := min; max_threads := max; (* Launch new workers: *) for i = 1 to diff do add_worker (make_worker ()) done let initialized = ref false let init min max errlog = initialized := true; error_log := errlog; set_bounds (min, max) let simple_init () = if not !initialized then begin initialized := true; set_bounds (0, 4) end let nbthreads () = !threads_count let nbthreadsqueued () = Lwt_sequence.fold_l (fun _ x -> x + 1) waiters 0 let nbthreadsbusy () = !threads_count - Queue.length workers (* +-----------------------------------------------------------------+ | Detaching | +-----------------------------------------------------------------+ *) let init_result = Lwt.make_error (Failure "Lwt_preemptive.detach") let detach f args = simple_init (); let result = ref init_result in (* The task for the worker thread: *) let task () = try result := Lwt.make_value (f args) with exn -> result := Lwt.make_error exn in get_worker () >>= fun worker -> let waiter, wakener = Lwt.wait () in let id = Lwt_unix.make_notification ~once:true (fun () -> Lwt.wakeup_result wakener !result) in Lwt.finalize (fun () -> (* Send the id and the task to the worker: *) Event.sync (Event.send worker.task_channel (id, task)); waiter) (fun () -> 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; Lwt.return_unit) (* +-----------------------------------------------------------------+ | Running Lwt threads in the main thread | +-----------------------------------------------------------------+ *) type 'a result = | Value of 'a | Error of exn (* Queue of [unit -> unit Lwt.t] functions. *) let jobs = Queue.create () (* Mutex to protect access to [jobs]. *) let jobs_mutex = Mutex.create () let job_notification = Lwt_unix.make_notification (fun () -> (* Take the first job. The queue is never empty at this point. *) Mutex.lock jobs_mutex; let thunk = Queue.take jobs in Mutex.unlock jobs_mutex; ignore (thunk ())) let run_in_main f = let channel = Event.new_channel () in (* Create the job. *) let job () = (* Execute [f] and wait for its result. *) Lwt.try_bind f (fun ret -> Lwt.return (Value ret)) (fun exn -> Lwt.return (Error exn)) >>= fun result -> (* Send the result. *) Event.sync (Event.send channel result); Lwt.return_unit in (* Add the job to the queue. *) Mutex.lock jobs_mutex; Queue.add job jobs; Mutex.unlock jobs_mutex; (* Notify the main thread. *) Lwt_unix.send_notification job_notification; (* Wait for the result. *) match Event.sync (Event.receive channel) with | Value ret -> ret | Error exn -> raise exn lwt-2.5.2/src/preemptive/lwt_preemptive.mli000066400000000000000000000056171270742521300210620ustar00rootroot00000000000000(* Ocsigen * http://www.ocsigen.org * Module lwt_preemptive.ml * Copyright (C) 2005 Nataliya Guts, Vincent Balat, Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * 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 module allows to mix preemptive threads with [Lwt] cooperative threads. It maintains an extensible pool of preemptive threads to which you can detach computations. *) val detach : ('a -> 'b) -> 'a -> 'b Lwt.t (** detaches a computation to a preemptive thread. *) val run_in_main : (unit -> 'a Lwt.t) -> 'a (** [run_in_main f] executes [f] in the main thread, i.e. the one executing {!Lwt_main.run} and returns its result. *) val init : int -> int -> (string -> unit) -> unit (** [init min max log] initialises this module. i.e. it launches the minimum number of preemptive threads and starts the {b dispatcher}. @param min is the minimum number of threads @param max is the maximum number of threads @param log is used to log error messages If {!Lwt_preemptive} has already been initialised, this call only modify bounds and the log function, and return the dispatcher thread. *) val simple_init : unit -> unit (** [simple_init ()] does a {i simple initialization}. i.e. with default parameters if the library is not yet initialised. Note: this function is automatically called {!detach}. *) val get_bounds : unit -> int * int (** [get_bounds ()] returns the minimum and the maximum number of preemptive threads. *) val set_bounds : int * int -> unit (** [set_bounds (min, max)] set the minimum and the maximum number of preemptive threads. *) val set_max_number_of_threads_queued : int -> unit (** Sets the size of the waiting queue, if no more preemptive threads are available. When the queue is full, {!detach} will sleep until a thread is available. *) val get_max_number_of_threads_queued : unit -> int (** Returns the size of the waiting queue, if no more threads are available *) (**/**) val nbthreads : unit -> int val nbthreadsbusy : unit -> int val nbthreadsqueued : unit -> int lwt-2.5.2/src/react/000077500000000000000000000000001270742521300142165ustar00rootroot00000000000000lwt-2.5.2/src/react/lwt-react.mldylib000066400000000000000000000001361270742521300174760ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 32a5629747b679a5337d8e2a2a9b3615) Lwt_react # OASIS_STOP lwt-2.5.2/src/react/lwt-react.mllib000066400000000000000000000001361270742521300171410ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 32a5629747b679a5337d8e2a2a9b3615) Lwt_react # OASIS_STOP lwt-2.5.2/src/react/lwt_react.ml000066400000000000000000000313671270742521300165460ustar00rootroot00000000000000(* * lwt_react.ml * ------------ * Copyright : (c) 2011, Jérémie Dimino * Licence : BSD3 * * This file is a part of lwt. *) open Lwt.Infix type 'a event = 'a React.event type 'a signal = 'a React.signal module E = struct include React.E (* +---------------------------------------------------------------+ | Lwt-specific utilities | +---------------------------------------------------------------+ *) let finalise f _ = f () let with_finaliser f event = let r = ref () in Gc.finalise (finalise f) r; map (fun x -> ignore r; x) event let next ev = let waiter, wakener = Lwt.task () in let ev = map (fun x -> Lwt.wakeup wakener x) (once ev) in Lwt.on_cancel waiter (fun () -> stop ev); waiter let limit f e = (* Thread which prevent [e] to occur while it is sleeping *) let limiter = ref Lwt.return_unit in (* The occurence that is delayed until the limiter returns. *) let delayed = ref None in (* The resulting event. *) let event, push = create () in let iter = fmap (fun x -> if Lwt.state !limiter = Lwt.Sleep then begin (* The limiter is sleeping, we queue the event for later delivering. *) match !delayed with | Some cell -> (* An occurence is alreayd queued, replace it. *) cell := x; None | None -> let cell = ref x in delayed := Some cell; Lwt.on_success !limiter (fun () -> let x = !cell in delayed := None; push x); None end else begin (* Set the limiter for future events. *) limiter := f (); (* Send the occurence now. *) push x; None end) e in select [iter; event] let cancel_thread t () = Lwt.cancel t let from f = let event, push = create () in let rec loop () = f () >>= fun x -> push x; loop () in let t = Lwt.pause () >>= loop in with_finaliser (cancel_thread t) event let to_stream event = let stream, push, set_ref = Lwt_stream.create_with_reference () in set_ref (map (fun x -> push (Some x)) event); stream let of_stream stream = let event, push = create () in let t = Lwt.pause () >>= fun () -> Lwt_stream.iter push stream in with_finaliser (cancel_thread t) event let delay thread = match Lwt.poll thread with | Some e -> e | None -> let event, send = create () in Lwt.on_success thread (fun e -> send e; stop event); switch never event let keeped = ref [] let keep e = keeped := map ignore e :: !keeped (* +---------------------------------------------------------------+ | Event transofrmations | +---------------------------------------------------------------+ *) let run_p e = let event, push = create () in let iter = fmap (fun t -> Lwt.on_success t push; None) e in select [iter; event] let run_s e = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun t -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) e in select [iter; event] let map_p f e = let event, push = create () in let iter = fmap (fun x -> Lwt.on_success (f x) push; None) e in select [iter; event] let map_s f e = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) e in select [iter; event] let app_p ef e = let event, push = create () in let iter = fmap (fun (f, x) -> Lwt.on_success (f x) push; None) (app (map (fun f x -> (f, x)) ef) e) in select [iter; event] let app_s ef e = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun (f, x) -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (app (map (fun f x -> (f, x)) ef) e) in select [iter; event] let filter_p f e = let event, push = create () in let iter = fmap (fun x -> Lwt.on_success (f x) (function true -> push x | false -> ()); None) e in select [iter; event] let filter_s f e = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) e in select [iter; event] let fmap_p f e = let event, push = create () in let iter = fmap (fun x -> Lwt.on_success (f x) (function Some x -> push x | None -> ()); None) e in select [iter; event] let fmap_s f e = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) e in select [iter; event] let diff_s f e = let previous = ref None in let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun x -> match !previous with | None -> previous := Some x; None | Some y -> previous := Some x; Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push; None) e in select [iter; event] let accum_s ef acc = let acc = ref acc in let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun f -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc)) (fun x -> acc := x; push x); None) ef in select [iter; event] let fold_s f acc e = let acc = ref acc in let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc x)) (fun x -> acc := x; push x); None) e in select [iter; event] let rec rev_fold f acc = function | [] -> Lwt.return acc | x :: l -> rev_fold f acc l >>= fun acc -> f acc x let merge_s f acc el = let event, push = create () in let mutex = Lwt_mutex.create () in let iter = fmap (fun l -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (merge (fun acc x -> x :: acc) [] el) in select [iter; event] end module S = struct include React.S (* +---------------------------------------------------------------+ | Lwt-specific utilities | +---------------------------------------------------------------+ *) let finalise f _ = f () let with_finaliser f signal = let r = ref () in Gc.finalise (finalise f) r; map (fun x -> ignore r; x) signal let limit ?eq f s = (* Thread which prevent [s] to changes while it is sleeping *) let limiter = ref (f ()) in (* The occurence that is delayed until the limiter returns. *) let delayed = ref None in (* The resulting event. *) let event, push = E.create () in let iter = E.fmap (fun x -> if Lwt.state !limiter = Lwt.Sleep then begin (* The limiter is sleeping, we queue the event for later delivering. *) match !delayed with | Some cell -> (* An occurence is alreayd queued, replace it. *) cell := x; None | None -> let cell = ref x in delayed := Some cell; Lwt.on_success !limiter (fun () -> let x = !cell in delayed := None; push x); None end else begin (* Set the limiter for future events. *) limiter := f (); (* Send the occurence now. *) push x; None end) (changes s) in hold ?eq (value s) (E.select [iter; event]) let keeped = ref [] let keep s = keeped := map ignore s :: !keeped (* +---------------------------------------------------------------+ | Signal transofrmations | +---------------------------------------------------------------+ *) let run_s ?eq s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun t -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> value s) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) let map_s ?eq f s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) let app_s ?eq sf s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun (f, x) -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s)) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) let filter_s ?eq f i s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in let x = value s in Lwt_mutex.with_lock mutex (fun () -> f x) >>= function | true -> Lwt.return (hold ?eq x (E.select [iter; event])) | false -> Lwt.return (hold ?eq i (E.select [iter; event])) let fmap_s ?eq f i s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= function | Some x -> Lwt.return (hold ?eq x (E.select [iter; event])) | None -> Lwt.return (hold ?eq i (E.select [iter; event])) let diff_s f s = let previous = ref (value s) in let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> let y = !previous in previous := x; Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push; None) (changes s) in E.select [iter; event] let sample_s f e s = E.map_s (fun x -> f x (value s)) e let accum_s ?eq ef i = hold ?eq i (E.accum_s ef i) let fold_s ?eq f i e = hold ?eq i (E.fold_s f i e) let rec rev_fold f acc = function | [] -> Lwt.return acc | x :: l -> rev_fold f acc l >>= fun acc -> f acc x let merge_s ?eq f acc sl = let s = merge (fun acc x -> x :: acc) [] sl in let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun l -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s)) >>= fun x -> Lwt.return (hold ?eq x (E.select [iter; event])) let l1_s ?eq f s1 = map_s ?eq f s1 let l2_s ?eq f s1 s2 = map_s ?eq (fun (x1, x2) -> f x1 x2) (l2 (fun x1 x2 -> (x1, x2)) s1 s2) let l3_s ?eq f s1 s2 s3 = map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) (l3 (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3) let l4_s ?eq f s1 s2 s3 s4 = map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) (l4 (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4) let l5_s ?eq f s1 s2 s3 s4 s5 = map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) (l5 (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5) let l6_s ?eq f s1 s2 s3 s4 s5 s6 = map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) (l6 (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6) (* +---------------------------------------------------------------+ | Monadic interface | +---------------------------------------------------------------+ *) let return = const let bind_s ?eq s f = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x -> Lwt.return (switch ?eq (hold ~eq:( == ) x (E.select [iter; event]))) end lwt-2.5.2/src/react/lwt_react.mli000066400000000000000000000144011270742521300167050ustar00rootroot00000000000000(* * lwt_react.mli * ------------- * Copyright : (c) 2011, Jérémie 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 (** {2 Lwt-specific utilities} *) val with_finaliser : (unit -> unit) -> 'a event -> 'a event (** [with_finaliser f e] returns an event [e'] which behave as [e], except that [f] is called when [e'] is garbage collected. *) val next : 'a event -> 'a Lwt.t (** [next e] returns the next occurrence of [e] *) val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event (** [limit f e] limits the rate of [e] with [f]. For example, to limit the rate of an event to 1 per second you can use: [limit (fun () -> Lwt_unix.sleep 1.0) event]. *) val from : (unit -> 'a Lwt.t) -> 'a event (** [from f] creates an event which occurs each time [f ()] returns a value. If [f] raises an exception, the event is just stopped. *) val to_stream : 'a event -> 'a Lwt_stream.t (** Creates a stream holding all values occurring on the given event *) val of_stream : 'a Lwt_stream.t -> 'a event (** [of_stream stream] creates an event which occurs each time a value is available on the stream. *) val delay : 'a event Lwt.t -> 'a event (** [delay thread] is an event which does not occurs until [thread] returns. Then it behaves as the event returned by [thread]. *) val keep : 'a event -> unit (** [keep e] keeps a reference to [e] so it will never be garbage collected. *) (** {2 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 (** {2 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. *) (** {2 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. *) (** {2 Threaded versions of React transformation functions} *) (** The following functions behave as their [React] counterpart, except that they takes functions that may yield. The [_s] suffix means that calls are serialized. *) val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'a signal -> 'b signal Lwt.t val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal Lwt.t val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal Lwt.t val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal Lwt.t val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'a signal -> 'b signal -> 'c signal Lwt.t val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal Lwt.t val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal Lwt.t val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal Lwt.t val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal Lwt.t val run_s : ?eq : ('a -> 'a -> bool) -> 'a Lwt.t signal -> 'a signal Lwt.t end lwt-2.5.2/src/simple_top/000077500000000000000000000000001270742521300152735ustar00rootroot00000000000000lwt-2.5.2/src/simple_top/lwt-simple-top.mldylib000066400000000000000000000001431270742521300215440ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: de6ce24e129acca71e8908d2344cd786) Lwt_simple_top # OASIS_STOP lwt-2.5.2/src/simple_top/lwt-simple-top.mllib000066400000000000000000000001431270742521300212070ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: de6ce24e129acca71e8908d2344cd786) Lwt_simple_top # OASIS_STOP lwt-2.5.2/src/simple_top/lwt_simple_top.ml000066400000000000000000000031141270742521300206650ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 use the enhanced toplevel (the utop project). *) open Lwt.Infix let read_input_non_interactive prompt buffer len = let rec loop i = if i = len then Lwt.return (i, false) else Lwt_io.read_char_opt Lwt_io.stdin >>= function | Some c -> Bytes.set buffer i c; if c = '\n' then Lwt.return (i + 1, false) else loop (i + 1) | None -> Lwt.return (i, true) in Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >>= fun () -> loop 0) let () = Toploop.read_interactive_input := read_input_non_interactive lwt-2.5.2/src/ssl/000077500000000000000000000000001270742521300137215ustar00rootroot00000000000000lwt-2.5.2/src/ssl/lwt-ssl.mldylib000066400000000000000000000001341270742521300167020ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: ab07ef30d9c1dd9dd2a1f2eef22e9d68) Lwt_ssl # OASIS_STOP lwt-2.5.2/src/ssl/lwt-ssl.mllib000066400000000000000000000001341270742521300163450ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: ab07ef30d9c1dd9dd2a1f2eef22e9d68) Lwt_ssl # OASIS_STOP lwt-2.5.2/src/ssl/lwt_ssl.ml000066400000000000000000000125431270742521300157470ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_ssl * Copyright (C) 2005-2008 Jérôme 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.Infix type t = Plain | SSL of Ssl.socket type socket = Lwt_unix.file_descr * t type uninitialized_socket = Lwt_unix.file_descr * Ssl.socket let ssl_socket (fd, kind) = match kind with | Plain -> None | SSL socket -> Some socket let ssl_socket_of_uninitialized_socket (fd, socket) = socket let is_ssl s = match snd s with Plain -> false | _ -> true let wrap_call f () = try f () with (Ssl.Connection_error err | Ssl.Accept_error err | Ssl.Read_error err | Ssl.Write_error err) as e -> match err with Ssl.Error_want_read -> raise Lwt_unix.Retry_read | Ssl.Error_want_write -> raise Lwt_unix.Retry_write | _ -> raise e let repeat_call fd f = try Lwt_unix.check_descriptor fd; Lwt.return (wrap_call f ()) with Lwt_unix.Retry_read -> Lwt_unix.register_action Lwt_unix.Read fd (wrap_call f) | Lwt_unix.Retry_write -> Lwt_unix.register_action Lwt_unix.Write fd (wrap_call f) | e -> Lwt.fail e (****) let plain fd = (fd, Plain) let embed_socket fd context = (fd, SSL(Ssl.embed_socket (Lwt_unix.unix_file_descr fd) context)) let embed_uninitialized_socket fd context = (fd, 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 ssl_accept_handshake (fd, socket) = Lwt.bind (repeat_call fd (fun () -> Ssl.accept socket)) (fun () -> Lwt.return (fd, SSL socket)) let ssl_perform_handshake (fd, socket) = 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 Ssl.read_into_bigarray s buf pos len 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 () -> Ssl.write_bigarray s buf pos len) let wait_read (fd, s) = match s with Plain -> Lwt_unix.wait_read fd | SSL _ -> Lwt_unix.yield () let wait_write (fd, s) = match s with Plain -> Lwt_unix.wait_write fd | SSL _ -> Lwt_unix.yield () let ssl_shutdown (fd, s) = match s with Plain -> Lwt.return_unit | SSL s -> repeat_call fd (fun () -> Ssl.shutdown s) let shutdown (fd, _) cmd = Lwt_unix.shutdown fd cmd let close (fd, _) = Lwt_unix.close fd let abort (fd, _) = Lwt_unix.abort fd let shutdown_and_close s = ssl_shutdown s >>= fun () -> Lwt.wrap2 shutdown s Unix.SHUTDOWN_ALL >>= fun () -> close s let out_channel_of_descr ?buffer s = Lwt_io.make ?buffer ~mode:Lwt_io.output ~close:(fun () -> shutdown_and_close s) (fun buf pos len -> write_bytes s buf pos len) let in_channel_of_descr ?buffer s = Lwt_io.make ?buffer ~mode:Lwt_io.input ~close:(fun () -> shutdown_and_close s) (fun buf pos len -> read_bytes s buf pos len) let get_fd (fd,socket) = fd let get_unix_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_unix_fd s) let getpeername s = Unix.getpeername (get_unix_fd s) lwt-2.5.2/src/ssl/lwt_ssl.mli000066400000000000000000000060551270742521300161210ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_ssl * Copyright (C) 2005-2008 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (** OCaml-SSL integration *) type socket (** Wrapper for SSL sockets. It is either a plain socket, either a real SSL socket. *) type uninitialized_socket (** Wrapper for SSL sockets that have not yet performed the SSL handshake. *) val ssl_socket : socket -> Ssl.socket option (** Returns the underlying SSL socket used for this wrapper. If it is a plain socket it returns [None]. *) val ssl_socket_of_uninitialized_socket : uninitialized_socket -> Ssl.socket (** Returns the underlying SSL socket used for this wrapper. *) val is_ssl : socket -> bool (** Are we using an SSL 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 embed_uninitialized_socket : Lwt_unix.file_descr -> Ssl.context -> uninitialized_socket val ssl_perform_handshake : uninitialized_socket -> socket Lwt.t (** Initiate a SSL/TLS handshake on the specified socket (used by clients). *) val ssl_accept_handshake : uninitialized_socket -> socket Lwt.t (** Await a SSL/TLS handshake on the specified socket (used by servers). *) 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 in_channel_of_descr : ?buffer:Lwt_bytes.t -> socket -> Lwt_io.input_channel val out_channel_of_descr : ?buffer:Lwt_bytes.t -> socket -> Lwt_io.output_channel val ssl_shutdown : socket -> unit Lwt.t val abort : socket -> exn -> unit val get_fd : socket -> Lwt_unix.file_descr val get_unix_fd : socket -> Unix.file_descr val getsockname : socket -> Unix.sockaddr val getpeername : socket -> Unix.sockaddr lwt-2.5.2/src/unix/000077500000000000000000000000001270742521300141035ustar00rootroot00000000000000lwt-2.5.2/src/unix/gen_stubs.ml000066400000000000000000000642721270742521300164410ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * * Copyright (C) 2012 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (* Script for generating C stubs for jobs. *) open Printf module StringMap = Map.Make(String) module StringSet = Set.Make(String) (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) (* Kind of caml values. *) type value_repr = | Val_int | Val_string | Val_block | Val_custom of string type caml_type = | Caml_void | Caml_int | Caml_int32 | Caml_int64 | Caml_bool | Caml_char | Caml_string | Caml_bytes | Caml_tuple of caml_type list | Caml_record of string * (string * caml_type) list | Caml_variant of string * (string * caml_type list) list | Caml_alias of string * caml_type | Caml_list of caml_type type c_type = | C_void | C_char | C_int | C_long | C_int_alias of string | C_long_alias of string | C_ptr of c_type | C_array of c_type * int | C_dyn_array of c_type type hint = | Hint_none | Hint_flag_list of (constructor_map * string option) list | Hint_table of (constructor_map * string option) list and constructor_map = | S of string | D of string * string type direction = | In | Out | In_out type abstract_type = { caml_type : caml_type; c_type : c_type; hint : hint; } type unix_error = | Uerror_errno | Uerror_result | Uerror_none type job = { includes : string list; name : string; params : (string * direction * abstract_type) list; result : abstract_type; uerror : unix_error; check : string option; exists_if : (bool * string) list; map64 : string list; } (* +-----------------------------------------------------------------+ | Configuration | +-----------------------------------------------------------------+ *) let prog_name = Filename.basename Sys.executable_name let log fmt = ksprintf (fun msg -> prerr_endline (prog_name ^ ": " ^ msg)) fmt (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) let unit = { c_type = C_int; caml_type = Caml_void; hint = Hint_none } let int = { c_type = C_int; caml_type = Caml_int; hint = Hint_none } let int32 = { c_type = C_int; caml_type = Caml_int32; hint = Hint_none } let int64 c_type = { c_type = c_type; caml_type = Caml_int64; hint = Hint_none } let long = { c_type = C_long; caml_type = Caml_int; hint = Hint_none } let char = { c_type = C_int; caml_type = Caml_char; hint = Hint_none } let string = { c_type = C_ptr C_char; caml_type = Caml_string; hint = Hint_none } let bool = { c_type = C_int; caml_type = Caml_bool; hint = Hint_none } let file_descr = { int with caml_type = Caml_alias ("Unix.file_descr", Caml_int) } let off_t = { long with c_type = C_long_alias "off_t" } let flag_list name c_type l = { c_type = c_type; caml_type = Caml_list (Caml_variant (name, List.map (function (S name, _) -> (name, []) | (D (name, _), _) -> (name, [])) l)); hint = Hint_flag_list l; } let table name c_type l = { c_type = c_type; caml_type = Caml_variant (name, List.map (function (S name, _) -> (name, []) | (D (name, _), _) -> (name, [])) l); hint = Hint_table l; } let filter_fst l = List.map snd (List.filter fst l) let open_flag = flag_list "Unix.open_flag" C_int [ S "O_RDONLY", None; S "O_WRONLY", None; S "O_RDWR", None; S "O_NONBLOCK", Some "O_NDELAY"; S "O_APPEND", None; S "O_CREAT", None; S "O_TRUNC", None; S "O_EXCL", None; S "O_NOCTTY", None; S "O_DSYNC", Some "0"; S "O_SYNC", Some "0"; S "O_RSYNC", Some "0"; S "O_SHARE_DELETE", None; ] let access_permission = flag_list "Unix.access_permission" C_int [ S "R_OK", None; S "W_OK", None; S "X_OK", None; S "F_OK", None; ] let seek_command = table "Unix.seek_command" C_int [ S "SEEK_SET", None; S "SEEK_CUR", None; S "SEEK_END", None; ] let flush_queue = table "Unix.flush_queue" C_int [ S "TCIFLUSH", None; S "TCOFLUSH", None; S "TCIOFLUSH", None; ] let flow_action = table "Unix.flow_action" C_int [ S "TCOOFF", None; S "TCOON", None; S "TCIOFF", None; S "TCION", None; ] (* +-----------------------------------------------------------------+ | Jobs | +-----------------------------------------------------------------+ *) let simple_unit includes name args = { includes = includes; name = name; params = List.map (fun (name, a_type) -> (name, In, a_type)) args; result = { int with caml_type = Caml_void }; uerror = Uerror_errno; check = Some "$(result) < 0"; exists_if = []; map64 = []; } type item = | Job of job | Seq of item list let rec map_jobs f item = match item with | Job job -> f job | Seq l -> Seq (List.map (map_jobs f) l) let path_and_fd = map_jobs (fun job -> if List.exists (fun (name, _, _) -> name = "path") job.params then Seq [ Job job; Job { job with name = "f" ^ job.name; params = List.map (fun ((name, _, _) as param) -> if name = "path" then ("fd", In, file_descr) else param) job.params; }; ] else Job job) let jobs = Seq [ Job (simple_unit ["unistd"] "close" [("fd", file_descr)]); Job (simple_unit ["unistd"] "unlink" [("path", string)]); Job (simple_unit ["unistd"] "chroot" [("path", string)]); Job (simple_unit ["unistd"] "rmdir" [("path", string)]); Job (simple_unit ["unistd"] "chdir" [("path", string)]); path_and_fd (Job (simple_unit ["sys/stat"] "chmod" [("path", string); ("mode", int)])); path_and_fd (Job { (simple_unit ["unistd"; "sys/types"] "truncate" [("path", string); ("offset", off_t)]) with map64 = ["offset"] }); path_and_fd (Job (simple_unit ["unistd"] "chown" [("path", string); ("ower", int); ("group", int)])); Job (simple_unit ["stdio"] "rename" [("oldpath", string); ("newpath", string)]); Job (simple_unit ["unistd"] "link" [("oldpath", string); ("newpath", string)]); Job (simple_unit ["unistd"] "symlink" [("oldpath", string); ("newpath", string)]); Job (simple_unit ["sys/stat"; "sys/types"] "mkdir" [("path", string); ("mode", int)]); Job (simple_unit ["sys/stat"; "sys/types"] "mkfifo" [("path", string); ("mode", int)]); Job (simple_unit ["unistd"] "access" [("path", string); ("mode", access_permission)]); Job (simple_unit ["unistd"] "fsync" [("fd", file_descr)]); Job { (simple_unit ["unistd"] "fdatasync" [("fd", file_descr)]) with exists_if = [(true, "HAVE_FDATASYNC")] }; Job { (simple_unit ["sys/types"; "unistd"] "lseek" [("fd", file_descr); ("offset", off_t); ("whence", seek_command)]) with result = off_t; check = Some "$(result) == (off_t)-1"; map64 = ["offset"; "result"]; }; Job { (simple_unit ["termios"; "unistd"] "tcdrain" [("fd", file_descr)]) with exists_if = [(false, "__ANDROID__")] }; Job (simple_unit ["termios"; "unistd"] "tcflush" [("fd", file_descr); ("queue", flush_queue)]); Job (simple_unit ["termios"; "unistd"] "tcflow" [("fd", file_descr); ("action", flow_action)]); Job (simple_unit ["termios"; "unistd"] "tcsendbreak" [("fd", file_descr); ("duration", int)]); ] (* +-----------------------------------------------------------------+ | Code generation | +-----------------------------------------------------------------+ *) let rec c_type_name = function | C_void -> "void" | C_int -> "int" | C_long -> "long" | C_int_alias name -> name | C_long_alias name -> name | C_char -> "char" | C_ptr t -> c_type_name t ^ "*" | C_array (t, n) -> c_type_name t ^ "[" ^ string_of_int n ^ "]" | C_dyn_array t -> c_type_name t ^ "[]" let rec caml_type_name = function | Caml_void -> "" | Caml_int -> "int" | Caml_int32 -> "int32" | Caml_int64 -> "int64" | Caml_bool -> "bool" | Caml_char -> "char" | Caml_string -> "string" | Caml_bytes -> "Lwt_bytes.t" | Caml_tuple l -> String.concat " * " (List.map caml_type_name l) | Caml_record (name, _) -> name | Caml_variant (name, _) -> name | Caml_alias (name, _) -> name | Caml_list (Caml_tuple _ as ty) -> sprintf "(%s) list" (caml_type_name ty) | Caml_list ty -> sprintf "%s list" (caml_type_name ty) let rec real_caml_type = function | Caml_alias (_, t) -> real_caml_type t | t -> t let string_of_direction = function | In -> "in" | Out -> "out" | In_out -> "in & out" let subst job patt = let buf = Buffer.create 128 in Buffer.add_substitute buf (fun var -> if job then "job->" ^ var else var) patt; Buffer.contents buf let rec find_map f l = match l with | [] -> raise Not_found | x :: l -> match f x with | Some x -> x | None -> find_map f l let split_name name = try let idx = String.rindex name '.' in (String.sub name 0 idx, String.sub name (idx + 1) (String.length name - idx - 1)) with Not_found -> ("", name) let ml_oc = ref stdout module type Params = sig val fname : string val oc : out_channel val job : job end module type Generator = sig val gen_worker : string -> unit val gen_result : string -> unit val gen_job_stub : string -> string -> string -> unit val gen_caml : string -> unit val gen_file : unit -> unit end module MakeGen(Gen64 : Generator)(Params : Params) = struct open Params let map_in_64 = List.exists (fun name -> List.exists (fun (name', dir, _) -> name = name' && dir = In) job.params) job.map64 let map_out_64 = List.exists (fun name -> List.exists (fun (name', dir, _) -> name = name' && dir = Out) job.params) job.map64 let map_result_64 = List.mem "result" job.map64 let pr fmt = fprintf oc fmt let ins = List.filter (fun (_, dir, { caml_type }) -> (dir = In || dir = In_out) && caml_type <> Caml_void) job.params let strings = List.map (fun (name, _, _) -> name) (List.filter (fun (_, dir, { caml_type }) -> dir = In && caml_type = Caml_string) job.params) let caml_return_type, is_tuple = match job.result.caml_type with | Caml_void -> ("unit", false) | Caml_tuple _ as t -> (caml_type_name t, true) | t -> (caml_type_name t, false) let caml_arg_types = String.concat " -> " (match List.map (fun (_, _, { caml_type }) -> caml_type_name caml_type) (List.filter (fun (_, dir, { caml_type }) -> dir = In && caml_type <> Caml_void) job.params) with | [] -> ["unit"] | l -> l) let gen_worker suffix = pr "\n"; pr "/* The function calling [%s]. */\n" job.name; pr "static void worker_%s%s(struct job_%s* job)\n" job.name suffix job.name; pr "{\n"; pr " /* Perform the blocking call. */\n"; pr " "; if job.result.c_type <> C_void then pr "job->result = "; pr "%s(%s);\n" job.name (String.concat ", " (List.map (fun (name, dir, _) -> match dir with | In -> "job->" ^ name | Out | In_out -> "&job->" ^ name) job.params)); if job.uerror = Uerror_errno then begin pr " /* Save the value of errno. */\n"; pr " job->errno_copy = errno;\n" end; pr "}\n" let gen_result suffix = pr "\n"; pr "/* The function building the caml result. */\n"; pr "static value result_%s%s(struct job_%s* job)\n" job.name suffix job.name; pr "{\n"; if job.result.caml_type <> Caml_void then pr " value result;\n"; (match job.check with | None -> () | Some test -> pr " /* Check for errors. */\n"; pr " if (%s) {\n" (subst true test); pr " /* Save the value of errno so we can use it once the job has been freed. */\n"; pr " int error = job->errno_copy;\n"; (match strings with | [] -> () | name :: _ -> pr " /* Copy the contents of job->%s into a caml string. */\n" name; pr " value string_argument = caml_copy_string(job->%s);\n" name); pr " /* Free the job structure. */\n"; pr " lwt_unix_free_job(&job->job);\n"; pr " /* Raise the error. */\n"; (match strings with | [] -> pr " unix_error(error, %S, Nothing);\n" job.name | name :: _ -> pr " unix_error(error, %S, string_argument);\n" job.name); pr " }\n"); if job.result.caml_type <> Caml_void then begin pr " /* Build the caml result. */\n"; match job.result.caml_type, job.result.c_type with | Caml_int, (C_int | C_int_alias _) -> pr " result = Val_int(job->result);\n" | Caml_int, (C_long | C_long_alias _) -> pr " result = Val_long(job->result);\n" | Caml_int64, (C_long | C_long_alias _) -> pr " result = caml_copy_int64(job->result);\n" | _ -> assert false end; pr " /* Free the job structure. */\n"; pr " lwt_unix_free_job(&job->job);\n"; pr " /* Return the result. */\n"; if job.result.caml_type = Caml_void then pr " return Val_unit;\n" else pr " return result;\n"; pr "}\n" let gen_job_stub suffix worker_suffix result_suffix = pr "\n"; pr "/* The stub creating the job structure. */\n"; pr "CAMLprim value lwt_unix_%s%s_job(%s)\n" job.name suffix (String.concat ", " (List.map (fun (name, _, _) -> "value " ^ name) ins)); pr "{\n"; List.iter (fun name -> pr " /* Get the length of the %s parameter. */\n" name; pr " mlsize_t len_%s = caml_string_length(%s) + 1;\n" name name) strings; pr " /* Allocate a new job. */\n"; if strings = [] then pr " struct job_%s* job = lwt_unix_new(struct job_%s);\n" job.name job.name else pr " struct job_%s* job = lwt_unix_new_plus(struct job_%s, %s);\n" job.name job.name (String.concat " + " (List.map (fun name -> "len_" ^ name) strings)); let rec loop = function | [] -> () | name :: names -> loop names; pr " /* Set the offset of the %s parameter inside the job structure. */\n" name; pr " job->%s = %s;\n" name (String.concat " + " ("job->data" :: List.map (fun n -> "len_" ^ n) names)) in loop (List.rev strings); List.iter (fun name -> pr " /* Copy the %s parameter inside the job structure. */\n" name; pr " memcpy(job->%s, String_val(%s), len_%s);\n" name name name) strings; pr " /* Initializes function fields. */\n"; pr " job->job.worker = (lwt_unix_job_worker)worker_%s%s;\n" job.name worker_suffix; pr " job->job.result = (lwt_unix_job_result)result_%s%s;\n" job.name result_suffix; List.iter (fun (name, dir, { caml_type; c_type; hint }) -> if caml_type <> Caml_string then begin pr " /* Copy the %s parameter. */\n" name; pr " job->%s = " name; (match real_caml_type caml_type, c_type, hint with | Caml_int, (C_int | C_int_alias _), _ -> pr "Int_val(%s)" name | Caml_int, (C_long | C_long_alias _), _ -> pr "Long_val(%s)" name | Caml_int64, (C_long | C_long_alias _), _ -> pr "Int64_val(%s)" name | Caml_list (Caml_variant (type_name, _)), _, Hint_flag_list _ -> pr "%s_of_%ss(%s)" (c_type_name c_type) (snd (split_name type_name)) name | Caml_variant (type_name, _), _, Hint_table _ -> pr "%s_table[Int_val(%s)]" (snd (split_name type_name)) name | _ -> assert false); pr ";\n" end) ins; pr " /* Wrap the structure into a caml value. */\n"; pr " return lwt_unix_alloc_job(&job->job);\n"; pr "}\n" let gen_caml suffix = let pr fmt = fprintf !ml_oc fmt in pr " external %s%s_job : %s -> %s Job.t = \"lwt_unix_%s%s_job\"\n" job.name suffix caml_arg_types (if is_tuple then "(" ^ caml_return_type ^ ")" else caml_return_type) job.name suffix let gen_file () = pr "\ /* * %s * %s * * File generated with %s */ /* Note: this file was generated at configure time. If it does not work and you want to fix it, you can modify it and send the result to the ocsigen mailing list. If you are courageous you can also look at the ocaml script that generated this file (%s). */ /* Informations: - this is the expected prototype of the C function [%s]: %s %s(%s) - these are the expected ocaml externals for this job: external %s_job : %s -> %s Lwt_unix.job = \"lwt_unix_%s_job\" external %s_sync : %s -> %s = \"lwt_unix_%s_sync\" */ " fname (String.make (String.length fname) '-') prog_name Sys.argv.(0) job.name (c_type_name job.result.c_type) job.name (String.concat ", " (List.map (fun (name, dir, { c_type }) -> match dir with | In -> c_type_name c_type ^ " " ^ name | In_out | Out -> c_type_name (C_ptr c_type) ^ " " ^ name) job.params)) job.name caml_arg_types (if is_tuple then "(" ^ caml_return_type ^ ")" else caml_return_type) job.name job.name caml_arg_types caml_return_type job.name; pr "\n"; pr "/* Caml headers. */\n"; pr "#include \n"; List.iter (pr "#include \n") ["memory"; "alloc"; "fail"; "signals"]; let exists_if = String.concat " && " (List.map (fun (yes, var) -> if yes then sprintf "defined(%s)" var else sprintf "!defined(%s)" var) job.exists_if) in if job.exists_if <> [] then pr "\n#if %s\n" exists_if; pr "\n"; pr "/* Specific headers. */\n"; pr "#include \n"; pr "#include \n"; List.iter (pr "#include <%s.h>\n") job.includes; let converters = List.filter (fun (name, _, { hint }) -> hint <> Hint_none) job.params in if converters <> [] then begin pr " /* +-----------------------------------------------------------------+ | Converters | +-----------------------------------------------------------------+ */ "; List.iter (fun (name, _, atype) -> match atype.hint with | Hint_none -> () | Hint_flag_list mapping | Hint_table mapping -> let name, cstrs = match atype.caml_type with | Caml_list (Caml_variant (name, cstrs)) | Caml_variant (name, cstrs) -> (name, cstrs) | _ -> assert false in let path, item = split_name name in pr "\n"; pr "/* Table mapping constructors of ocaml type %s to C values. */\n" name; pr "static %s %s_table[] = {\n" (c_type_name atype.c_type) item; let rec loop l = match l with | [] -> () | (cstr, typ) :: l -> assert (typ = []); pr " /* Constructor %s. */\n" cstr; pr " %s" (find_map (function | (S name, _) when name = cstr -> Some name | (D (name, name'), _) when name = cstr -> Some name' | _ -> None) mapping); if l = [] then pr "\n" else begin pr ",\n"; loop l end in loop cstrs; pr "};\n"; if (match atype.hint with Hint_flag_list _ -> true | _ -> false) then begin pr "\n"; pr "/* Convert ocaml values of type %s to a C %s. */\n" name (c_type_name atype.c_type); pr "static %s %s_of_%ss(value list)\n" (c_type_name atype.c_type) (c_type_name atype.c_type) item; pr "{\n"; pr " %s result = 0;\n" (c_type_name atype.c_type); pr " while (Is_block(list)) {\n"; pr " result |= %s_table[Int_val(Field(list, 0))];\n" item; pr " list = Field(list, 1);\n"; pr " };\n"; pr " return result;\n"; pr "}\n"; end) converters end; pr " /* +-----------------------------------------------------------------+ | Asynchronous job | +-----------------------------------------------------------------+ */ "; pr "\n"; pr "/* Structure holding informations for calling [%s]. */\n" job.name; pr "struct job_%s {\n" job.name; pr " /* Informations used by lwt. It must be the first field of the structure. */\n"; pr " struct lwt_unix_job job;\n"; if job.result.c_type <> C_void then begin pr " /* This field store the result of the call. */\n"; pr " %s result;\n" (c_type_name job.result.c_type) end; if job.uerror = Uerror_errno then begin pr " /* This field store the value of [errno] after the call. */\n"; pr " int errno_copy;\n" end; List.iter (fun (name, dir, { c_type }) -> pr " /* %s parameter. */\n" (string_of_direction dir); pr " %s %s;\n" (c_type_name c_type) name) job.params; if strings <> [] then begin pr " /* Buffer for string parameters. */\n"; pr " char data[];\n" end; pr "};\n"; gen_worker ""; gen_result ""; if map_out_64 || map_result_64 then Gen64.gen_result "_64"; gen_job_stub "" "" ""; if map_in_64 || map_out_64 || map_result_64 then Gen64.gen_job_stub "_64" "" (if map_out_64 || map_result_64 then "_64" else ""); if job.exists_if <> [] then begin pr "\n"; (* XXX: hack for fsync *) if job.name <> "fsync" then begin pr "#else /* %s */\n" exists_if; pr "\n"; pr "CAMLprim value lwt_unix_%s_job(value Unit)\n" job.name; pr "{\n"; pr " lwt_unix_not_available(%S);\n" job.name; pr " return Val_unit;\n"; pr "}\n"; pr "\n"; if map_in_64 || map_out_64 || map_result_64 then begin pr "CAMLprim value lwt_unix_%s_64_job(value Unit)\n" job.name; pr "{\n"; pr " lwt_unix_not_available(%S);\n" job.name; pr " return Val_unit;\n"; pr "}\n"; pr "\n"; end; end; pr "#endif /* %s */\n" exists_if end; gen_caml ""; if map_in_64 || map_out_64 || map_result_64 then Gen64.gen_caml "_64" end module GenFake = struct let gen_worker _ = assert false let gen_result _ = assert false let gen_job_stub _ _ _ = assert false let gen_sync_stub _ = assert false let gen_file _ = assert false let gen_caml _ = assert false end let gen job = let fname = "lwt_unix_job_" ^ job.name ^ ".c" in let oc = open_out ("src/unix/jobs-unix/" ^ fname) in let job64 = { job with params = ( List.map (fun (name, dir, atype) -> if List.mem name job.map64 then (name, dir, { atype with caml_type = Caml_int64 }) else (name, dir, atype)) job.params ); result = if List.mem "result" job.map64 then { job.result with caml_type = Caml_int64 } else job.result; } in let module Gen64 = MakeGen(GenFake)(struct let fname = fname let oc = oc let job = job64 end) in let module Gen = MakeGen(Gen64)(struct let fname = fname let oc = oc let job = job end) in Gen.gen_file (); close_out oc let rec collect_jobs map = function | Job job -> if StringMap.mem job.name map then begin log "job '%s' is defined two times" job.name; exit 1 end; StringMap.add job.name { job with exists_if = (false, "LWT_ON_WINDOWS") :: job.exists_if } map | Seq l -> List.fold_left collect_jobs map l let jobs = collect_jobs StringMap.empty jobs let () = match Sys.argv with | [|_|] -> let fname = "lwt_unix_jobs_generated.ml" in ml_oc := open_out ("src/unix/" ^ fname); let pr_header oc fname = fprintf oc "\ (* * %s * %s * * File generated with %s *) module type Job = sig type 'a t end " fname (String.make (String.length fname) '-') prog_name; in pr_header !ml_oc fname; fprintf !ml_oc "\ module Make(Job : Job) = struct "; StringMap.iter (fun name job -> gen job) jobs; output_string !ml_oc "end\n"; close_out !ml_oc | [|_; "list-job-files"|] -> StringMap.iter (fun name job -> printf "src/unix/jobs-unix/lwt_unix_job_%s.c\n" name) jobs | [|_; "list-job-names"|] -> StringMap.iter (fun name job -> printf "%s\n" name) jobs | _ -> log "invalid arguments"; eprintf "usage: %s [list-job-files|list-job-names]\n" prog_name; exit 2 lwt-2.5.2/src/unix/jobs-unix/000077500000000000000000000000001270742521300160215ustar00rootroot00000000000000lwt-2.5.2/src/unix/jobs-unix/.keepme000066400000000000000000000000001270742521300172560ustar00rootroot00000000000000lwt-2.5.2/src/unix/liblwt-unix_stubs.clib000066400000000000000000000016211270742521300204340ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 810db210723744b64cf412cd5a8ef063) lwt_unix_stubs.o lwt_libev_stubs.o lwt_process_stubs.o jobs-unix/lwt_unix_job_access.o jobs-unix/lwt_unix_job_chdir.o jobs-unix/lwt_unix_job_chmod.o jobs-unix/lwt_unix_job_chown.o jobs-unix/lwt_unix_job_chroot.o jobs-unix/lwt_unix_job_close.o jobs-unix/lwt_unix_job_fchmod.o jobs-unix/lwt_unix_job_fchown.o jobs-unix/lwt_unix_job_fdatasync.o jobs-unix/lwt_unix_job_fsync.o jobs-unix/lwt_unix_job_ftruncate.o jobs-unix/lwt_unix_job_link.o jobs-unix/lwt_unix_job_lseek.o jobs-unix/lwt_unix_job_mkdir.o jobs-unix/lwt_unix_job_mkfifo.o jobs-unix/lwt_unix_job_rename.o jobs-unix/lwt_unix_job_rmdir.o jobs-unix/lwt_unix_job_symlink.o jobs-unix/lwt_unix_job_tcdrain.o jobs-unix/lwt_unix_job_tcflow.o jobs-unix/lwt_unix_job_tcflush.o jobs-unix/lwt_unix_job_tcsendbreak.o jobs-unix/lwt_unix_job_truncate.o jobs-unix/lwt_unix_job_unlink.o # OASIS_STOP lwt-2.5.2/src/unix/lwt-unix.mldylib000066400000000000000000000003651270742521300172540ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 680445e6f7b15b12386a42168894b9e8) 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_unix_jobs_generated Lwt_config # OASIS_STOP lwt-2.5.2/src/unix/lwt-unix.mllib000066400000000000000000000003651270742521300167170ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 680445e6f7b15b12386a42168894b9e8) 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_unix_jobs_generated Lwt_config # OASIS_STOP lwt-2.5.2/src/unix/lwt_bytes.ml000066400000000000000000000220471270742521300164560ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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. *) open Bigarray open Lwt.Infix 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_from_bytes : Bytes.t -> int -> t -> int -> int -> unit = "lwt_unix_blit_from_bytes" "noalloc" external unsafe_blit_to_bytes : t -> int -> Bytes.t -> int -> int -> unit = "lwt_unix_blit_to_bytes" "noalloc" external unsafe_blit : t -> int -> t -> int -> int -> unit = "lwt_unix_blit" "noalloc" let blit_from_bytes src_buf src_ofs dst_buf dst_ofs len = if (len < 0 || src_ofs < 0 || src_ofs > Bytes.length src_buf - len || dst_ofs < 0 || dst_ofs > length dst_buf - len) then invalid_arg "String.blit" else unsafe_blit_from_bytes src_buf src_ofs dst_buf dst_ofs len let blit_to_bytes 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 > Bytes.length dst_buf - len) then invalid_arg "String.blit" else unsafe_blit_to_bytes 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_bytes buf = let len = Bytes.length buf in let bytes = create len in unsafe_blit_from_bytes buf 0 bytes 0 len; bytes let of_string str = of_bytes (Bytes.unsafe_of_string str) let to_bytes bytes = let len = length bytes in let str = Bytes.create len in unsafe_blit_to_bytes bytes 0 str 0 len; str let to_string bytes = Bytes.unsafe_to_string (to_bytes bytes) let proxy = Array1.sub let extract buf ofs len = if ofs < 0 || len < 0 || ofs > length buf - len then invalid_arg "Lwt_bytes.extract" else begin let buf' = create len in blit buf ofs buf' 0 len; buf' end let copy buf = let len = length buf in let buf' = create len in blit buf 0 buf' 0 len; buf' (* +-----------------------------------------------------------------+ | IOs | +-----------------------------------------------------------------+ *) open Lwt_unix external stub_read : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_read" external read_job : Unix.file_descr -> t -> int -> int -> int job = "lwt_unix_bytes_read_job" let read fd buf pos len = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.read" else blocking fd >>= function | true -> wait_read fd >>= fun () -> run_job (read_job (unix_file_descr fd) buf pos len) | false -> wrap_syscall Read fd (fun () -> stub_read (unix_file_descr fd) buf pos len) external stub_write : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_write" external write_job : Unix.file_descr -> t -> int -> int -> int job = "lwt_unix_bytes_write_job" let write fd buf pos len = if pos < 0 || len < 0 || pos > length buf - len then invalid_arg "Lwt_bytes.write" else blocking fd >>= function | true -> wait_write fd >>= fun () -> run_job (write_job (unix_file_descr fd) buf pos len) | false -> wrap_syscall Write fd (fun () -> stub_write (unix_file_descr fd) buf pos len) 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) 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) 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 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) 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) 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) 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) (* +-----------------------------------------------------------------+ | 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 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 external get_page_size : unit -> int = "lwt_unix_get_page_size" let page_size = get_page_size () external stub_mincore : t -> int -> int -> bool array -> unit = "lwt_unix_mincore" let mincore buffer offset states = if (offset mod page_size <> 0 || offset < 0 || offset > length buffer - (Array.length states * page_size)) then invalid_arg "Lwt_bytes.mincore" else stub_mincore buffer offset (Array.length states * page_size) states external wait_mincore_job : t -> int -> unit job = "lwt_unix_wait_mincore_job" let wait_mincore buffer offset = if offset < 0 || offset >= length buffer then invalid_arg "Lwt_bytes.wait_mincore" else begin let state = [|false|] in mincore buffer (offset - (offset mod page_size)) state; if state.(0) then Lwt.return_unit else run_job (wait_mincore_job buffer offset) end lwt-2.5.2/src/unix/lwt_bytes.mli000066400000000000000000000146631270742521300166340ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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. *) (** {2 Access} *) val get : t -> int -> char (** [get buffer offset] returns the byte at offset [offset] in [buffer]. *) val set : t -> int -> char -> unit (** [get buffer offset value] changes the value of the byte at offset [offset] in [buffer] to [value]. *) val unsafe_get : t -> int -> char (** Same as {!get} but without bounds checking. *) val unsafe_set : t -> int -> char -> unit (** Same as {!set} but without bounds checking. *) (** {2 Conversions} *) val of_bytes : Bytes.t -> t (** [of_bytes buf] returns a newly allocated byte array with the same contents as [buf]. *) val of_string : string -> t (** [of_string buf] returns a newly allocated byte array with the same contents as [buf]. *) val to_bytes : t -> Bytes.t (** [to_bytes buf] returns newly allocated bytes with the same contents as [buf]. *) val to_string : t -> string (** [to_string buf] returns a newly allocated string with the same contents as [buf]. *) (** {2 Copying} *) val blit : t -> int -> t -> int -> int -> unit (** [blit buf1 ofs1 buf2 ofs2 len] copies [len] bytes from [buf1] starting at offset [ofs1] to [buf2] starting at offset [ofs2]. *) val blit_from_bytes : Bytes.t -> int -> t -> int -> int -> unit (** Same as {!blit} but the first buffer is a string instead of a byte array. *) val blit_to_bytes : t -> int -> Bytes.t -> int -> int -> unit (** Same as {!blit} but the second buffer is a string instead of a byte array. *) val unsafe_blit : t -> int -> t -> int -> int -> unit (** Same as {!blit} but without bound checking. *) val unsafe_blit_from_bytes : Bytes.t -> int -> t -> int -> int -> unit (** Same as {!blit_string_bytes} but without bounds checking. *) val unsafe_blit_to_bytes : t -> int -> Bytes.t -> int -> int -> unit (** Same as {!blit_bytes_string} but without bounds 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. *) (** {2 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 bounds checking. *) (** {2 IOs} *) (** The following functions behave similarly to the ones in {!Lwt_unix} except 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. *) (** {2 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. *) type advice = | MADV_NORMAL | MADV_RANDOM | MADV_SEQUENTIAL | MADV_WILLNEED | MADV_DONTNEED val madvise : t -> int -> int -> advice -> unit (** [madvise buffer pos len advice] advises the kernel how the program will use 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 is in RAM and [false] otherwise. This call is not available on windows and cygwin. *) val wait_mincore : t -> int -> unit Lwt.t (** [wait_mincore buffer offset] waits until the page containing the byte at offset [offset] is in RAM. This functions is not available on windows and cygwin. *) lwt-2.5.2/src/unix/lwt_chan.ml000066400000000000000000000057431270742521300162450ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_chan * Copyright (C) 2005-2008 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * 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.Infix type in_channel = Lwt_io.input_channel type out_channel = Lwt_io.output_channel let in_channel_of_descr fd = Lwt_io.of_fd ~mode:Lwt_io.input fd let make_in_channel ?close read = Lwt_io.make ~mode:Lwt_io.input ?close (fun buf ofs len -> let str = Bytes.create len in read str 0 len >>= fun n -> if (n > 0) then Lwt_bytes.blit_from_bytes str 0 buf ofs len; Lwt.return n) let input_line ic = let rec loop buf = Lwt_io.read_char_opt ic >>= function | None | Some '\n' -> Lwt.return (Buffer.contents buf) | Some char -> Buffer.add_char buf char; loop buf in Lwt_io.read_char_opt ic >>= function | Some '\n' -> Lwt.return "" | Some char -> let buf = Buffer.create 128 in Buffer.add_char buf char; loop buf | None -> Lwt.fail End_of_file let input_value = Lwt_io.read_value let input = Lwt_io.read_into let really_input = Lwt_io.read_into_exactly let input_char = Lwt_io.read_char let input_binary_int = Lwt_io.BE.read_int let open_in_gen flags perm fname = Lwt_io.open_file ~flags ~perm ~mode:Lwt_io.input fname let open_in fname = Lwt_io.open_file ~mode:Lwt_io.input fname let close_in = Lwt_io.close let out_channel_of_descr fd = Lwt_io.of_fd ~mode:Lwt_io.output fd let make_out_channel ?close write = Lwt_io.make ~mode:Lwt_io.output ?close (fun buf ofs len -> let str = Bytes.create len in Lwt_bytes.blit_to_bytes buf ofs str 0 len; write str 0 len) let output = Lwt_io.write_from_exactly let flush = Lwt_io.flush let output_string = Lwt_io.write let output_value oc v = Lwt_io.write_value oc v let output_char = Lwt_io.write_char let output_binary_int = Lwt_io.BE.write_int let open_out_gen flags perm fname = Lwt_io.open_file ~flags ~perm ~mode:Lwt_io.output fname let open_out fname = Lwt_io.open_file ~mode:Lwt_io.output fname let close_out = Lwt_io.close let open_connection sockaddr = Lwt_io.open_connection sockaddr lwt-2.5.2/src/unix/lwt_chan.mli000066400000000000000000000064371270742521300164170ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_chan * Copyright (C) 2005-2008 Jérôme 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. *) (** {3 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) -> (Bytes.t -> 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 -> Bytes.t -> int -> int -> int Lwt.t val really_input : in_channel -> Bytes.t -> 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 (** {3 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) -> (Bytes.t -> 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 -> Bytes.t -> int -> int -> unit Lwt.t val flush : out_channel -> unit Lwt.t val output_string : out_channel -> string -> unit Lwt.t val output_value : out_channel -> 'a -> unit Lwt.t val output_char : out_channel -> char -> unit Lwt.t val output_binary_int : out_channel -> int -> unit Lwt.t val open_out_gen : Unix.open_flag list -> int -> string -> out_channel Lwt.t val open_out : string -> out_channel Lwt.t val close_out : out_channel -> unit Lwt.t val open_connection : Unix.sockaddr -> (in_channel * out_channel) Lwt.t lwt-2.5.2/src/unix/lwt_daemon.ml000066400000000000000000000047441270742521300165770ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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.Infix let rec copy ic logger = Lwt_io.read_line ic >>= fun line -> Lwt_log.log ?logger ~level:Lwt_log.Notice line >>= fun () -> 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_r in Lwt.ignore_result (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) () = 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 n); end; ignore (Unix.setsid ()) lwt-2.5.2/src/unix/lwt_daemon.mli000066400000000000000000000061241270742521300167420ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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: - 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] default to [`Log_default]. Warning: do not redirect an output to a logger logging into this output. 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 umask is set to [n] It defaults to [`Set 0o022]. *) lwt-2.5.2/src/unix/lwt_engine.ml000066400000000000000000000341651270742521300166010ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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. *) (* +-----------------------------------------------------------------+ | 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 | +-----------------------------------------------------------------+ *) 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 (* +-----------------------------------------------------------------+ | 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 -> (* We have to remove the sleeper to the queue before performing the action. The action can change the sleeper's time, and this might break the priority queue invariant if the sleeper is still in the queue. *) let q = Sleep_queue.remove_min sleep_queue in action (); restart_actions q 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 immediately to the main sleep queue in order to prevent them from being wakeup immediately. *) 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 | +-----------------------------------------------------------------+ *) let current = if Lwt_config._HAVE_LIBEV && Lwt_config.libev_default then ref (new libev :> t) else ref (new select :> t) let get () = !current let set ?(transfer=true) ?(destroy=true) engine = if transfer then !current#transfer (engine : #t :> abstract); if destroy then !current#destroy; current := (engine : #t :> t) let iter block = !current#iter block let on_readable fd f = !current#on_readable fd f let on_writable fd f = !current#on_writable fd f let on_timer delay repeat f = !current#on_timer delay repeat f let fake_io fd = !current#fake_io fd let readable_count () = !current#readable_count let writable_count () = !current#writable_count let timer_count () = !current#timer_count lwt-2.5.2/src/unix/lwt_engine.mli000066400000000000000000000152131270742521300167430ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 *) (** {2 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. *) (** {2 Event loop functions} *) val iter : bool -> unit (** [iter block] performs one iteration of the main loop. If [block] is [true] the function must block until one event becomes available, otherwise it should just check for available events and return immediately. *) 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. *) (** {2 Engines} *) (** An engine represents a set of functions used to register different kinds of callbacks for different kinds 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 occur in 2 seconds in the destination engine. *) (** {2 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 (** {2 Backend methods} *) (** Notes: - the callback passed to register methods is of type [unit -> unit] and not [event -> unit] - register methods return a lazy value which unregisters the event when forced *) method virtual private cleanup : unit (** Cleanup resources associated with 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 (** {2 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 (** {2 The current engine} *) val get : unit -> t (** [get ()] returns the engine currently in use. *) val set : ?transfer : bool -> ?destroy : bool -> #t -> unit (** [set ?transfer ?destroy engine] replaces the current engine by the given one. If [transfer] is [true] (the default) all events from the current engine are transferred to the new one. If [destroy] is [true] (the default) then the current engine is destroyed before being replaced. *) lwt-2.5.2/src/unix/lwt_gc.ml000066400000000000000000000057251270742521300157250ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 ( Lwt.finalize (fun () -> t) (fun () -> Lwt_sequence.remove hook; Lwt.return_unit)) end let finaliser f = (* In order not to create a reference to the value in the notification callback, we use an initially unset option cell which will be filled when the finaliser is called. *) let opt = ref None in let id = Lwt_unix.make_notification ~once:true (fun () -> match !opt with | None -> assert false | Some x -> opt := None; ensure_termination (f x)) in (* The real finaliser: fill the cell and send a notification. *) (fun x -> opt := Some x; Lwt_unix.send_notification id) let finalise f x = Gc.finalise (finaliser f) x (* Exit hook for a finalise_or_exit *) let foe_exit f called weak () = match Weak.get weak 0 with | None -> (* The value has been garbage collected, normally this point is never reached *) Lwt.return_unit | Some x -> (* Just to avoid double finalisation *) Weak.set weak 0 None; if !called then Lwt.return_unit else begin called := true; f x end (* Finaliser for a finalise_or_exit *) let foe_finaliser f called hook = finaliser (fun x -> (* Remove the exit hook, it is not needed anymore. *) Lwt_sequence.remove hook; (* Call the real finaliser. *) if !called then Lwt.return_unit else begin called := true; f x end) let finalise_or_exit f x = (* Create a weak pointer, so the exit-hook does not keep a reference to [x]. *) let weak = Weak.create 1 in Weak.set weak 0 (Some x); let called = ref false in let hook = Lwt_sequence.add_l (foe_exit f called weak) Lwt_main.exit_hooks in Gc.finalise (foe_finaliser f called hook) x lwt-2.5.2/src/unix/lwt_gc.mli000066400000000000000000000031541270742521300160700ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 offers a convenient way to add a finaliser launching a thread to a value, without having to use [Lwt_unix.run] in the finaliser. *) val finalise : ('a -> unit Lwt.t) -> 'a -> unit (** [finalise f x] ensures [f x] is evaluated after [x] has been garbage collected. If [f x] yields, then Lwt will wait for its termination at the end of the program. Note that [f x] is not called at garbage collection time, but later in the main loop. *) val finalise_or_exit : ('a -> unit Lwt.t) -> 'a -> unit (** [finalise_or_exit f x] call [f x] when [x] is garbage collected or (exclusively) when the program exits. *) lwt-2.5.2/src/unix/lwt_io.ml000066400000000000000000001411531270742521300157370ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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.Infix 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 check_buffer fun_name buffer = check_buffer_size fun_name (Lwt_bytes.length buffer) let default_buffer_size = ref 4096 (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) type input type output type 'a mode = | Input : input mode | Output : output mode 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 let position : type mode. mode channel -> int64 = fun wrapper -> 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) let name : type mode. mode _channel -> string = fun ch -> 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: *) let perform_io : type mode. mode _channel -> int Lwt.t = fun ch -> match ch.main.state with | 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.pick [ch.abort_waiter; if Sys.win32 then Lwt.catch (fun () -> perform_io ch.buffer ptr len) (function | Unix.Unix_error (Unix.EPIPE, _, _) -> Lwt.return 0 | exn -> Lwt.fail exn) else perform_io ch.buffer ptr len ] >>= fun n -> (* Never trust user functions... *) if n < 0 || n > len then Lwt.fail (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; Lwt.return n end | Type_bytes -> begin match ch.mode with | Input -> Lwt.return 0 | Output -> Lwt.fail (Failure "cannot flush a channel created with Lwt_io.of_string") end end | Closed -> Lwt.fail (closed_channel ch) | Invalid -> Lwt.fail (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 flush_partial oc >>= fun _ -> flush_total oc else Lwt.return_unit let safe_flush_total oc = Lwt.catch (fun () -> flush_total oc) (fun _ -> Lwt.return_unit) 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.pause () >>= fun () -> 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 Lwt.returns to the [Idle] state: *) oc.auto_flushing <- false; Lwt.return_unit | Busy_atomic _ -> (* Cannot happen since we took the deepest wrapper: *) assert false | Idle -> oc.auto_flushing <- false; wrapper.state <- Busy_primitive; safe_flush_total oc >>= fun () -> if wrapper.state = Busy_primitive then wrapper.state <- Idle; if not (Lwt_sequence.is_empty wrapper.queued) then Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) (); Lwt.return_unit | Closed | Invalid -> Lwt.return_unit (* A ``locked'' channel is a channel in the state [Busy_primitive] or [Busy_atomic] *) let unlock : type m. m channel -> unit = fun wrapper -> match wrapper.state with | Busy_primitive | Busy_atomic _ -> if Lwt_sequence.is_empty wrapper.queued then wrapper.state <- Idle else begin wrapper.state <- Waiting_for_busy; Lwt.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 Lwt.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; Lwt.finalize (fun () -> f wrapper.channel) (fun () -> unlock wrapper; Lwt.return_unit) | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> Lwt.add_task_r wrapper.queued >>= fun () -> begin match wrapper.state with | Closed -> (* The channel has been closed while we were waiting *) unlock wrapper; Lwt.fail (closed_channel wrapper.channel) | Idle | Waiting_for_busy -> wrapper.state <- Busy_primitive; Lwt.finalize (fun () -> f wrapper.channel) (fun () -> unlock wrapper; Lwt.return_unit) | Invalid -> Lwt.fail (invalid_channel wrapper.channel) | Busy_primitive | Busy_atomic _ -> assert false end | Closed -> Lwt.fail (closed_channel wrapper.channel) | Invalid -> Lwt.fail (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; Lwt.finalize (fun () -> f tmp_wrapper) (fun () -> (* The temporary wrapper is no more valid: *) tmp_wrapper.state <- Invalid; unlock wrapper; Lwt.return_unit) | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> Lwt.add_task_r wrapper.queued >>= fun () -> begin match wrapper.state with | Closed -> (* The channel has been closed while we were waiting *) unlock wrapper; Lwt.fail (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; Lwt.finalize (fun () -> f tmp_wrapper) (fun () -> tmp_wrapper.state <- Invalid; unlock wrapper; Lwt.return_unit) | Invalid -> Lwt.fail (invalid_channel wrapper.channel) | Busy_primitive | Busy_atomic _ -> assert false end | Closed -> Lwt.fail (closed_channel wrapper.channel) | Invalid -> Lwt.fail (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 -> Lwt.fail (invalid_channel wrapper.channel) | Idle | Busy_primitive | Waiting_for_busy -> wrapper.state <- Closed; (* Abort any current real reading/writing operation on the channel: *) Lwt.wakeup_exn wrapper.channel.abort_wakener (closed_channel wrapper.channel); Lazy.force wrapper.channel.close let close : type mode. mode channel -> unit Lwt.t = fun wrapper -> let channel = wrapper.channel in if channel.main != wrapper then Lwt.fail (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 -> Lwt.catch (fun () -> (* Performs all pending actions, flush the buffer, then close it: *) primitive (fun channel -> safe_flush_total channel >>= fun () -> abort wrapper) wrapper) (fun _ -> abort wrapper) let flush_all () = let wrappers = Outputs.fold (fun x l -> x :: l) outputs [] in Lwt_list.iter_p (fun wrapper -> Lwt.catch (fun () -> primitive safe_flush_total wrapper) (fun _ -> Lwt.return_unit)) wrappers let () = (* Flush all opened ouput channels on exit: *) Lwt_main.at_exit flush_all let no_seek pos cmd = Lwt.fail (Failure "Lwt_io.seek: seek not supported on this channel") let make : type m. ?buffer : Lwt_bytes.t -> ?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 ?(close=Lwt.return) ?(seek=no_seek) ~mode perform_io -> let (buffer, size) = match buffer with | Some buffer -> check_buffer "Lwt_io.make" buffer; (buffer, Lwt_bytes.length buffer) | None -> let size = !default_buffer_size in (Lwt_bytes.create size, size) in let 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(Lwt.catch close Lwt.fail); 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 -> Lwt.fail e); } and wrapper = { state = Idle; channel = ch; queued = Lwt_sequence.create (); } in (match mode with | Input -> () | Output -> Outputs.add outputs wrapper); 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(Lwt.return_unit); 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_fd : type m. ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> mode : m mode -> Lwt_unix.file_descr -> m channel = fun ?buffer ?close ~mode fd -> let perform_io = match mode with | Input -> Lwt_bytes.read fd | Output -> Lwt_bytes.write fd in make ?buffer ~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 let of_unix_fd : type m. ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> mode : m mode -> Unix.file_descr -> m channel = fun ?buffer ?close ~mode fd -> of_fd ?buffer ?close ~mode (Lwt_unix.of_unix_file_descr fd) let buffered : type m. m channel -> int = fun ch -> match ch.channel.mode with | Input -> ch.channel.max - ch.channel.ptr | Output -> ch.channel.ptr let buffer_size ch = ch.channel.length let resize_buffer : type m. m channel -> int -> unit Lwt.t = fun wrapper len -> if len < min_buffer_size then invalid_arg "Lwt_io.resize_buffer"; match wrapper.channel.typ with | Type_bytes -> Lwt.fail (Failure "Lwt_io.resize_buffer: cannot resize the buffer of a channel created with Lwt_io.of_string") | Type_normal _ -> let f : type m. m _channel -> unit Lwt.t = fun ch -> 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 Lwt.fail (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; Lwt.return_unit 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 flush_partial ch >>= fun _ -> loop () else Lwt.return_unit in loop () >>= fun () -> 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; Lwt.return_unit 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 -> Lwt.fail End_of_file | _ -> read_char ic else begin ic.ptr <- ptr + 1; Lwt.return (Lwt_bytes.unsafe_get ic.buffer ptr) end let read_char_opt ic = Lwt.catch (fun () -> read_char ic >|= fun ch -> Some ch) (function | End_of_file -> Lwt.return_none | exn -> Lwt.fail exn) let read_line ic = let buf = Buffer.create 128 in let rec loop cr_read = Lwt.try_bind (fun _ -> read_char ic) (function | '\n' -> Lwt.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'; Lwt.return(Buffer.contents buf) | exn -> Lwt.fail exn) in read_char ic >>= function | '\r' -> loop true | '\n' -> Lwt.return "" | ch -> Buffer.add_char buf ch; loop false let read_line_opt ic = Lwt.catch (fun () -> read_line ic >|= fun ch -> Some ch) (function | End_of_file -> Lwt.return_none | exn -> Lwt.fail exn) let unsafe_read_into ic buf ofs len = let avail = ic.max - ic.ptr in if avail > 0 then begin let len = min len avail in Lwt_bytes.unsafe_blit_to_bytes ic.buffer ic.ptr buf ofs len; ic.ptr <- ic.ptr + len; Lwt.return len end else begin refill ic >>= fun n -> let len = min len n in Lwt_bytes.unsafe_blit_to_bytes ic.buffer 0 buf ofs len; ic.ptr <- len; ic.max <- n; Lwt.return len end let read_into ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument (Printf.sprintf "Lwt_io.read_into(ofs=%d,len=%d,str_len=%d)" ofs len (Bytes.length buf))) else begin if len = 0 then Lwt.return 0 else unsafe_read_into ic buf ofs len end let rec unsafe_read_into_exactly ic buf ofs len = unsafe_read_into ic buf ofs len >>= function | 0 -> Lwt.fail End_of_file | n -> let len = len - n in if len = 0 then Lwt.return_unit else unsafe_read_into_exactly ic buf (ofs + n) len let read_into_exactly ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument (Printf.sprintf "Lwt_io.read_into_exactly(ofs=%d,len=%d,str_len=%d)" ofs len (Bytes.length buf))) else begin if len = 0 then Lwt.return_unit else unsafe_read_into_exactly ic buf ofs len end let rev_concat len l = let buf = Bytes.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 buf = Bytes.create len in Lwt_bytes.unsafe_blit_to_bytes ic.buffer ic.ptr buf 0 len; let str = Bytes.unsafe_to_string buf in ic.ptr <- ic.max; refill ic >>= function | 0 -> Lwt.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 [] >|= Bytes.unsafe_to_string | Some len -> let buf = Bytes.create len in unsafe_read_into ic buf 0 len >>= fun real_len -> if real_len < len then Lwt.return Bytes.(sub buf 0 real_len |> unsafe_to_string) else Lwt.return (Bytes.unsafe_to_string buf) let read_value ic = let header = Bytes.create 20 in unsafe_read_into_exactly ic header 0 20 >>= fun () -> let bsize = Marshal.data_size header 0 in let buffer = Bytes.create (20 + bsize) in Bytes.unsafe_blit header 0 buffer 0 20; unsafe_read_into_exactly ic buffer 20 bsize >>= fun () -> (* Marshal.from_bytes should be used here, but we want 4.01 compat. *) Lwt.return (Marshal.from_string (Bytes.unsafe_to_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; Lwt.return_unit end else flush_partial oc >>= fun _ -> 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_from_bytes str ofs oc.buffer oc.ptr len; oc.ptr <- oc.ptr + len; Lwt.return 0 end else begin Lwt_bytes.unsafe_blit_from_bytes str ofs oc.buffer oc.ptr avail; oc.ptr <- oc.length; flush_partial oc >>= fun _ -> let len = len - avail in if oc.ptr = 0 then begin if len = 0 then Lwt.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: *) Lwt.return len end let write_from oc buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument (Printf.sprintf "Lwt_io.write_from(ofs=%d,len=%d,str_len=%d)" ofs len (Bytes.length buf))) else begin if len = 0 then Lwt.return 0 else unsafe_write_from oc buf ofs len >>= fun remaining -> Lwt.return (len - remaining) end let write_from_string oc buf ofs len = let buf = Bytes.unsafe_of_string buf in write_from oc buf ofs len let rec unsafe_write_from_exactly oc buf ofs len = unsafe_write_from oc buf ofs len >>= function | 0 -> Lwt.return_unit | n -> unsafe_write_from_exactly oc buf (ofs + len - n) n let write_from_exactly oc buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then Lwt.fail (Invalid_argument (Printf.sprintf "Lwt_io.write_from_exactly(ofs=%d,len=%d,str_len=%d)" ofs len (Bytes.length buf))) else begin if len = 0 then Lwt.return_unit else unsafe_write_from_exactly oc buf ofs len end let write_from_string_exactly oc buf ofs len = let buf = Bytes.unsafe_of_string buf in write_from_exactly oc buf ofs len let write oc str = let buf = Bytes.unsafe_of_string str in unsafe_write_from_exactly oc buf 0 (Bytes.length buf) let write_line oc str = let buf = Bytes.unsafe_of_string str in unsafe_write_from_exactly oc buf 0 (Bytes.length buf) >>= fun () -> 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 -> Lwt.fail 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 flush_partial oc >>= fun _ -> write_block_unsafe oc size f else begin let ptr = oc.ptr in oc.ptr <- ptr + size; f oc.buffer ptr end let block : type m. m _channel -> int -> (Lwt_bytes.t -> int -> 'a Lwt.t) -> 'a Lwt.t = fun ch size f -> if size < 0 || size > min_buffer_size then Lwt.fail (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 Lwt.fail (Invalid_argument "Lwt_io.direct_access.perform") else begin ch.ptr <- da.da_ptr; perform_io ch >>= fun count -> da.da_ptr <- ch.ptr; da.da_max <- ch.max; Lwt.return count end end else Lwt.fail (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 f da >>= fun x -> token := false; if da.da_max <> ch.max || da.da_ptr < ch.ptr || da.da_ptr > ch.max then Lwt.fail (Failure "Lwt_io.direct_access: invalid result of [f]") else begin ch.ptr <- da.da_ptr; Lwt.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 Lwt.return v else Lwt.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 Lwt.return v else Lwt.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 Lwt.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 Lwt.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 -> Lwt.return (Int32.float_of_bits x) let read_float64 ic = read_int64 ic >>= fun x -> Lwt.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); Lwt.return_unit) 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); Lwt.return_unit) 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)); Lwt.return_unit) 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)); Lwt.return_unit) 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 = seek pos Unix.SEEK_SET >>= fun offset -> if offset <> pos then Lwt.fail (Failure "Lwt_io.set_position: seek failed") else Lwt.return_unit let set_position : type m. m _channel -> int64 -> unit Lwt.t = fun ch pos -> match ch.typ, ch.mode with | Type_normal(perform_io, seek), Output -> flush_total ch >>= fun () -> do_seek seek pos >>= fun () -> ch.offset <- pos; Lwt.return_unit | 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)); Lwt.return_unit end else begin do_seek seek pos >>= fun () -> ch.offset <- pos; ch.ptr <- 0; ch.max <- 0; Lwt.return_unit end | Type_bytes, _ -> if pos < 0L || pos > Int64.of_int ch.length then Lwt.fail (Failure "Lwt_io.set_position: out of bounds") else begin ch.ptr <- Int64.to_int pos; Lwt.return_unit end let length ch = match ch.typ with | Type_normal(perform_io, seek) -> seek 0L Unix.SEEK_END >>= fun len -> do_seek seek ch.offset >>= fun () -> Lwt.return len | Type_bytes -> Lwt.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; Lwt.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; Lwt.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); Lwt.return_unit end else Lwt.return_unit 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_string oc str ofs len = primitive (fun oc -> Primitives.write_from_string 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_from_string_exactly oc str ofs len = primitive (fun oc -> Primitives.write_from_string_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:(Lwt_bytes.create min_buffer_size) (fun str ofs len -> Lwt_bytes.fill str ofs len '\x00'; Lwt.return len) let null = make ~mode:output ~buffer:(Lwt_bytes.create min_buffer_size) (fun str ofs len -> Lwt.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 ?in_buffer ?out_buffer _ = let fd_r, fd_w = Lwt_unix.pipe () in (of_fd ?buffer:in_buffer ~mode:input fd_r, of_fd ?buffer:out_buffer ~mode:output fd_w) type file_name = string let open_file : type m. ?buffer : Lwt_bytes.t -> ?flags : Unix.open_flag list -> ?perm : Unix.file_perm -> mode : m mode -> file_name -> m channel Lwt.t = fun ?buffer ?flags ?perm ~mode filename -> 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_unix.openfile filename flags perm >>= fun fd -> Lwt.return (of_fd ?buffer ~mode fd) let with_file ?buffer ?flags ?perm ~mode filename f = open_file ?buffer ?flags ?perm ~mode filename >>= fun ic -> Lwt.finalize (fun () -> f ic) (fun () -> close ic) let file_length filename = with_file ~mode:input filename length let open_connection ?fd ?in_buffer ?out_buffer sockaddr = let fd = match fd with | None -> Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 | Some fd -> fd in let close = lazy begin Lwt.finalize (fun () -> Lwt.catch (fun () -> Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; Lwt.return_unit) (function | Unix.Unix_error(Unix.ENOTCONN, _, _) -> (* This may happen if the server closed the connection before us *) Lwt.return_unit | exn -> Lwt.fail exn)) (fun () -> Lwt_unix.close fd) end in Lwt.catch (fun () -> Lwt_unix.connect fd sockaddr >>= fun () -> (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); Lwt.return (make ?buffer:in_buffer ~close:(fun _ -> Lazy.force close) ~mode:input (Lwt_bytes.read fd), make ?buffer:out_buffer ~close:(fun _ -> Lazy.force close) ~mode:output (Lwt_bytes.write fd))) (fun exn -> Lwt_unix.close fd >>= fun () -> Lwt.fail exn) let with_connection ?fd ?in_buffer ?out_buffer sockaddr f = open_connection ?fd ?in_buffer ?out_buffer sockaddr >>= fun (ic, oc) -> Lwt.finalize (fun () -> f (ic, oc)) (fun () -> close ic <&> close oc) type server = { shutdown : unit Lazy.t; } let shutdown_server server = Lazy.force server.shutdown let establish_server ?fd ?(buffer_size = !default_buffer_size) ?(backlog=5) sockaddr f = let sock = match fd with | None -> Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 | Some fd -> fd in Lwt_unix.setsockopt sock Unix.SO_REUSEADDR true; Lwt_unix.bind sock sockaddr; Lwt_unix.listen sock backlog; let abort_waiter, abort_wakener = Lwt.wait () in let abort_waiter = abort_waiter >>= fun _ -> Lwt.return `Shutdown in let rec loop () = Lwt.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:(Lwt_bytes.create buffer_size) ~mode:input ~close:(fun () -> Lazy.force close) fd, of_fd ~buffer:(Lwt_bytes.create buffer_size) ~mode:output ~close:(fun () -> Lazy.force close) fd); loop () | `Shutdown -> Lwt_unix.close sock >>= fun () -> match sockaddr with | Unix.ADDR_UNIX path when path <> "" && path.[0] <> '\x00' -> Unix.unlink path; Lwt.return_unit | _ -> Lwt.return_unit in ignore (loop ()); { shutdown = lazy(Lwt.wakeup abort_wakener `Shutdown) } let ignore_close ch = ignore (close ch) let make_stream f lazy_ic = let lazy_ic = lazy(Lazy.force lazy_ic >>= fun ic -> Gc.finalise ignore_close ic; Lwt.return ic) in Lwt_stream.from (fun _ -> Lazy.force lazy_ic >>= fun ic -> f ic >>= fun x -> if x = None then close ic >>= fun () -> Lwt.return x else Lwt.return x) let lines_of_file filename = make_stream read_line_opt (lazy(open_file ~mode:input filename)) let lines_to_file filename lines = with_file ~mode:output filename (fun oc -> write_lines oc lines) let chars_of_file filename = make_stream read_char_opt (lazy(open_file ~mode:input filename)) let chars_to_file filename chars = with_file ~mode:output filename (fun oc -> write_chars oc chars) let hexdump_stream oc stream = write_lines oc (Lwt_stream.hexdump stream) let hexdump oc buf = hexdump_stream oc (Lwt_stream.of_string buf) let set_default_buffer_size size = check_buffer_size "set_default_buffer_size" size; default_buffer_size := size let default_buffer_size _ = !default_buffer_size lwt-2.5.2/src/unix/lwt_io.mli000066400000000000000000000455571270742521300161230ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 input/output (IO). It allows to read/write from/to the outside world in an efficient way, by minimising the number of system calls. An {b output channel} is used to send data and an {b input channel} is used to receive data. If you are familiar with buffered channels you may be familiar too with the {b flush} operation. Note that byte channels of this module are automatically flushed when there is nothing else to do (i.e. before the program becomes idle), so this means that you no longer have to write: {[ eprintf "log message\n"; flush stderr; ]} to have your 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. *) (** {2 Types} *) type 'mode channel (** Type of buffered byte channels *) type input (** Input mode *) type output (** Output mode *) (** Channel mode *) type 'a mode = | Input : input mode | Output : output mode 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 *) (** {2 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 *) (** {2 Channels creation/manipulation} *) val pipe : ?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t -> unit -> input_channel * output_channel (** [pipe ?in_buffer ?out_buffer ()] creates a pipe using {!Lwt_unix.pipe} and makes two channels from the two returned file descriptors *) val make : ?buffer : Lwt_bytes.t -> ?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 ?close ~mode perform_io] is the main function for creating new channels. @param buffer user-supplied buffer. When this argument is present, its value will be used as the buffer for the created channel. The size of buffer must conform to the limitations described in {!set_default_buffer_size}. When this argument is not present, a new internal buffer of default size will be allocated for this channel. Warning: do not use the same buffer for simultaneous work with more than one channel. There are other functions in this module that take a [buffer] argument, sharing the same semantics. @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 : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> mode : 'mode mode -> Lwt_unix.file_descr -> 'mode channel (** [of_fd ?buffer ?close ~mode fd] creates a channel from a file descriptor. @param close defaults to closing the file descriptor. *) val of_unix_fd : ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> mode : 'mode mode -> Unix.file_descr -> 'mode channel (** [of_unix_fd ?buffer ?close ~mode fd] is a short-hand for: [of_fd ?buffer ?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, flushes it and closes it. If [ch] is an input channel, it just closes it immediately. [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 channels obtained with {!atomic}. *) val abort : 'a channel -> unit Lwt.t (** [abort ch] abort current operations and close the channel immediately. *) 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. *) (** {2 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 does not support random access. *) val length : 'a channel -> int64 Lwt.t (** Returns the length of the channel in bytes *) (** {2 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 raise [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 [count] 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 -> Bytes.t -> 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 -> Bytes.t -> 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] *) (** {2 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 two 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 -> Bytes.t -> 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_string : output_channel -> string -> int -> int -> int Lwt.t (** See {!write}. *) val write_from_exactly : output_channel -> Bytes.t -> 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_from_string_exactly : output_channel -> string -> int -> int -> unit Lwt.t (** See {!write_from_exactly}. *) 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] *) (** {2 Printing} *) (** These functions are basically helpers. Also you may prefer 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 (** {2 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)] *) (** {2 File utilities} *) type file_name = string (** Type of file names *) val open_file : ?buffer : Lwt_bytes.t -> ?flags : Unix.open_flag list -> ?perm : Unix.file_perm -> mode : 'a mode -> file_name -> 'a channel Lwt.t (** [open_file ?buffer ?flags ?perm ~mode filename] opens the file with name [filename] and returns a channel for reading/writing it. @raise Unix.Unix_error on error. *) val with_file : ?buffer : Lwt_bytes.t -> ?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 ?flags ?perm ~mode filename f] opens 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 : ?fd : Lwt_unix.file_descr -> ?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t -> Unix.sockaddr -> (input_channel * output_channel) Lwt.t (** [open_connection ?fd ?in_buffer ?out_buffer addr] opens a connection to the given address and returns two channels for using it. If [fd] is not specified, a fresh one will be used. The connection is completly closed when you close both channels. @raise Unix.Unix_error on error. *) val with_connection : ?fd : Lwt_unix.file_descr -> ?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t -> Unix.sockaddr -> (input_channel * output_channel -> 'a Lwt.t) -> 'a Lwt.t (** [with_connection ?fd ?in_buffer ?out_buffer addr f] opens a connection to the given address and passes the channels to [f] *) type server (** Type of a server *) val establish_server : ?fd : Lwt_unix.file_descr -> ?buffer_size : int -> ?backlog : int -> Unix.sockaddr -> (input_channel * output_channel -> unit) -> server (** [establish_server ?fd ?buffer_size ?backlog sockaddr f] creates a server which will listen for incoming connections. New connections are passed to [f]. Note that [f] must not raise any exception. If [fd] is not specified, a fresh file descriptor will be created. [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 file with name [name]. *) 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] *) (** {2 Input/output of integers} *) (** Common interface for reading/writing integers in binary *) module type NumberIO = sig (** {3 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 *) (** {3 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}. *) (** {2 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 read or write these chars. [size] must satisfy [0 <= size <= 16] *) (** Information for directly accessing 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: refills 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] passes to [f] a {!direct_access} structure. [f] must use it and update [da_ptr] to reflect how many bytes have been read/written. *) (** {2 Misc} *) val default_buffer_size : unit -> int (** Return the default size for buffers. Channels that are created without a specific buffer use new buffer of this size. *) 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] *) lwt-2.5.2/src/unix/lwt_libev_stubs.c000066400000000000000000000162671270742521300174720ustar00rootroot00000000000000/* Lightweight thread library for OCaml * 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" #include "lwt_unix.h" #if defined(HAVE_LIBEV) #include #include #include #include #include #include #include #include /* +-----------------------------------------------------------------+ | Loops | +-----------------------------------------------------------------+ */ static int compare_loops(value a, value b) { return (int)(Data_custom_val(a) - Data_custom_val(b)); } static long hash_loop(value loop) { return (long)Data_custom_val(loop); } static struct custom_operations loop_ops = { "lwt.libev.loop", custom_finalize_default, compare_loops, hash_loop, custom_serialize_default, custom_deserialize_default }; /* Do nothing. We replace the invoke_pending callback of the event loop, so when events are ready, they can be executed after ev_loop has returned: it is executed in a blocking section and callbacks must be executed outside. */ static void nop(struct ev_loop *loop) { } CAMLprim value lwt_libev_init(value Unit) { struct ev_loop *loop = ev_loop_new(EVFLAG_FORKCHECK); if (!loop) caml_failwith("lwt_libev_init"); /* Remove the invoke_pending callback. */ ev_set_invoke_pending_cb(loop, nop); value result = caml_alloc_custom(&loop_ops, sizeof(struct ev_loop*), 0, 1); Ev_loop_val(result) = loop; return result; } CAMLprim value lwt_libev_stop(value loop) { ev_loop_destroy(Ev_loop_val(loop)); return Val_unit; } CAMLprim value lwt_libev_loop(value val_loop, value val_block) { struct ev_loop *loop = Ev_loop_val(val_loop); /* Call the event loop inside a blocking section. */ caml_enter_blocking_section(); ev_loop(loop, Bool_val(val_block) ? EVLOOP_ONESHOT : EVLOOP_ONESHOT | EVLOOP_NONBLOCK); caml_leave_blocking_section(); /* Invoke callbacks now, i.e. outside the blocking section. */ ev_invoke_pending(loop); return Val_unit; } CAMLprim value lwt_libev_unloop(value loop) { ev_unloop(Ev_loop_val(loop), EVUNLOOP_ONE); return Val_unit; } /* +-----------------------------------------------------------------+ | Watchers | +-----------------------------------------------------------------+ */ #define Ev_io_val(v) *(struct ev_io**)Data_custom_val(v) #define Ev_timer_val(v) *(struct ev_timer**)Data_custom_val(v) static int compare_watchers(value a, value b) { return (int)(Data_custom_val(a) - Data_custom_val(b)); } static long hash_watcher(value watcher) { return (long)Data_custom_val(watcher); } static struct custom_operations watcher_ops = { "lwt.libev.watcher", custom_finalize_default, compare_watchers, hash_watcher, custom_serialize_default, custom_deserialize_default }; /* +-----------------------------------------------------------------+ | IO watchers | +-----------------------------------------------------------------+ */ static void handle_io(struct ev_loop *loop, ev_io *watcher, int revents) { caml_callback((value)watcher->data, Val_unit); } static value lwt_libev_io_init(struct ev_loop *loop, int fd, int event, value callback) { CAMLparam1(callback); CAMLlocal1(result); /* Create and initialise the watcher */ struct ev_io* watcher = lwt_unix_new(struct ev_io); ev_io_init(watcher, handle_io, fd, event); /* Wrap the watcher into a custom caml value */ result = caml_alloc_custom(&watcher_ops, sizeof(struct ev_io*), 0, 1); Ev_io_val(result) = watcher; /* Store the callback in the watcher, and register it as a root */ watcher->data = (void*)callback; caml_register_generational_global_root((value*)(&(watcher->data))); /* Start the event */ ev_io_start(loop, watcher); CAMLreturn(result); } CAMLprim value lwt_libev_readable_init(value loop, value fd, value callback) { return lwt_libev_io_init(Ev_loop_val(loop), FD_val(fd), EV_READ, callback); } CAMLprim value lwt_libev_writable_init(value loop, value fd, value callback) { return lwt_libev_io_init(Ev_loop_val(loop), FD_val(fd), EV_WRITE, callback); } CAMLprim value lwt_libev_io_stop(value loop, value val_watcher) { CAMLparam2(loop, val_watcher); struct ev_io* watcher = Ev_io_val(val_watcher); caml_remove_generational_global_root((value*)(&(watcher->data))); ev_io_stop(Ev_loop_val(loop), watcher); free(watcher); CAMLreturn(Val_unit); } /* +-----------------------------------------------------------------+ | Timer watchers | +-----------------------------------------------------------------+ */ static void handle_timer(struct ev_loop *loop, ev_timer *watcher, int revents) { caml_callback((value)watcher->data, Val_unit); } CAMLprim value lwt_libev_timer_init(value loop, value delay, value repeat, value callback) { CAMLparam4(loop, delay, repeat, callback); CAMLlocal1(result); /* Create and initialise the watcher */ struct ev_timer* watcher = lwt_unix_new(struct ev_timer); if (Bool_val(repeat)) ev_timer_init(watcher, handle_timer, Double_val(delay), Double_val(delay)); else ev_timer_init(watcher, handle_timer, Double_val(delay), 0.0); /* Wrap the watcher into a custom caml value */ result = caml_alloc_custom(&watcher_ops, sizeof(struct ev_timer*), 0, 1); Ev_timer_val(result) = watcher; /* Store the callback in the watcher, and register it as a root */ watcher->data = (void*)callback; caml_register_generational_global_root((value*)(&(watcher->data))); /* Start the event */ ev_timer_start(Ev_loop_val(loop), watcher); CAMLreturn(result); } CAMLprim value lwt_libev_timer_stop(value loop, value val_watcher) { CAMLparam2(loop, val_watcher); struct ev_timer* watcher = Ev_timer_val(val_watcher); caml_remove_generational_global_root((value*)(&(watcher->data))); ev_timer_stop(Ev_loop_val(loop), watcher); free(watcher); CAMLreturn(Val_unit); } #else LWT_NOT_AVAILABLE1(libev_init) LWT_NOT_AVAILABLE1(libev_stop) LWT_NOT_AVAILABLE2(libev_loop) LWT_NOT_AVAILABLE1(libev_unloop) LWT_NOT_AVAILABLE3(libev_readable_init) LWT_NOT_AVAILABLE3(libev_writable_init) LWT_NOT_AVAILABLE2(libev_io_stop) LWT_NOT_AVAILABLE4(libev_timer_init) LWT_NOT_AVAILABLE2(libev_timer_stop) #endif lwt-2.5.2/src/unix/lwt_log.ml000066400000000000000000000251611270742521300161110ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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] *) include Lwt_log_core open Lwt.Infix let program_name = Filename.basename Sys.executable_name (* Errors happening in this module are always logged to [stderr]: *) let log_intern fmt = Printf.eprintf ("%s: Lwt_log: " ^^ fmt ^^ "\n%!") program_name (* +-----------------------------------------------------------------+ | Templates | +-----------------------------------------------------------------+ *) 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" -> Lwt_log_core.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 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_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 >>= fun () -> Lwt_io.flush oc end channel) ~close:(match close_mode with | `Keep -> Lwt.return | `Close -> (fun () -> Lwt_io.close channel)) let _ = Lwt_log_core.default := 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_unix.openfile file_name flags perm >>= fun fd -> Lwt_unix.set_close_on_exec fd; let oc = Lwt_io.of_fd ~mode:Lwt_io.output fd in Lwt.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)); Lwt.fail (Sys_error(Unix.error_message Unix.ENOENT)) | path :: paths -> begin try Lwt.return (Some (Unix.stat path).Unix.st_kind) with | Unix.Unix_error(Unix.ENOENT, _, _) -> Lwt.return_none | Unix.Unix_error(error, _, _) -> log_intern "can not stat \"%s\": %s" path (Unix.error_message error); Lwt.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 Lwt.catch (fun () -> Lwt_unix.connect fd (Unix.ADDR_UNIX path) >>= fun () -> Lwt_unix.set_close_on_exec fd; Lwt.return (DGRAM, fd)) (function | Unix.Unix_error(Unix.EPROTOTYPE, _, _) -> begin Lwt_unix.close fd >>= fun () -> (* Then try with a stream socket: *) let fd = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in Lwt.catch (fun () -> Lwt_unix.connect fd (Unix.ADDR_UNIX path) >>= fun () -> Lwt_unix.set_close_on_exec fd; Lwt.return (STREAM, fd)) (function | Unix.Unix_error(error, _, _) -> Lwt_unix.close fd >>= fun () -> log_intern "can not connect to \"%s\": %s" path (Unix.error_message error); loop paths | exn -> Lwt.fail exn) end | Unix.Unix_error(error, _, _) -> Lwt_unix.close fd >>= fun () -> log_intern "can not connect to \"%s\": %s" path (Unix.error_message error); loop paths | exn -> Lwt.fail exn) 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 Lwt.return_unit else Lwt_unix.write_string fd str start_ofs (len - start_ofs) >>= fun n -> if n <> 0 then aux (start_ofs + n) else Lwt.return_unit in aux 0 let truncate buf max = if Buffer.length buf > max then begin let suffix = "" in let len_suffix = String.length suffix in Buffer.sub buf 0 (max - len_suffix) ^ suffix end else Buffer.contents buf let syslog ?(template="$(date) $(name)[$(pid)]: $(section): $(message)") ?(paths=["/dev/log"; "/var/run/log"; "/var/run/syslog"]) ~facility () = let syslog_socket = ref None and mutex = Lwt_mutex.create () in let get_syslog () = match !syslog_socket with | Some x -> Lwt.return x | None -> syslog_connect paths >>= fun x -> syslog_socket := Some x; Lwt.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 | [] -> Lwt.return_unit | line :: lines -> Lwt.catch (fun () -> write_string fd (make_line socket_type line) >>= fun () -> print socket_type fd lines) (function | Unix.Unix_error(_, _, _) -> (* Try to reconnect *) shutdown fd >>= fun () -> syslog_socket := None; get_syslog () >>= fun (socket_type, fd) -> write_string fd (make_line socket_type line) >>= fun () -> print socket_type fd lines | exn -> Lwt.fail exn) in get_syslog () >>= fun (socket_type, fd) -> print socket_type fd lines)) ~close:(fun () -> match !syslog_socket with | None -> Lwt.return_unit | Some(socket_type, fd) -> shutdown fd) lwt-2.5.2/src/unix/lwt_log.mli000066400000000000000000000074631270742521300162670ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 extends {!Lwt_log_core} with Unix features. It adds: - logging to the syslog daemon - logging to a channel (stderr, stdout, ...) - logging to a file *) include module type of Lwt_log_core with type level = Lwt_log_core.level and type logger = Lwt_log_core.logger and type section = Lwt_log_core.section and type template = Lwt_log_core.template and module Section = Lwt_log_core.Section val render : buffer : Buffer.t -> template : template -> section : section -> level : level -> message : string -> unit (** Same as {!Lwt_log_core.render}, except that the template may also contain the following variables: - [date] which will be replaced with the current date - [milliseconds] which will be replaced by the fractionnal part of the current unix time For example: - ["$(date) $(name)[$(pid)]: $(message)"] - ["$(date).$(milliseconds) $(name)[$(pid)]: $(message)"] - ["$(date): $(loc-file): $(loc-line): $(loc-column): $(message)"] *) (** Syslog facility. Look at the SYSLOG(3) man page for a description of syslog facilities *) type syslog_facility = [ `Auth | `Authpriv | `Cron | `Daemon | `FTP | `Kernel | `Local0 | `Local1 | `Local2 | `Local3 | `Local4 | `Local5 | `Local6 | `Local7 | `LPR | `Mail | `News | `Syslog | `User | `UUCP | `NTP | `Security | `Console ] val syslog : ?template : template -> ?paths : string list -> facility : syslog_facility -> unit -> logger (** [syslog ?template ?paths ~facility ()] creates an logger which send message to the system logger. @param paths is a list of path to try for the syslogd socket. It default to [\["/dev/log"; "/var/run/log"\]]. @param template defaults to ["$(date) $(name)[$(pid)]: $(section): $(message)"] *) val file : ?template : template -> ?mode : [ `Truncate | `Append ] -> ?perm : Unix.file_perm -> file_name : string -> unit -> logger Lwt.t (** [desf_file ?template ?mode ?perm ~file_name ()] creates an logger which will write messages to [file_name]. - if [mode = `Truncate] then the file is truncated and previous contents will be lost. - if [mode = `Append], new messages will be appended at the end of the file @param mode defaults to [`Append] @param template defaults to ["$(date): $(section): $(message)"] *) val channel :?template : template -> close_mode : [ `Close | `Keep ] -> channel : Lwt_io.output_channel -> unit -> logger (** [channel ?template ~close_mode ~channel ()] creates a logger from a channel. If [close_mode = `Close] then [channel] is closed when the logger is closed, otherwise it is left open. @param template defaults to ["$(name): $(section): $(message)"] *) lwt-2.5.2/src/unix/lwt_main.ml000066400000000000000000000044341270742521300162540ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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.Infix let enter_iter_hooks = Lwt_sequence.create () let leave_iter_hooks = Lwt_sequence.create () let yielded = Lwt_sequence.create () let yield () = Lwt.add_task_r yielded let rec run t = (* Wakeup paused threads now. *) Lwt.wakeup_paused (); match Lwt.poll t with | Some x -> x | None -> (* Call enter hooks. *) Lwt_sequence.iter_l (fun f -> f ()) enter_iter_hooks; (* Do the main loop call. *) Lwt_engine.iter (Lwt.paused_count () = 0 && Lwt_sequence.is_empty yielded); (* Wakeup paused threads again. *) Lwt.wakeup_paused (); (* Wakeup yielded threads now. *) if not (Lwt_sequence.is_empty yielded) then begin let tmp = Lwt_sequence.create () in Lwt_sequence.transfer_r yielded tmp; Lwt_sequence.iter_l (fun wakener -> Lwt.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 -> Lwt.return_unit | Some f -> Lwt.catch (fun () -> f ()) (fun _ -> Lwt.return_unit) >>= fun () -> call_hooks () let () = at_exit (fun () -> run (call_hooks ())) let at_exit f = ignore (Lwt_sequence.add_l f exit_hooks) lwt-2.5.2/src/unix/lwt_main.mli000066400000000000000000000045651270742521300164320ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_main * Copyright (C) 2009-2011 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (** Main loop and event queue *) (** This module controls the ``main-loop'' of Lwt. *) val run : 'a Lwt.t -> 'a (** [run t] calls the Lwt scheduler repeatedly until [t] terminates, then returns the value returned by the thread. It [t] fails with an exception, this exception is raised. Note that you should avoid using [run] inside threads - The calling threads will not resume before [run] returns. - Successive invocations of [run] are serialized: an invocation of [run] will not terminate before all subsequent invocations are terminated. Note also that it is not safe to call [run] in a function registered with [Pervasives.at_exit], use the {!at_exit} function of this module instead. *) val yield : unit -> unit Lwt.t (** [yield ()] is a threads which suspends itself and then resumes as soon as possible and terminates. *) val enter_iter_hooks : (unit -> unit) Lwt_sequence.t (** Functions that are called before the main iteration. *) val leave_iter_hooks : (unit -> unit) Lwt_sequence.t (** Functions that are called after the main iteration. *) val exit_hooks : (unit -> unit Lwt.t) Lwt_sequence.t (** Sets of functions executed just before the program exit. Notes: - each hook is called exactly one time - exceptions raised by hooks are ignored *) val at_exit : (unit -> unit Lwt.t) -> unit (** [at_exit hook] adds hook at the left of [exit_hooks]*) lwt-2.5.2/src/unix/lwt_process.ml000066400000000000000000000403731270742521300170100ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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.Infix type command = string * string array let shell = if Sys.win32 then fun cmd -> ("", [|"cmd.exe"; "/c"; "\000" ^ cmd|]) else fun cmd -> ("", [|"/bin/sh"; "-c"; cmd|]) type redirection = [ `Keep | `Dev_null | `Close | `FD_copy of Unix.file_descr | `FD_move of Unix.file_descr ] (* +-----------------------------------------------------------------+ | OS-depentent command spawning | +-----------------------------------------------------------------+ *) type proc = { id : int; (* The process id. *) fd : Unix.file_descr; (* A handle on windows, and a dummy value of Unix. *) } let win32_get_fd fd redirection = match redirection with | `Keep -> Some fd | `Dev_null -> Some (Unix.openfile "nul" [Unix.O_RDWR] 0o666) | `Close -> None | `FD_copy fd' -> Some fd' | `FD_move fd' -> Some fd' external win32_create_process : string option -> string -> string option -> (Unix.file_descr option * Unix.file_descr option * Unix.file_descr option) -> proc = "lwt_process_create_process" let win32_quote arg = if String.length arg > 0 && arg.[0] = '\000' then String.sub arg 1 (String.length arg - 1) else Filename.quote arg let win32_spawn (prog, args) env ?(stdin:redirection=`Keep) ?(stdout:redirection=`Keep) ?(stderr:redirection=`Keep) toclose = let cmdline = String.concat " " (List.map win32_quote (Array.to_list args)) in let env = match env with | None -> None | Some env -> let len = Array.fold_left (fun len str -> String.length str + len + 1) 1 env in let res = Bytes.create len in let ofs = Array.fold_left (fun ofs str -> let len = String.length str in String.blit str 0 res ofs len; Bytes.set res (ofs + len) '\000'; ofs + len + 1) 0 env in Bytes.set res ofs '\000'; Some (Bytes.unsafe_to_string res) in List.iter Unix.set_close_on_exec toclose; let stdin_fd = win32_get_fd Unix.stdin stdin and stdout_fd = win32_get_fd Unix.stdout stdout and stderr_fd = win32_get_fd Unix.stderr stderr in let proc = win32_create_process (if prog = "" then None else Some prog) cmdline env (stdin_fd, stdout_fd, stderr_fd) in let close = function | `FD_move fd -> Unix.close fd | _ -> () in close stdin; close stdout; close stderr; proc external win32_wait_job : Unix.file_descr -> int Lwt_unix.job = "lwt_process_wait_job" let win32_waitproc proc = Lwt_unix.run_job (win32_wait_job proc.fd) >>= fun code -> Lwt.return (proc.id, Lwt_unix.WEXITED code, { Lwt_unix.ru_utime = 0.; Lwt_unix.ru_stime = 0. }) external win32_terminate_process : Unix.file_descr -> int -> unit = "lwt_process_terminate_process" let win32_terminate proc = win32_terminate_process proc.fd 1 let unix_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' external sys_exit : int -> 'a = "caml_sys_exit" let unix_spawn (prog, args) env ?(stdin:redirection=`Keep) ?(stdout:redirection=`Keep) ?(stderr:redirection=`Keep) toclose = let prog = if prog = "" && Array.length args > 0 then args.(0) else prog in match Lwt_unix.fork () with | 0 -> unix_redirect Unix.stdin stdin; unix_redirect Unix.stdout stdout; unix_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 _ -> (* Do not run at_exit hooks *) sys_exit 127 end | id -> let close = function | `FD_move fd -> Unix.close fd | _ -> () in close stdin; close stdout; close stderr; { id; fd = Unix.stdin } let unix_waitproc proc = Lwt_unix.wait4 [] proc.id let unix_terminate proc = Unix.kill proc.id Sys.sigkill let spawn = if Sys.win32 then win32_spawn else unix_spawn let waitproc = if Sys.win32 then win32_waitproc else unix_waitproc let terminate = if Sys.win32 then win32_terminate else unix_terminate (* +-----------------------------------------------------------------+ | Objects | +-----------------------------------------------------------------+ *) type state = | Running | Exited of Unix.process_status let status (pid, status, rusage) = status let rusage (pid, status, rusage) = rusage external cast_chan : 'a Lwt_io.channel -> unit Lwt_io.channel = "%identity" (* Transform a channel into a channel that only support closing. *) let ignore_close chan = ignore (Lwt_io.close chan) class virtual common timeout proc channels = let wait = waitproc proc in object(self) val mutable closed = false method pid = proc.id method state = match Lwt.poll wait with | None -> Running | Some (pid, status, rusage) -> Exited status method kill signum = if Lwt.state wait = Lwt.Sleep then Unix.kill proc.id signum method terminate = if Lwt.state wait = Lwt.Sleep then terminate proc method close = if closed then self#status else ( closed <- true; Lwt.protected (Lwt.join (List.map Lwt_io.close channels)) >>= fun () -> self#status ) method status = Lwt.protected wait >|= status method rusage = Lwt.protected wait >|= rusage initializer (* Ensure channels are closed when no longer used. *) List.iter (Gc.finalise ignore_close) channels; (* Handle timeout. *) match timeout with | None -> () | Some dt -> ignore ( (* Ignore errors since they can be obtained by self#close. *) Lwt.try_bind (fun () -> Lwt.choose [(Lwt_unix.sleep dt >>= fun () -> Lwt.return_false); (wait >>= fun _ -> Lwt.return_true)]) (function | true -> Lwt.return_unit | false -> self#terminate; self#close >>= fun _ -> Lwt.return_unit) (fun exn -> (* The exception is dropped because it can be obtained with self#close. *) Lwt.return_unit) ) end class process_none ?timeout ?env ?stdin ?stdout ?stderr cmd = let proc = spawn cmd env ?stdin ?stdout ?stderr [] in object inherit common timeout proc [] end class process_in ?timeout ?env ?stdin ?stderr cmd = let stdout_r, stdout_w = Unix.pipe () in let proc = spawn cmd env ?stdin ~stdout:(`FD_move stdout_w) ?stderr [stdout_r] in let stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r in object inherit common timeout proc [cast_chan stdout] method stdout = stdout end class process_out ?timeout ?env ?stdout ?stderr cmd = let stdin_r, stdin_w = Unix.pipe () in let proc = spawn cmd env ~stdin:(`FD_move stdin_r) ?stdout ?stderr [stdin_w] in let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w in object inherit common timeout proc [cast_chan stdin] method stdin = stdin end class process ?timeout ?env ?stderr cmd = let stdin_r, stdin_w = Unix.pipe () and stdout_r, stdout_w = Unix.pipe () in let proc = spawn cmd env ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ?stderr [stdin_w; stdout_r] in let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w and stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r in object inherit common timeout proc [cast_chan stdin; cast_chan stdout] method stdin = stdin method stdout = stdout end class process_full ?timeout ?env cmd = let stdin_r, stdin_w = Unix.pipe () and stdout_r, stdout_w = Unix.pipe () and stderr_r, stderr_w = Unix.pipe () in let proc = spawn cmd env ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ~stderr:(`FD_move stderr_w) [stdin_w; stdout_r; stderr_r] in let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w and stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r and stderr = Lwt_io.of_unix_fd ~mode:Lwt_io.input stderr_r in object inherit common timeout proc [cast_chan stdin; cast_chan stdout; cast_chan stderr] method stdin = stdin method stdout = stdout method stderr = stderr end let open_process_none ?timeout ?env ?stdin ?stdout ?stderr cmd = new process_none ?timeout ?env ?stdin ?stdout ?stderr cmd let open_process_in ?timeout ?env ?stdin ?stderr cmd = new process_in ?timeout ?env ?stdin ?stderr cmd let open_process_out ?timeout ?env ?stdout ?stderr cmd = new process_out ?timeout ?env ?stdout ?stderr cmd let open_process ?timeout ?env ?stderr cmd = new process ?timeout ?env ?stderr cmd let open_process_full ?timeout ?env cmd = new process_full ?timeout ?env cmd let make_with backend ?timeout ?env cmd f = let process = backend ?timeout ?env cmd in Lwt.finalize (fun () -> f process) (fun () -> process#close >>= fun _ -> Lwt.return_unit) 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 ignore_close ch = ignore (Lwt_io.close ch) let read_opt read ic = Lwt.catch (fun () -> read ic >|= fun x -> Some x) (function | Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file -> Lwt.return_none | exn -> Lwt.fail exn) let recv_chars pr = let ic = pr#stdout in Gc.finalise ignore_close ic; Lwt_stream.from (fun _ -> read_opt Lwt_io.read_char ic >>= fun x -> if x = None then begin Lwt_io.close ic >>= fun () -> Lwt.return x end else Lwt.return x) let recv_lines pr = let ic = pr#stdout in Gc.finalise ignore_close ic; Lwt_stream.from (fun _ -> read_opt Lwt_io.read_line ic >>= fun x -> if x = None then begin Lwt_io.close ic >>= fun () -> Lwt.return x end else Lwt.return x) let recv pr = let ic = pr#stdout in Lwt.finalize (fun () -> Lwt_io.read ic) (fun () -> Lwt_io.close ic) let recv_line pr = let ic = pr#stdout in Lwt.finalize (fun () -> Lwt_io.read_line ic) (fun () -> Lwt_io.close ic) let send f pr data = let oc = pr#stdin in Lwt.finalize (fun () -> f oc data) (fun () -> Lwt_io.close oc) (* Receiving *) let pread ?timeout ?env ?stdin ?stderr cmd = recv (open_process_in ?timeout ?env ?stdin ?stderr cmd) let pread_chars ?timeout ?env ?stdin ?stderr cmd = recv_chars (open_process_in ?timeout ?env ?stdin ?stderr cmd) let pread_line ?timeout ?env ?stdin ?stderr cmd = recv_line (open_process_in ?timeout ?env ?stdin ?stderr cmd) let pread_lines ?timeout ?env ?stdin ?stderr cmd = recv_lines (open_process_in ?timeout ?env ?stdin ?stderr cmd) (* Sending *) let pwrite ?timeout ?env ?stdout ?stderr cmd text = send Lwt_io.write (open_process_out ?timeout ?env ?stdout ?stderr cmd) text let pwrite_chars ?timeout ?env ?stdout ?stderr cmd chars = send Lwt_io.write_chars (open_process_out ?timeout ?env ?stdout ?stderr cmd) chars let pwrite_line ?timeout ?env ?stdout ?stderr cmd line = send Lwt_io.write_line (open_process_out ?timeout ?env ?stdout ?stderr cmd) line let pwrite_lines ?timeout ?env ?stdout ?stderr cmd lines = send Lwt_io.write_lines (open_process_out ?timeout ?env ?stdout ?stderr cmd) lines (* Mapping *) type 'a map_state = | Init | Save of 'a option Lwt.t | Done (* Monitor the thread [sender] in the stream [st] so write errors are reported. *) let monitor sender st = let sender = sender >|= fun () -> None in let state = ref Init in Lwt_stream.from (fun () -> match !state with | Init -> let getter = Lwt.apply Lwt_stream.get st in let result _ = match Lwt.state sender with | Lwt.Sleep -> (* The sender is still sleeping, behave as the getter. *) getter | Lwt.Return _ -> (* The sender terminated successfully, we are done monitoring it. *) state := Done; getter | Lwt.Fail _ -> (* The sender failed, behave as the sender for this element and save current getter. *) state := Save getter; sender in Lwt.try_bind (fun () -> Lwt.choose [sender; getter]) result result | Save t -> state := Done; t | Done -> Lwt_stream.get st) let pmap ?timeout ?env ?stderr cmd text = let pr = open_process ?timeout ?env ?stderr cmd in (* Start the sender and getter at the same time. *) let sender = send Lwt_io.write pr text in let getter = recv pr in Lwt.catch (fun () -> (* Wait for both to terminate, returning the result of the getter. *) sender >>= fun () -> getter) (function | Lwt.Canceled as exn -> (* Cancel the getter if the sender was canceled. *) Lwt.cancel getter; Lwt.fail exn | exn -> Lwt.fail exn) let pmap_chars ?timeout ?env ?stderr cmd chars = let pr = open_process ?timeout ?env ?stderr cmd in let sender = send Lwt_io.write_chars pr chars in monitor sender (recv_chars pr) let pmap_line ?timeout ?env ?stderr cmd line = let pr = open_process ?timeout ?env ?stderr cmd in (* Start the sender and getter at the same time. *) let sender = send Lwt_io.write_line pr line in let getter = recv_line pr in Lwt.catch (fun () -> (* Wait for both to terminate, returning the result of the getter. *) sender >>= fun () -> getter) (function | Lwt.Canceled as exn -> (* Cancel the getter if the sender was canceled. *) Lwt.cancel getter; Lwt.fail exn | exn -> Lwt.fail exn) let pmap_lines ?timeout ?env ?stderr cmd lines = let pr = open_process ?timeout ?env ?stderr cmd in let sender = send Lwt_io.write_lines pr lines in monitor sender (recv_lines pr) lwt-2.5.2/src/unix/lwt_process.mli000066400000000000000000000210111270742521300171450ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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. *) (** Process management *) (** This module allows you to spawn processes and communicate with them. *) type command = string * string array (** A command. The first field is the name of the executable and the second is the list of arguments. For example: {[ ("ls", [|"ls"; "-l"|]) ]}. Notes: - if the name is the empty string, then the first argument will be used. You should specify a name only if you do not want the executable to be searched in the PATH. On Windows the only way to enable automatic seach in PATH is to pass an empty name. - it is possible to ``inline'' an argument, i.e. split it into multiple arguments. To do that prefix it with ["\000"]. For example: {[ ("", [|"echo"; "\000foo bar"|]) ]} is the same as: {[ ("", [|"echo"; "foo"; "bar"|]) ]}. *) val shell : string -> command (** A command executed with the shell. (with ["/bin/sh -c "] on Unix and ["cmd.exe /c "] on Windows). *) (** All the following functions take an optional argument [timeout]. If specified, after expiration, the process will be sent a [Unix.sigkill] signal and channels will be closed. *) (** {2 High-level functions} *) (** {3 Redirections} *) (** A file descriptor redirection. It describes 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 optional redirection arguments default to [`Keep] *) (** {3 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. *) (** {3 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 (** {3 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 (** {3 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 (** {2 Spawning processes} *) (** State of a sub-process *) type state = | Running (** The process is still running *) | Exited of Unix.process_status (** The process has exited *) class process_none : ?timeout : float -> ?env : string array -> ?stdin : redirection -> ?stdout : redirection -> ?stderr : redirection -> command -> object method pid : int (** Pid of the sub-process *) method state : state (** Return the state of the process *) method kill : int -> unit (** [kill signum] sends [signum] to the process if it is still running. *) method terminate : unit (** Terminates the process. It is equivalent to [kill Sys.sigkill] on Unix but also works on Windows (unlike {!kill}). *) method status : Unix.process_status Lwt.t (** Threads which wait for the sub-process to exit then returns its exit status *) method rusage : Lwt_unix.resource_usage Lwt.t (** Threads which wait for the sub-process to exit then returns its resource usages *) method close : Unix.process_status Lwt.t (** Closes the process and returns its exit status. This closes all channels used to communicate with the process *) end val open_process_none : ?timeout : float -> ?env : string array -> ?stdin : redirection -> ?stdout : redirection -> ?stderr : redirection -> command -> process_none val with_process_none : ?timeout : float -> ?env : string array -> ?stdin : redirection -> ?stdout : redirection -> ?stderr : redirection -> command -> (process_none -> 'a Lwt.t) -> 'a Lwt.t class process_in : ?timeout : float -> ?env : string array -> ?stdin : redirection -> ?stderr : redirection -> command -> object inherit process_none method stdout : Lwt_io.input_channel (** The standard output of the process *) end val open_process_in : ?timeout : float -> ?env : string array -> ?stdin : redirection -> ?stderr : redirection -> command -> process_in val with_process_in : ?timeout : float -> ?env : string array -> ?stdin : redirection -> ?stderr : redirection -> command -> (process_in -> 'a Lwt.t) -> 'a Lwt.t class process_out : ?timeout : float -> ?env : string array -> ?stdout : redirection -> ?stderr : redirection -> command -> object inherit process_none method stdin : Lwt_io.output_channel (** The standard input of the process *) end val open_process_out : ?timeout : float -> ?env : string array -> ?stdout : redirection -> ?stderr : redirection -> command -> process_out val with_process_out : ?timeout : float -> ?env : string array -> ?stdout : redirection -> ?stderr : redirection -> command -> (process_out -> 'a Lwt.t) -> 'a Lwt.t class process : ?timeout : float -> ?env : string array -> ?stderr : redirection -> command -> object inherit process_none method stdin : Lwt_io.output_channel method stdout : Lwt_io.input_channel end val open_process : ?timeout : float -> ?env : string array -> ?stderr : redirection -> command -> process val with_process : ?timeout : float -> ?env : string array -> ?stderr : redirection -> command -> (process -> 'a Lwt.t) -> 'a Lwt.t class process_full : ?timeout : float -> ?env : string array -> command -> object inherit process_none method stdin : Lwt_io.output_channel method stdout : Lwt_io.input_channel method stderr : Lwt_io.input_channel end val open_process_full : ?timeout : float -> ?env : string array -> command -> process_full val with_process_full : ?timeout : float -> ?env : string array -> command -> (process_full -> 'a Lwt.t) -> 'a Lwt.t lwt-2.5.2/src/unix/lwt_process_stubs.c000066400000000000000000000063721270742521300200430ustar00rootroot00000000000000/* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_process_stubs * Copyright (C) 2012 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. */ #include #if defined(LWT_ON_WINDOWS) #include #include #include #include static HANDLE get_handle(value opt) { value fd; if (Is_block(opt)) { fd = Field(opt, 0); if (Descr_kind_val(fd) == KIND_SOCKET) { win32_maperr(ERROR_INVALID_HANDLE); uerror("CreateProcess", Nothing); return NULL; } else return Handle_val(fd); } else return INVALID_HANDLE_VALUE; } #define string_option(opt) (Is_block(opt) ? String_val(Field(opt, 0)) : NULL) CAMLprim value lwt_process_create_process(value prog, value cmdline, value env, value fds) { CAMLparam4(prog, cmdline, env, fds); CAMLlocal1(result); STARTUPINFO si; PROCESS_INFORMATION pi; ZeroMemory(&si, sizeof(si)); ZeroMemory(&pi, sizeof(pi)); si.cb = sizeof(si); si.dwFlags = STARTF_USESTDHANDLES; si.hStdInput = get_handle(Field(fds, 0)); si.hStdOutput = get_handle(Field(fds, 1)); si.hStdError = get_handle(Field(fds, 2)); if (!CreateProcess(string_option(prog), String_val(cmdline), NULL, NULL, TRUE, 0, string_option(env), NULL, &si, &pi)) { win32_maperr(GetLastError()); uerror("CreateProcess", Nothing); } CloseHandle(pi.hThread); result = caml_alloc_tuple(2); Store_field(result, 0, Val_int(pi.dwProcessId)); Store_field(result, 1, win_alloc_handle(pi.hProcess)); CAMLreturn(result); } struct job_wait { struct lwt_unix_job job; HANDLE handle; }; static void worker_wait(struct job_wait *job) { WaitForSingleObject(job->handle, INFINITE); } static value result_wait(struct job_wait *job) { DWORD code, error; if (!GetExitCodeProcess(job->handle, &code)) { error = GetLastError(); CloseHandle(job->handle); lwt_unix_free_job(&job->job); win32_maperr(error); uerror("GetExitCodeProcess", Nothing); } CloseHandle(job->handle); lwt_unix_free_job(&job->job); return Val_int(code); } CAMLprim value lwt_process_wait_job(value handle) { LWT_UNIX_INIT_JOB(job, wait, 0); job->handle = Handle_val(handle); return lwt_unix_alloc_job(&(job->job)); } CAMLprim value lwt_process_terminate_process(value handle, value code) { if (!TerminateProcess(Handle_val(handle), Int_val(code))) { win32_maperr(GetLastError()); uerror("TerminateProcess", Nothing); } return Val_unit; } #endif /* defined(LWT_ON_WINDOWS) */ lwt-2.5.2/src/unix/lwt_sys.ml000066400000000000000000000035221270742521300161430ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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. *) exception Not_available of string let () = Callback.register_exception "lwt:not-available" (Not_available "") let windows = Sys.win32 type feature = [ `wait4 | `get_cpu | `get_affinity | `set_affinity | `recv_msg | `send_msg | `fd_passing | `get_credentials | `mincore | `madvise | `fdatasync | `libev ] let have = function | `wait4 | `recv_msg | `send_msg | `madvise -> not Sys.win32 | `mincore -> not (Sys.win32 || Sys.cygwin) | `get_cpu -> Lwt_config._HAVE_GETCPU | `get_affinity | `set_affinity -> Lwt_config._HAVE_AFFINITY | `fd_passing -> Lwt_config._HAVE_FD_PASSING | `get_credentials -> Lwt_config._HAVE_GET_CREDENTIALS | `fdatasync -> Lwt_config._HAVE_FDATASYNC | `libev -> Lwt_config._HAVE_LIBEV type byte_order = Little_endian | Big_endian external get_byte_order : unit -> byte_order = "lwt_unix_system_byte_order" let byte_order = get_byte_order () lwt-2.5.2/src/unix/lwt_sys.mli000066400000000000000000000033321270742521300163130ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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. Deprecated; use [Sys.win32]. *) (** Features that can be tested. *) type feature = [ `wait4 | `get_cpu | `get_affinity | `set_affinity | `recv_msg | `send_msg | `fd_passing | `get_credentials | `mincore | `madvise | `fdatasync | `libev ] val have : feature -> bool (** Test whether the given feature is available on the current system. *) type byte_order = Little_endian | Big_endian (** Type of byte order *) val byte_order : byte_order (** The byte order used by the computer running the program. *) lwt-2.5.2/src/unix/lwt_throttle.ml000066400000000000000000000072541270742521300172000ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_throttle * Copyright (C) 2008 Stéphane 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.Infix 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 -> Lwt.wakeup u true) to_run and launch_cleaning t = t.cleaning <- let t = Lwt_unix.sleep 1. >>= fun () -> Lwt.catch (fun () -> clean_table t; Lwt.return_unit) (fun 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 Lwt.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; Lwt.return_true) with | Not_found -> let elt = { consumed = 1; queue = Queue.create () } in MH.add t.table key elt; Lwt.return_true in (match t.cleaning with | None -> launch_cleaning t | Some _ -> ()); res end lwt-2.5.2/src/unix/lwt_throttle.mli000066400000000000000000000033401270742521300173410ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_throttle * Copyright (C) 2008 Stéphane Glondu * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (** Rate limiters *) (** This module defines rate limiters. A rate limiter is parametrized by its limit and a maximum waiting time. The [wait] function will collaboratively hang for a delay necessary to respect the limit. If that delay exceeds the maximum waiting time, [wait] returns [false]; otherwise it returns [true]. *) module type S = sig type key type t val create : rate:int -> max:int -> n:int -> t (** @param rate maximum number of connections per second @param max maximum waiting time (in seconds) @param n initial size of the hash table *) val wait : t -> key -> bool Lwt.t (** @return [false] if maximum reached, [true] else *) end module Make (H : Hashtbl.HashedType) : S with type key = H.t lwt-2.5.2/src/unix/lwt_timeout.ml000066400000000000000000000062201270742521300170110ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_timeout * Copyright (C) 2005-2008 Jérôme 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_unit end) let start x = let in_list = lst_in_list x in let slot = (!curr + x.delay) mod (Array.length !buckets) in lst_remove x; lst_insert !buckets.(slot) x; if not in_list then begin incr count; if !count = 1 && !stopped then ignore (loop ()) end let create delay action = if delay < 1 then invalid_arg "Lwt_timeout.create"; let x = make delay action in size delay; x let stop x = if lst_in_list x then begin lst_remove x; decr count end let change x delay = if delay < 1 then invalid_arg "Lwt_timeout.change"; x.delay <- delay; size delay; if lst_in_list x then start x lwt-2.5.2/src/unix/lwt_timeout.mli000066400000000000000000000031631270742521300171650ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_timeout * Copyright (C) 2005-2008 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (** Timeouts *) type t val set_exn_handler : (exn -> unit) -> unit (** set the default handler for exception occurring after a timeout. The function lauched after a timeout should not raise any exception. That's why the default handler will exit the program. *) val create : int -> (unit -> unit) -> t (** [create n f] defines a new timeout with [n] seconds duration. [f] is the function to be called after the timeout. That function must not raise any exception. *) val start : t -> unit (** starts a timeout. *) val stop : t -> unit (** stops a timeout. *) val change : t -> int -> unit (** changes the duration of a timeout. *) lwt-2.5.2/src/unix/lwt_unix.h000066400000000000000000000272041270742521300161320ustar00rootroot00000000000000/* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Header lwt_unix * Copyright (C) 2010 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. */ #ifndef __LWT_UNIX_H #define __LWT_UNIX_H #include #include #include /* The macro to get the file-descriptor from a value. */ #if defined(LWT_ON_WINDOWS) # define FD_val(value) win_CRT_fd_of_filedescr(value) #else # define FD_val(value) Int_val(value) #endif /* Macro to extract a libev loop from a caml value. */ #define Ev_loop_val(value) *(struct ev_loop**)Data_custom_val(value) /* +-----------------------------------------------------------------+ | Utils | +-----------------------------------------------------------------+ */ /* Allocate the given amount of memory and abort the program if there is no free memory left. */ void *lwt_unix_malloc(size_t size); void *lwt_unix_realloc(void *ptr, size_t size); /* Same as [strdup] and abort hte program if there is not memory left. */ char *lwt_unix_strdup(char *string); /* Helpers for allocating structures. */ #define lwt_unix_new(type) (type*)lwt_unix_malloc(sizeof(type)) #define lwt_unix_new_plus(type, size) (type*)lwt_unix_malloc(sizeof(type) + size) /* Raise [Lwt_unix.Not_available]. */ void lwt_unix_not_available(char const *feature) Noreturn; #define LWT_NOT_AVAILABLE1(prim) \ CAMLprim value lwt_ ## prim(value a1) \ { lwt_unix_not_available(#prim); } #define LWT_NOT_AVAILABLE2(prim) \ CAMLprim value lwt_ ## prim(value a1, value a2) \ { lwt_unix_not_available(#prim); } #define LWT_NOT_AVAILABLE3(prim) \ CAMLprim value lwt_ ## prim(value a1, value a2, value a3) \ { lwt_unix_not_available(#prim); } #define LWT_NOT_AVAILABLE4(prim) \ CAMLprim value lwt_ ## prim(value a1, value a2, value a3, value a4) \ { lwt_unix_not_available(#prim); } #define LWT_NOT_AVAILABLE5(prim) \ CAMLprim value lwt_ ## prim(value a1, value a2, value a3, value a4, value a5) \ { lwt_unix_not_available(#prim); } #define LWT_NOT_AVAILABLE6(prim) \ CAMLprim value lwt_ ## prim(value a1, value a2, value a3, value a4, value a5, value a6) \ { lwt_unix_not_available(#prim); } /* +-----------------------------------------------------------------+ | Notifications | +-----------------------------------------------------------------+ */ /* Sends a notification for the given id. */ void lwt_unix_send_notification(int id); /* +-----------------------------------------------------------------+ | Threading | +-----------------------------------------------------------------+ */ #if defined(HAVE_PTHREAD) #include typedef pthread_t lwt_unix_thread; typedef pthread_mutex_t lwt_unix_mutex; typedef pthread_cond_t lwt_unix_condition; #else typedef DWORD lwt_unix_thread; typedef CRITICAL_SECTION lwt_unix_mutex; typedef struct lwt_unix_condition lwt_unix_condition; #endif /* Launch a thread in detached mode. */ void lwt_unix_launch_thread(void* (*start)(void*), void* data); /* Return a handle to the currently running thread. */ lwt_unix_thread lwt_unix_thread_self(); /* Returns whether two thread handles refer to the same thread. */ int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2); /* Initialises a mutex. */ void lwt_unix_mutex_init(lwt_unix_mutex *mutex); /* Destroy a mutex. */ void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex); /* Lock a mutex. */ void lwt_unix_mutex_lock(lwt_unix_mutex *mutex); /* Unlock a mutex. */ void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex); /* Initialises a condition variable. */ void lwt_unix_condition_init(lwt_unix_condition *condition); /* Destroy a condition variable. */ void lwt_unix_condition_destroy(lwt_unix_condition *condition); /* Signal a condition variable. */ void lwt_unix_condition_signal(lwt_unix_condition *condition); /* Broadcast a signal on a condition variable. */ void lwt_unix_condition_broadcast(lwt_unix_condition *condition); /* Wait for a signal on a condition variable. */ void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex); /* +-----------------------------------------------------------------+ | Detached jobs | +-----------------------------------------------------------------+ */ /* How job are executed. */ enum lwt_unix_async_method { /* Synchronously. */ LWT_UNIX_ASYNC_METHOD_NONE = 0, /* Asynchronously, on another thread. */ LWT_UNIX_ASYNC_METHOD_DETACH = 1, /* Asynchronously, on the main thread, switcing to another thread if necessary. */ LWT_UNIX_ASYNC_METHOD_SWITCH = 2 }; /* Type of job execution modes. */ typedef enum lwt_unix_async_method lwt_unix_async_method; /* State of a job. */ enum lwt_unix_job_state { /* The job has not yet started. */ LWT_UNIX_JOB_STATE_PENDING, /* The job is running. */ LWT_UNIX_JOB_STATE_RUNNING, /* The job is done. */ LWT_UNIX_JOB_STATE_DONE }; /* A job descriptor. */ struct lwt_unix_job { /* The next job in the queue. */ struct lwt_unix_job *next; /* Id used to notify the main thread in case the job do not terminate immediately. */ int notification_id; /* The function to call to do the work. This function must not: - access or allocate OCaml block values (tuples, strings, ...), - call OCaml code. */ void (*worker)(struct lwt_unix_job *job); /* The function to call to extract the result and free memory allocated by the job. Note: if you want to raise an excpetion, be sure to free resources before raising it! It has been introduced in Lwt 2.3.3. */ value (*result)(struct lwt_unix_job *job); /* State of the job. */ enum lwt_unix_job_state state; /* Is the main thread still waiting for the job ? */ int fast; /* Mutex to protect access to [state] and [fast]. */ lwt_unix_mutex mutex; /* Thread running the job. */ lwt_unix_thread thread; /* The async method in used by the job. */ lwt_unix_async_method async_method; }; /* Type of job descriptors. */ typedef struct lwt_unix_job* lwt_unix_job; /* Type of worker functions. */ typedef void (*lwt_unix_job_worker)(lwt_unix_job job); /* Type of result functions. */ typedef value (*lwt_unix_job_result)(lwt_unix_job job); /* Allocate a caml custom value for the given job. */ value lwt_unix_alloc_job(lwt_unix_job job); /* Free resourecs allocated for this job and free it. */ void lwt_unix_free_job(lwt_unix_job job); /* +-----------------------------------------------------------------+ | Helpers for writing jobs | +-----------------------------------------------------------------+ */ /* Allocate a job structure and set its worker and result fields. - VAR is the name of the job variable. It is usually "job". - FUNC is the suffix of the structure name and functions of this job. It is usually the name of the function that is wrapped. - SIZE is the dynamic size to allocate at the end of the structure, in case it ends ends with something of the form: char data[]); */ #define LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE) \ struct job_##FUNC *VAR = lwt_unix_new_plus(struct job_##FUNC, SIZE); \ VAR->job.worker = (lwt_unix_job_worker)worker_##FUNC; \ VAR->job.result = (lwt_unix_job_result)result_##FUNC /* Same as LWT_UNIX_INIT_JOB, but also stores a string argument named ARG at the end of the job structure. The offset of the copied string is assigned to the field VAR->ARG. The structure must ends with: char data[]; */ #define LWT_UNIX_INIT_JOB_STRING(VAR, FUNC, SIZE, ARG) \ mlsize_t __len = caml_string_length(ARG); \ LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE + __len + 1); \ VAR->ARG = VAR->data + SIZE; \ memcpy(VAR->ARG, String_val(ARG), __len + 1) /* Same as LWT_UNIX_INIT_JOB, but also stores two string arguments named ARG1 and ARG2 at the end of the job structure. The offsets of the copied strings are assigned to the fields VAR->ARG1 and VAR->ARG2. The structure definition must ends with: char data[]; */ #define LWT_UNIX_INIT_JOB_STRING2(VAR, FUNC, SIZE, ARG1, ARG2) \ mlsize_t __len1 = caml_string_length(ARG1); \ mlsize_t __len2 = caml_string_length(ARG2); \ LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE + __len1 + __len2 + 2); \ VAR->ARG1 = VAR->data + SIZE; \ VAR->ARG2 = VAR->data + SIZE + __len1 + 1; \ memcpy(VAR->ARG1, String_val(ARG1), __len1 + 1); \ memcpy(VAR->ARG2, String_val(ARG2), __len2 + 1) /* If TEST is true, it frees the job and raises Unix.Unix_error using the value of errno stored in the field error_code. */ #define LWT_UNIX_CHECK_JOB(VAR, TEST, NAME) \ if (TEST) { \ int error_code = VAR->error_code; \ lwt_unix_free_job(&VAR->job); \ unix_error(error_code, NAME, Nothing); \ } /* If TEST is true, it frees the job and raises Unix.Unix_error using the value of errno stored in the field error_code and uses the C string ARG for the third field of Unix.Unix_error. */ #define LWT_UNIX_CHECK_JOB_ARG(VAR, TEST, NAME, ARG) \ if (TEST) { \ int error_code = VAR->error_code; \ value arg = caml_copy_string(ARG); \ lwt_unix_free_job(&VAR->job); \ unix_error(error_code, NAME, arg); \ } /* +-----------------------------------------------------------------+ | Deprecated | +-----------------------------------------------------------------+ */ /* Define not implement methods. Deprecated: it is for the old mechanism with three externals. */ #define LWT_UNIX_JOB_NOT_IMPLEMENTED(name) \ CAMLprim value lwt_unix_##name##_job(value Unit) \ { \ caml_invalid_argument("not implemented"); \ } \ \ CAMLprim value lwt_unix_##name##_result(value Unit) \ { \ caml_invalid_argument("not implemented"); \ } \ \ CAMLprim value lwt_unix_##name##_free(value Unit) \ { \ caml_invalid_argument("not implemented"); \ } #endif /* __LWT_UNIX_H */ lwt-2.5.2/src/unix/lwt_unix.ml000066400000000000000000001766531270742521300163300ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_unix * Copyright (C) 2005-2008 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * 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.Infix (* +-----------------------------------------------------------------+ | 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 = Lwt.with_value async_method_key (Some Async_none) f let with_async_detach f = Lwt.with_value async_method_key (Some Async_detach) f let with_async_switch f = Lwt.with_value async_method_key (Some Async_switch) f (* +-----------------------------------------------------------------+ | Notifications management | +-----------------------------------------------------------------+ *) (* Informations about a notifier *) type notifier = { notify_handler : unit -> unit; (* The callback *) notify_once : bool; (* Whether to remove the notifier after the reception of the first notification *) } module Notifiers = Hashtbl.Make(struct type t = int let equal (x : int) (y : int) = x = y let hash (x : int) = x end) let notifiers = Notifiers.create 1024 let current_notification_id = ref 0 let rec find_free_id id = if Notifiers.mem notifiers id then find_free_id (id + 1) else id let make_notification ?(once=false) f = let id = find_free_id (!current_notification_id + 1) in current_notification_id := id; Notifiers.add notifiers id { notify_once = once; notify_handler = f }; id let stop_notification id = Notifiers.remove notifiers id let set_notification id f = let notifier = Notifiers.find notifiers id in Notifiers.replace notifiers id { notifier with notify_handler = f } let call_notification id = match try Some(Notifiers.find notifiers id) with Not_found -> None with | Some notifier -> if notifier.notify_once then stop_notification id; notifier.notify_handler () | None -> () (* +-----------------------------------------------------------------+ | Sleepers | +-----------------------------------------------------------------+ *) let sleep delay = let waiter, wakener = Lwt.task () in let ev = Lwt_engine.on_timer delay false (fun ev -> Lwt_engine.stop_event ev; Lwt.wakeup wakener ()) in Lwt.on_cancel waiter (fun () -> Lwt_engine.stop_event ev); waiter let yield = Lwt_main.yield let auto_yield timeout = let limit = ref (Unix.gettimeofday () +. timeout) in fun () -> let current = Unix.gettimeofday () in if current >= !limit then begin limit := current +. timeout; yield (); end else Lwt.return_unit exception Timeout let timeout d = sleep d >>= fun () -> Lwt.fail Timeout let with_timeout d f = Lwt.pick [timeout d; Lwt.apply f ()] (* +-----------------------------------------------------------------+ | Jobs | +-----------------------------------------------------------------+ *) type 'a job external start_job : 'a job -> async_method -> bool = "lwt_unix_start_job" (* Starts the given job with given parameters. It returns [true] if the job is already terminated. *) external check_job : 'a job -> int -> bool = "lwt_unix_check_job" "noalloc" (* Check whether that a job has terminated or not. If it has not yet terminated, it is marked so it will send a notification when it finishes. *) (* For all running job, a waiter and a function to abort it. *) let jobs = Lwt_sequence.create () let rec abort_jobs exn = match Lwt_sequence.take_opt_l jobs with | Some (w, f) -> f exn; abort_jobs exn | None -> () let cancel_jobs () = abort_jobs Lwt.Canceled let wait_for_jobs () = Lwt.join (Lwt_sequence.fold_l (fun (w, f) l -> w :: l) jobs []) let wrap_result f x = try Lwt.make_value (f x) with exn -> Lwt.make_error exn let run_job_aux async_method job result = (* Starts the job. *) if start_job job async_method then (* The job has already terminated, read and return the result immediately. *) Lwt.of_result (result job) else begin (* Thread for the job. *) let waiter, wakener = Lwt.wait () in (* Add the job to the sequence of all jobs. *) let node = Lwt_sequence.add_l ( (waiter >>= fun _ -> Lwt.return_unit), (fun exn -> if Lwt.state waiter = Lwt.Sleep then Lwt.wakeup_exn wakener exn)) jobs in ignore begin (* Create the notification for asynchronous wakeup. *) let id = make_notification ~once:true (fun () -> Lwt_sequence.remove node; let result = result job in if Lwt.state waiter = Lwt.Sleep then Lwt.wakeup_result wakener result) in (* Give the job some time before we fallback to asynchronous notification. *) Lwt.pause () >>= fun () -> (* The job has terminated, send the result immediately. *) if check_job job id then call_notification id; Lwt.return_unit end; waiter end let choose_async_method = function | Some async_method -> async_method | None -> match Lwt.get async_method_key with | Some am -> am | None -> !default_async_method_var let execute_job ?async_method ~job ~result ~free = let async_method = choose_async_method async_method in run_job_aux async_method job (fun job -> let x = wrap_result result job in free job; x) external self_result : 'a job -> 'a = "lwt_unix_self_result" (* returns the result of a job using the [result] field of the C job structure. *) external run_job_sync : 'a job -> 'a = "lwt_unix_run_job_sync" (* Exeuctes a job synchronously and returns its result. *) let self_result job = try Lwt.make_value (self_result job) with exn -> Lwt.make_error exn let run_job ?async_method job = let async_method = choose_async_method async_method in if async_method = Async_none then try Lwt.return (run_job_sync job) with exn -> Lwt.fail exn else run_job_aux async_method job self_result (* +-----------------------------------------------------------------+ | File descriptor wrappers | +-----------------------------------------------------------------+ *) type state = Opened | Closed | Aborted of exn type file_descr = { fd : Unix.file_descr; (* The underlying unix file descriptor *) mutable state: state; (* The state of the file descriptor *) mutable set_flags : bool; (* Whether to set file flags *) mutable blocking : bool Lwt.t Lazy.t; (* Is the file descriptor in blocking or non-blocking mode *) mutable event_readable : Lwt_engine.event option; (* The event used to check the file descriptor for readability. *) mutable event_writable : Lwt_engine.event option; (* The event used to check the file descriptor for writability. *) hooks_readable : (unit -> unit) Lwt_sequence.t; (* Hooks to call when the file descriptor becomes readable. *) hooks_writable : (unit -> unit) Lwt_sequence.t; (* Hooks to call when the file descriptor becomes writable. *) } external is_socket : Unix.file_descr -> bool = "lwt_unix_is_socket" "noalloc" external guess_blocking_job : Unix.file_descr -> bool job = "lwt_unix_guess_blocking_job" let guess_blocking fd = run_job (guess_blocking_job fd) let is_blocking ?blocking ?(set_flags=true) fd = if Sys.win32 then begin if is_socket fd then match blocking, set_flags with | Some state, false -> lazy(Lwt.return state) | Some true, true -> Unix.clear_nonblock fd; lazy(Lwt.return_true) | Some false, true -> Unix.set_nonblock fd; lazy(Lwt.return_false) | None, false -> lazy(Lwt.return_false) | None, true -> Unix.set_nonblock fd; lazy(Lwt.return_false) else match blocking with | Some state -> lazy(Lwt.return state) | None -> lazy(Lwt.return_true) end else begin match blocking, set_flags with | Some state, false -> lazy(Lwt.return state) | Some true, true -> Unix.clear_nonblock fd; lazy(Lwt.return_true) | Some false, true -> Unix.set_nonblock fd; lazy(Lwt.return_false) | None, false -> lazy(guess_blocking fd) | None, true -> lazy(guess_blocking fd >>= function | true -> Unix.clear_nonblock fd; Lwt.return_true | false -> Unix.set_nonblock fd; Lwt.return_false) end 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 external unix_stub_readable : Unix.file_descr -> bool = "lwt_unix_readable" external unix_stub_writable : Unix.file_descr -> bool = "lwt_unix_writable" let rec unix_readable fd = try if Sys.win32 then Unix.select [fd] [] [] 0.0 <> ([], [], []) else unix_stub_readable fd with Unix.Unix_error (Unix.EINTR, _, _) -> unix_readable fd let rec unix_writable fd = try if Sys.win32 then Unix.select [] [fd] [] 0.0 <> ([], [], []) else unix_stub_writable fd with Unix.Unix_error (Unix.EINTR, _, _) -> unix_writable fd let readable ch = check_descriptor ch; unix_readable ch.fd let writable ch = check_descriptor ch; unix_writable ch.fd let set_state ch st = ch.state <- st let clear_events ch = Lwt_sequence.iter_node_l (fun node -> Lwt_sequence.remove node; Lwt_sequence.get node ()) ch.hooks_readable; Lwt_sequence.iter_node_l (fun node -> Lwt_sequence.remove node; Lwt_sequence.get node ()) ch.hooks_writable; begin match ch.event_readable with | Some ev -> ch.event_readable <- None; Lwt_engine.stop_event ev | None -> () end; begin match ch.event_writable with | Some ev -> ch.event_writable <- None; Lwt_engine.stop_event ev | None -> () end let abort ch e = if ch.state <> Closed then begin set_state ch (Aborted e); clear_events ch end let unix_file_descr ch = ch.fd let of_unix_file_descr = mk_ch let stdin = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stdin let stdout = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stdout let stderr = of_unix_file_descr ~set_flags:false ~blocking:true Unix.stderr (* +-----------------------------------------------------------------+ | Actions on file descriptors | +-----------------------------------------------------------------+ *) type io_event = Read | Write exception Retry exception Retry_write exception Retry_read type 'a outcome = | Success of 'a | Exn of exn | Requeued of io_event (* Wait a bit, then stop events that are no more used. *) let stop_events ch = Lwt.on_success (Lwt.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; Lwt.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; Lwt.on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); register_writable ch; waiter (* Wraps a system call *) let wrap_syscall event ch action = check_descriptor ch; Lazy.force ch.blocking >>= fun blocking -> try if not blocking || (event = Read && unix_readable ch.fd) || (event = Write && unix_writable ch.fd) then Lwt.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 immediately, register it: *) register_action event ch action | Retry_read -> register_action Read ch action | Retry_write -> register_action Write ch action | e -> Lwt.fail e (* +-----------------------------------------------------------------+ | Generated jobs | +-----------------------------------------------------------------+ *) module Jobs = Lwt_unix_jobs_generated.Make(struct type 'a t = 'a job end) (* +-----------------------------------------------------------------+ | Basic file input/output | +-----------------------------------------------------------------+ *) type open_flag = Unix.open_flag = | O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC | O_SHARE_DELETE | O_CLOEXEC external open_job : string -> Unix.open_flag list -> int -> (Unix.file_descr * bool) job = "lwt_unix_open_job" let openfile name flags perms = if Sys.win32 then Lwt.return (of_unix_file_descr (Unix.openfile name flags perms)) else run_job (open_job name flags perms) >>= fun (fd, blocking) -> Lwt.return (of_unix_file_descr ~blocking fd) let close ch = if ch.state = Closed then check_descriptor ch; set_state ch Closed; clear_events ch; if Sys.win32 then Lwt.return (Unix.close ch.fd) else run_job (Jobs.close_job ch.fd) let wait_read ch = Lwt.catch (fun () -> if readable ch then Lwt.return_unit else register_action Read ch ignore) Lwt.fail external stub_read : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_read" external read_job : Unix.file_descr -> Bytes.t -> int -> int -> int job = "lwt_unix_read_job" let read ch buf pos len = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.read" else Lazy.force ch.blocking >>= function | true -> wait_read ch >>= fun () -> run_job (read_job ch.fd buf pos len) | false -> wrap_syscall Read ch (fun () -> stub_read ch.fd buf pos len) let wait_write ch = Lwt.catch (fun () -> if writable ch then Lwt.return_unit else register_action Write ch ignore) Lwt.fail external stub_write : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_write" external write_job : Unix.file_descr -> Bytes.t -> int -> int -> int job = "lwt_unix_write_job" let write ch buf pos len = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.write" else Lazy.force ch.blocking >>= function | true -> wait_write ch >>= fun () -> run_job (write_job ch.fd buf pos len) | false -> wrap_syscall Write ch (fun () -> stub_write ch.fd buf pos len) let write_string ch buf pos len = let buf = Bytes.unsafe_of_string buf in write ch buf pos len (* +-----------------------------------------------------------------+ | Seeking and truncating | +-----------------------------------------------------------------+ *) type seek_command = Unix.seek_command = | SEEK_SET | SEEK_CUR | SEEK_END let lseek ch offset whence = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.lseek ch.fd offset whence) else run_job (Jobs.lseek_job ch.fd offset whence) let truncate name offset = if Sys.win32 then Lwt.return (Unix.truncate name offset) else run_job (Jobs.truncate_job name offset) let ftruncate ch offset = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.ftruncate ch.fd offset) else run_job (Jobs.ftruncate_job ch.fd offset) (* +-----------------------------------------------------------------+ | File system synchronisation | +-----------------------------------------------------------------+ *) let fdatasync ch = check_descriptor ch; run_job (Jobs.fdatasync_job ch.fd) let fsync ch = check_descriptor ch; run_job (Jobs.fsync_job ch.fd) (* +-----------------------------------------------------------------+ | File status | +-----------------------------------------------------------------+ *) type file_perm = Unix.file_perm type file_kind = Unix.file_kind = | S_REG | S_DIR | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK type stats = Unix.stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int; st_atime : float; st_mtime : float; st_ctime : float; } external stat_job : string -> Unix.stats job = "lwt_unix_stat_job" let stat name = if Sys.win32 then Lwt.return (Unix.stat name) else run_job (stat_job name) external lstat_job : string -> Unix.stats job = "lwt_unix_lstat_job" let lstat name = if Sys.win32 then Lwt.return (Unix.stat name) else run_job (lstat_job name) external fstat_job : Unix.file_descr -> Unix.stats job = "lwt_unix_fstat_job" let fstat ch = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.fstat ch.fd) else run_job (fstat_job ch.fd) let file_exists name = Lwt.try_bind (fun () -> stat name) (fun _ -> Lwt.return_true) (fun e -> match e with | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_false | _ -> Lwt.fail e) external isatty_job : Unix.file_descr -> bool job = "lwt_unix_isatty_job" let isatty ch = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.isatty ch.fd) else run_job (isatty_job ch.fd) (* +-----------------------------------------------------------------+ | 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; } let lseek ch offset whence = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.LargeFile.lseek ch.fd offset whence) else run_job (Jobs.lseek_64_job ch.fd offset whence) let truncate name offset = if Sys.win32 then Lwt.return (Unix.LargeFile.truncate name offset) else run_job (Jobs.truncate_64_job name offset) let ftruncate ch offset = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.LargeFile.ftruncate ch.fd offset) else run_job (Jobs.ftruncate_64_job ch.fd offset) external stat_job : string -> Unix.LargeFile.stats job = "lwt_unix_stat_64_job" let stat name = if Sys.win32 then Lwt.return (Unix.LargeFile.stat name) else run_job (stat_job name) external lstat_job : string -> Unix.LargeFile.stats job = "lwt_unix_lstat_64_job" let lstat name = if Sys.win32 then Lwt.return (Unix.LargeFile.lstat name) else run_job (lstat_job name) external fstat_job : Unix.file_descr -> Unix.LargeFile.stats job = "lwt_unix_fstat_64_job" let fstat ch = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.LargeFile.fstat ch.fd) else run_job (fstat_job ch.fd) let file_exists name = Lwt.try_bind (fun () -> stat name) (fun _ -> Lwt.return_true) (fun e -> match e with | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_false | _ -> Lwt.fail e) end (* +-----------------------------------------------------------------+ | Operations on file names | +-----------------------------------------------------------------+ *) let unlink name = if Sys.win32 then Lwt.return (Unix.unlink name) else run_job (Jobs.unlink_job name) let rename name1 name2 = if Sys.win32 then Lwt.return (Unix.rename name1 name2) else run_job (Jobs.rename_job name1 name2) let link oldpath newpath = if Sys.win32 then Lwt.return (Unix.link oldpath newpath) else run_job (Jobs.link_job oldpath newpath) (* +-----------------------------------------------------------------+ | File permissions and ownership | +-----------------------------------------------------------------+ *) let chmod name mode = if Sys.win32 then Lwt.return (Unix.chmod name mode) else run_job (Jobs.chmod_job name mode) let fchmod ch mode = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.fchmod ch.fd mode) else run_job (Jobs.fchmod_job ch.fd mode) let chown name uid gid = if Sys.win32 then Lwt.return (Unix.chown name uid gid) else run_job (Jobs.chown_job name uid gid) let fchown ch uid gid = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.fchown ch.fd uid gid) else run_job (Jobs.fchown_job ch.fd uid gid) type access_permission = Unix.access_permission = | R_OK | W_OK | X_OK | F_OK let access name mode = if Sys.win32 then Lwt.return (Unix.access name mode) else run_job (Jobs.access_job name mode) (* +-----------------------------------------------------------------+ | 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; Lwt.return_true | false -> Unix.set_nonblock fd; Lwt.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; Lwt.return_true | false -> Unix.set_nonblock ch2.fd; Lwt.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 | +-----------------------------------------------------------------+ *) let mkdir name perms = if Sys.win32 then Lwt.return (Unix.mkdir name perms) else run_job (Jobs.mkdir_job name perms) let rmdir name = if Sys.win32 then Lwt.return (Unix.rmdir name) else run_job (Jobs.rmdir_job name) let chdir name = if Sys.win32 then Lwt.return (Unix.chdir name) else run_job (Jobs.chdir_job name) let chroot name = if Sys.win32 then Lwt.return (Unix.chroot name) else run_job (Jobs.chroot_job name) type dir_handle = Unix.dir_handle external opendir_job : string -> Unix.dir_handle job = "lwt_unix_opendir_job" let opendir name = if Sys.win32 then Lwt.return (Unix.opendir name) else run_job (opendir_job name) external readdir_job : Unix.dir_handle -> string job = "lwt_unix_readdir_job" let readdir handle = if Sys.win32 then Lwt.return (Unix.readdir handle) else run_job (readdir_job handle) external readdir_n_job : Unix.dir_handle -> int -> string array job = "lwt_unix_readdir_n_job" let readdir_n handle count = if count < 0 then Lwt.fail (Invalid_argument "Lwt_uinx.readdir_n") else if Sys.win32 then let array = Array.make count "" in let rec fill i = if i = count then Lwt.return array else match try array.(i) <- Unix.readdir handle; true with End_of_file -> false with | true -> fill (i + 1) | false -> Lwt.return (Array.sub array 0 i) in fill 0 else run_job (readdir_n_job handle count) external rewinddir_job : Unix.dir_handle -> unit job = "lwt_unix_rewinddir_job" let rewinddir handle = if Sys.win32 then Lwt.return (Unix.rewinddir handle) else run_job (rewinddir_job handle) external closedir_job : Unix.dir_handle -> unit job = "lwt_unix_closedir_job" let closedir handle = if Sys.win32 then Lwt.return (Unix.closedir handle) else run_job (closedir_job handle) 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 -> opendir path >>= fun handle -> Lwt.catch (fun () -> readdir_n handle 1024) (fun exn -> closedir handle >>= fun () -> Lwt.fail exn) >>= fun entries -> if Array.length entries < 1024 then begin state := LDS_done; closedir handle >>= fun () -> Lwt.return (Some(Lwt_stream.of_array entries)) end else begin state := LDS_listing handle; Gc.finalise cleanup_dir_handle state; Lwt.return (Some(Lwt_stream.of_array entries)) end | LDS_listing handle -> Lwt.catch (fun () -> readdir_n handle 1024) (fun exn -> closedir handle >>= fun () -> Lwt.fail exn) >>= fun entries -> if Array.length entries < 1024 then begin state := LDS_done; closedir handle >>= fun () -> Lwt.return (Some(Lwt_stream.of_array entries)) end else Lwt.return (Some(Lwt_stream.of_array entries)) | LDS_done -> Lwt.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) let mkfifo name perms = if Sys.win32 then Lwt.return (Unix.mkfifo name perms) else run_job (Jobs.mkfifo_job name perms) (* +-----------------------------------------------------------------+ | Symbolic links | +-----------------------------------------------------------------+ *) let symlink name1 name2 = if Sys.win32 then Lwt.return (Unix.symlink name1 name2) else run_job (Jobs.symlink_job name1 name2) external readlink_job : string -> string job = "lwt_unix_readlink_job" let readlink name = if Sys.win32 then Lwt.return (Unix.readlink name) else run_job (readlink_job name) (* +-----------------------------------------------------------------+ | Locking | +-----------------------------------------------------------------+ *) type lock_command = Unix.lock_command = | F_ULOCK | F_LOCK | F_TLOCK | F_TEST | F_RLOCK | F_TRLOCK external lockf_job : Unix.file_descr -> Unix.lock_command -> int -> unit job = "lwt_unix_lockf_job" let lockf ch cmd size = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.lockf ch.fd cmd size) else run_job (lockf_job ch.fd cmd size) (* +-----------------------------------------------------------------+ | 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 } external getlogin_job : unit -> string job = "lwt_unix_getlogin_job" let getlogin () = if Sys.win32 || Lwt_config.android then Lwt.return (Unix.getlogin ()) else run_job (getlogin_job ()) external getpwnam_job : string -> Unix.passwd_entry job = "lwt_unix_getpwnam_job" let getpwnam name = if Sys.win32 || Lwt_config.android then Lwt.return (Unix.getpwnam name) else run_job (getpwnam_job name) external getgrnam_job : string -> Unix.group_entry job = "lwt_unix_getgrnam_job" let getgrnam name = if Sys.win32 || Lwt_config.android then Lwt.return (Unix.getgrnam name) else run_job (getgrnam_job name) external getpwuid_job : int -> Unix.passwd_entry job = "lwt_unix_getpwuid_job" let getpwuid uid = if Sys.win32 || Lwt_config.android then Lwt.return (Unix.getpwuid uid) else run_job (getpwuid_job uid) external getgrgid_job : int -> Unix.group_entry job = "lwt_unix_getgrgid_job" let getgrgid gid = if Sys.win32 || Lwt_config.android then Lwt.return (Unix.getgrgid gid) else run_job (getgrgid_job gid) (* +-----------------------------------------------------------------+ | Sockets | +-----------------------------------------------------------------+ *) type msg_flag = Unix.msg_flag = | MSG_OOB | MSG_DONTROUTE | MSG_PEEK external stub_recv : Unix.file_descr -> Bytes.t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_recv" let recv ch buf pos len flags = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.recv" else let do_recv = if Sys.win32 then Unix.recv else stub_recv in wrap_syscall Read ch (fun () -> do_recv ch.fd buf pos len flags) external stub_send : Unix.file_descr -> Bytes.t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_send" let send ch buf pos len flags = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.send" else let do_send = if Sys.win32 then Unix.send else stub_send in wrap_syscall Write ch (fun () -> do_send ch.fd buf pos len flags) external stub_recvfrom : Unix.file_descr -> Bytes.t -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr = "lwt_unix_recvfrom" let recvfrom ch buf pos len flags = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.recvfrom" else let do_recvfrom = if Sys.win32 then Unix.recvfrom else stub_recvfrom in wrap_syscall Read ch (fun () -> do_recvfrom ch.fd buf pos len flags) external stub_sendto : Unix.file_descr -> Bytes.t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int = "lwt_unix_sendto_byte" "lwt_unix_sendto" let sendto ch buf pos len flags addr = if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "Lwt_unix.sendto" else let do_sendto = if Sys.win32 then Unix.sendto else stub_sendto in wrap_syscall Write ch (fun () -> do_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 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) 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) 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 external stub_socketpair : socket_domain -> socket_type -> int -> Unix.file_descr * Unix.file_descr = "lwt_unix_socketpair_stub" let socketpair dom typ proto = let do_socketpair = if Sys.win32 then stub_socketpair else Unix.socketpair in let (s1, s2) = do_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 Lazy.force ch.blocking >>= fun blocking -> Lwt.catch (fun () -> wrap_syscall Read ch begin fun () -> begin try for i = 1 to n do if blocking && not (unix_readable ch.fd) then raise Retry; let fd, addr = Unix.accept ch.fd in l := (mk_ch ~blocking:false fd, addr) :: !l done with | (Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) | Retry) when !l <> [] -> (* Ignore blocking errors if we have at least one file-descriptor: *) () end; (List.rev !l, None) end) (fun exn -> Lwt.return (List.rev !l, Some exn)) let connect ch addr = if Sys.win32 then (* [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 (* [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 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; } external stub_get_credentials : Unix.file_descr -> credentials = "lwt_unix_get_credentials" let get_credentials ch = check_descriptor ch; stub_get_credentials ch.fd (* +-----------------------------------------------------------------+ | 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 (* +-----------------------------------------------------------------+ | Multicast functions | +-----------------------------------------------------------------+ *) external stub_mcast_set_loop : Unix.file_descr -> bool -> unit = "lwt_unix_mcast_set_loop" external stub_mcast_set_ttl : Unix.file_descr -> int -> unit = "lwt_unix_mcast_set_ttl" type mcast_action = Add | Drop external stub_mcast_modify_membership : Unix.file_descr -> mcast_action -> Unix.inet_addr -> Unix.inet_addr -> unit = "lwt_unix_mcast_modify_membership" let mcast_set_loop ch flag = check_descriptor ch; stub_mcast_set_loop ch.fd flag let mcast_set_ttl ch ttl = check_descriptor ch; stub_mcast_set_ttl ch.fd ttl let mcast_add_membership ch ?(ifname = Unix.inet_addr_any) addr = check_descriptor ch; stub_mcast_modify_membership ch.fd Add ifname addr let mcast_drop_membership ch ?(ifname = Unix.inet_addr_any) addr = check_descriptor ch; stub_mcast_modify_membership ch.fd Drop ifname addr (* +-----------------------------------------------------------------+ | 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 } external gethostname_job : unit -> string job = "lwt_unix_gethostname_job" let gethostname () = if Sys.win32 then Lwt.return (Unix.gethostname ()) else run_job (gethostname_job ()) let hostent_mutex = Lwt_mutex.create () external gethostbyname_job : string -> Unix.host_entry job = "lwt_unix_gethostbyname_job" let gethostbyname name = if Sys.win32 then Lwt.return (Unix.gethostbyname name) else if Lwt_config._HAVE_REENTRANT_HOSTENT then run_job (gethostbyname_job name) else Lwt_mutex.with_lock hostent_mutex ( fun () -> run_job (gethostbyname_job name) ) external gethostbyaddr_job : Unix.inet_addr -> Unix.host_entry job = "lwt_unix_gethostbyaddr_job" let gethostbyaddr addr = if Sys.win32 then Lwt.return (Unix.gethostbyaddr addr) else if Lwt_config._HAVE_REENTRANT_HOSTENT then run_job (gethostbyaddr_job addr) else Lwt_mutex.with_lock hostent_mutex ( fun () -> run_job (gethostbyaddr_job addr) ) let protoent_mutex = if Sys.win32 || Lwt_config._HAVE_NETDB_REENTRANT then hostent_mutex else Lwt_mutex.create () external getprotobyname_job : string -> Unix.protocol_entry job = "lwt_unix_getprotobyname_job" let getprotobyname name = if Sys.win32 then Lwt.return (Unix.getprotobyname name) else if Lwt_config._HAVE_NETDB_REENTRANT then run_job (getprotobyname_job name) else Lwt_mutex.with_lock protoent_mutex ( fun () -> run_job (getprotobyname_job name)) external getprotobynumber_job : int -> Unix.protocol_entry job = "lwt_unix_getprotobynumber_job" let getprotobynumber number = if Sys.win32 then Lwt.return (Unix.getprotobynumber number) else if Lwt_config._HAVE_NETDB_REENTRANT then run_job (getprotobynumber_job number) else Lwt_mutex.with_lock protoent_mutex ( fun () -> run_job (getprotobynumber_job number)) let servent_mutex = if Sys.win32 || Lwt_config._HAVE_NETDB_REENTRANT then hostent_mutex else Lwt_mutex.create () external getservbyname_job : string -> string -> Unix.service_entry job = "lwt_unix_getservbyname_job" let getservbyname name x = if Sys.win32 then Lwt.return (Unix.getservbyname name x) else if Lwt_config._HAVE_NETDB_REENTRANT then run_job (getservbyname_job name x) else Lwt_mutex.with_lock protoent_mutex ( fun () -> run_job (getservbyname_job name x) ) external getservbyport_job : int -> string -> Unix.service_entry job = "lwt_unix_getservbyport_job" let getservbyport port x = if Sys.win32 then Lwt.return (Unix.getservbyport port x) else if Lwt_config._HAVE_NETDB_REENTRANT then run_job (getservbyport_job port x) else Lwt_mutex.with_lock protoent_mutex ( fun () -> run_job (getservbyport_job port x) ) 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 external getaddrinfo_job : string -> string -> Unix.getaddrinfo_option list -> Unix.addr_info list job = "lwt_unix_getaddrinfo_job" let getaddrinfo host service opts = if Sys.win32 then Lwt.return (Unix.getaddrinfo host service opts) else run_job (getaddrinfo_job host service opts) >>= fun l -> Lwt.return (List.rev l) 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 external getnameinfo_job : Unix.sockaddr -> Unix.getnameinfo_option list -> Unix.name_info job = "lwt_unix_getnameinfo_job" let getnameinfo addr opts = if Sys.win32 then Lwt.return (Unix.getnameinfo addr opts) else run_job (getnameinfo_job addr opts) (* +-----------------------------------------------------------------+ | 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 external tcgetattr_job : Unix.file_descr -> Unix.terminal_io job = "lwt_unix_tcgetattr_job" let tcgetattr ch = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcgetattr ch.fd) else run_job (tcgetattr_job ch.fd) external tcsetattr_job : Unix.file_descr -> Unix.setattr_when -> Unix.terminal_io -> unit job = "lwt_unix_tcsetattr_job" let tcsetattr ch when_ attrs = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcsetattr ch.fd when_ attrs) else run_job (tcsetattr_job ch.fd when_ attrs) let tcsendbreak ch delay = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcsendbreak ch.fd delay) else run_job (Jobs.tcsendbreak_job ch.fd delay) let tcdrain ch = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcdrain ch.fd) else run_job (Jobs.tcdrain_job ch.fd) let tcflush ch q = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcflush ch.fd q) else run_job (Jobs.tcflush_job ch.fd q) let tcflow ch act = check_descriptor ch; if Sys.win32 then Lwt.return (Unix.tcflow ch.fd act) else run_job (Jobs.tcflow_job ch.fd act) (* +-----------------------------------------------------------------+ | Reading notifications | +-----------------------------------------------------------------+ *) (* Buffer used to receive notifications: *) let notification_buffer = Bytes.create 4 external init_notification : unit -> Unix.file_descr = "lwt_unix_init_notification" external send_notification : int -> unit = "lwt_unix_send_notification_stub" external recv_notifications : unit -> int array = "lwt_unix_recv_notifications" let rec handle_notifications ev = (* Process available notifications. *) Array.iter call_notification (recv_notifications ()) let event_notifications = ref (Lwt_engine.on_readable (init_notification ()) handle_notifications) (* +-----------------------------------------------------------------+ | Signals | +-----------------------------------------------------------------+ *) external set_signal : int -> int -> unit = "lwt_unix_set_signal" external remove_signal : int -> unit = "lwt_unix_remove_signal" external init_signals : unit -> unit = "lwt_unix_init_signals" let () = init_signals () module Signal_map = Map.Make(struct type t = int let compare a b = a - b end) type signal_handler = { sh_num : int; sh_node : (signal_handler_id -> int -> unit) Lwt_sequence.node; } and signal_handler_id = signal_handler option ref let signals = ref Signal_map.empty let signal_count () = Signal_map.fold (fun signum (id, actions) len -> len + Lwt_sequence.length actions) !signals 0 let on_signal_full signum handler = let id = ref None in let notification, actions = try Signal_map.find signum !signals with Not_found -> let actions = Lwt_sequence.create () in let notification = make_notification (fun () -> Lwt_sequence.iter_l (fun f -> f id signum) actions) in (try set_signal signum notification with exn -> stop_notification notification; raise exn); signals := Signal_map.add signum (notification, actions) !signals; (notification, actions) in let node = Lwt_sequence.add_r handler actions in id := Some { sh_num = signum; sh_node = node }; id let on_signal signum f = on_signal_full signum (fun id num -> f num) let disable_signal_handler id = match !id with | None -> () | Some sh -> id := None; Lwt_sequence.remove sh.sh_node; let notification, actions = Signal_map.find sh.sh_num !signals in if Lwt_sequence.is_empty actions then begin remove_signal sh.sh_num; signals := Signal_map.remove sh.sh_num !signals; stop_notification notification end let reinstall_signal_handler signum = match try Some (Signal_map.find signum !signals) with Not_found -> None with | Some (notification, actions) -> set_signal signum notification | None -> () (* +-----------------------------------------------------------------+ | Processes | +-----------------------------------------------------------------+ *) external reset_after_fork : unit -> unit = "lwt_unix_reset_after_fork" let fork () = match Unix.fork () with | 0 -> (* Reset threading. *) reset_after_fork (); (* Stop the old event for notifications. *) Lwt_engine.stop_event !event_notifications; (* Reinitialise the notification system. *) event_notifications := Lwt_engine.on_readable (init_notification ()) handle_notifications; (* Collect all pending jobs. *) let l = Lwt_sequence.fold_l (fun (w, f) l -> f :: l) jobs [] in (* Remove them all. *) Lwt_sequence.iter_node_l Lwt_sequence.remove jobs; (* And cancel them all. We yield first so that if the program do an exec just after, it won't be executed. *) Lwt.on_termination (Lwt_main.yield ()) (fun () -> List.iter (fun f -> f Lwt.Canceled) l); 0 | pid -> pid type process_status = Unix.process_status = | WEXITED of int | WSIGNALED of int | WSTOPPED of int type wait_flag = Unix.wait_flag = | WNOHANG | WUNTRACED type resource_usage = { ru_utime : float; ru_stime : float } let has_wait4 = not Sys.win32 external stub_wait4 : Unix.wait_flag list -> int -> int * Unix.process_status * resource_usage = "lwt_unix_wait4" let do_wait4 flags pid = if Sys.win32 then let pid, status = Unix.waitpid flags pid in (pid, status, { ru_utime = 0.0; ru_stime = 0.0 }) else stub_wait4 flags pid let wait_children = Lwt_sequence.create () let wait_count () = Lwt_sequence.length wait_children let () = if not Sys.win32 then 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 = do_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 let _waitpid flags pid = Lwt.catch (fun () -> Lwt.return (Unix.waitpid flags pid)) Lwt.fail let waitpid = if Sys.win32 then _waitpid else fun flags pid -> if List.mem Unix.WNOHANG flags then _waitpid flags pid else let flags = Unix.WNOHANG :: flags in _waitpid flags pid >>= fun ((pid', _) as res) -> if pid' <> 0 then Lwt.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 >>= fun (pid, status, _) -> Lwt.return (pid, status) end let wait4 flags pid = if Sys.win32 then Lwt.return (do_wait4 flags pid) else if List.mem Unix.WNOHANG flags then Lwt.return (do_wait4 flags pid) else let flags = Unix.WNOHANG :: flags in let (pid', _, _) as res = do_wait4 flags pid in if pid' <> 0 then Lwt.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 let wait () = waitpid [] (-1) external system_job : string -> int job = "lwt_unix_system_job" external sys_exit : int -> 'a = "caml_sys_exit" let system cmd = if Sys.win32 then run_job (system_job ("cmd.exe /c " ^ cmd)) >>= fun code -> Lwt.return (Unix.WEXITED code) else match fork () with | 0 -> begin try Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] with _ -> (* Do not run at_exit hooks *) sys_exit 127 end | id -> waitpid [] id >|= snd (* +-----------------------------------------------------------------+ | Misc | +-----------------------------------------------------------------+ *) let run = Lwt_main.run let handle_unix_error f x = Lwt.catch (fun () -> f x) (fun 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 | +-----------------------------------------------------------------+ *) external get_cpu : unit -> int = "lwt_unix_get_cpu" 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 (* +-----------------------------------------------------------------+ | Error printing | +-----------------------------------------------------------------+ *) let () = Printexc.register_printer (function | Unix.Unix_error(error, func, arg) -> let error = match error with | Unix.E2BIG -> "E2BIG" | Unix.EACCES -> "EACCES" | Unix.EAGAIN -> "EAGAIN" | Unix.EBADF -> "EBADF" | Unix.EBUSY -> "EBUSY" | Unix.ECHILD -> "ECHILD" | Unix.EDEADLK -> "EDEADLK" | Unix.EDOM -> "EDOM" | Unix.EEXIST -> "EEXIST" | Unix.EFAULT -> "EFAULT" | Unix.EFBIG -> "EFBIG" | Unix.EINTR -> "EINTR" | Unix.EINVAL -> "EINVAL" | Unix.EIO -> "EIO" | Unix.EISDIR -> "EISDIR" | Unix.EMFILE -> "EMFILE" | Unix.EMLINK -> "EMLINK" | Unix.ENAMETOOLONG -> "ENAMETOOLONG" | Unix.ENFILE -> "ENFILE" | Unix.ENODEV -> "ENODEV" | Unix.ENOENT -> "ENOENT" | Unix.ENOEXEC -> "ENOEXEC" | Unix.ENOLCK -> "ENOLCK" | Unix.ENOMEM -> "ENOMEM" | Unix.ENOSPC -> "ENOSPC" | Unix.ENOSYS -> "ENOSYS" | Unix.ENOTDIR -> "ENOTDIR" | Unix.ENOTEMPTY -> "ENOTEMPTY" | Unix.ENOTTY -> "ENOTTY" | Unix.ENXIO -> "ENXIO" | Unix.EPERM -> "EPERM" | Unix.EPIPE -> "EPIPE" | Unix.ERANGE -> "ERANGE" | Unix.EROFS -> "EROFS" | Unix.ESPIPE -> "ESPIPE" | Unix.ESRCH -> "ESRCH" | Unix.EXDEV -> "EXDEV" | Unix.EWOULDBLOCK -> "EWOULDBLOCK" | Unix.EINPROGRESS -> "EINPROGRESS" | Unix.EALREADY -> "EALREADY" | Unix.ENOTSOCK -> "ENOTSOCK" | Unix.EDESTADDRREQ -> "EDESTADDRREQ" | Unix.EMSGSIZE -> "EMSGSIZE" | Unix.EPROTOTYPE -> "EPROTOTYPE" | Unix.ENOPROTOOPT -> "ENOPROTOOPT" | Unix.EPROTONOSUPPORT -> "EPROTONOSUPPORT" | Unix.ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT" | Unix.EOPNOTSUPP -> "EOPNOTSUPP" | Unix.EPFNOSUPPORT -> "EPFNOSUPPORT" | Unix.EAFNOSUPPORT -> "EAFNOSUPPORT" | Unix.EADDRINUSE -> "EADDRINUSE" | Unix.EADDRNOTAVAIL -> "EADDRNOTAVAIL" | Unix.ENETDOWN -> "ENETDOWN" | Unix.ENETUNREACH -> "ENETUNREACH" | Unix.ENETRESET -> "ENETRESET" | Unix.ECONNABORTED -> "ECONNABORTED" | Unix.ECONNRESET -> "ECONNRESET" | Unix.ENOBUFS -> "ENOBUFS" | Unix.EISCONN -> "EISCONN" | Unix.ENOTCONN -> "ENOTCONN" | Unix.ESHUTDOWN -> "ESHUTDOWN" | Unix.ETOOMANYREFS -> "ETOOMANYREFS" | Unix.ETIMEDOUT -> "ETIMEDOUT" | Unix.ECONNREFUSED -> "ECONNREFUSED" | Unix.EHOSTDOWN -> "EHOSTDOWN" | Unix.EHOSTUNREACH -> "EHOSTUNREACH" | Unix.ELOOP -> "ELOOP" | Unix.EOVERFLOW -> "EOVERFLOW" | Unix.EUNKNOWNERR n -> Printf.sprintf "EUNKNOWNERR %d" n in Some(Printf.sprintf "Unix.Unix_error(Unix.%s, %S, %S)" error func arg) | _ -> None) lwt-2.5.2/src/unix/lwt_unix.mli000066400000000000000000001072721270742521300164700ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Lwt_unix * Copyright (C) 2005-2008 Jérôme Vouillon * Laboratoire PPS - CNRS Université Paris Diderot * 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. *) (** Cooperative system calls *) (** This modules maps system calls, like those of the standard library's [Unix] module, to cooperative ones, which will not block the program. The semantics of all operations is the following: if the action (for example reading from a {b file descriptor}) can be performed immediately, it is done and returns immediately, otherwise it returns a sleeping thread which is woken up when the operation completes. Most operations on sockets and pipes (on Windows it is only sockets) are {b cancelable}, meaning 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. For example, consider that you have two sockets [sock1] and [sock2]. You want to read something from [sock1] or exclusively from [sock2] and fail with an exception if a timeout of 1 second expires, without reading anything from [sock1] and [sock2], even if they become readable in the future. Then you can do: {[ Lwt.pick [Lwt_unix.timeout 1.0; read sock1 buf1 ofs1 len1; read sock2 buf2 ofs2 len2] ]} In this case, it is guaranteed that exactly one of the three operations will complete, and the others will 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 *) (** {2 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 performance 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 efficient, also you will get better performance 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_detach f] is a shorthand for: {[ Lwt.with_value async_method_key (Some Async_detach) f ]} *) val with_async_switch : (unit -> 'a) -> 'a (** [with_async_switch f] is a shorthand for: {[ Lwt.with_value async_method_key (Some Async_switch) f ]} *) (** {2 Sleeping} *) val sleep : float -> unit Lwt.t (** [sleep d] is a thread that remains suspended for [d] seconds and then terminates. *) val yield : unit -> unit Lwt.t (** [yield ()] is a thread that 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] that will yield every [timeout] seconds. *) exception Timeout (** Exception raised by timeout operations *) val timeout : float -> 'a Lwt.t (** [timeout d] is a thread that remains suspended for [d] seconds and then fails with {!Timeout}. *) val with_timeout : float -> (unit -> 'a Lwt.t) -> 'a Lwt.t (** [with_timeout d f] is a short-hand for: {[ Lwt.pick [Lwt_unix.timeout d; f ()] ]} *) (** {2 Operation on file-descriptors} *) type file_descr (** The abstract type for {b file descriptor}s. A Lwt {b file descriptor} is a pair of a unix {b file descriptor} (of type [Unix.file_descr]) and a {b state}. A {b file descriptor} may be: - {b opened}, in which case it is fully usable - {b closed} or {b aborted}, in which case it is no longer usable *) (** State of a {b file descriptor} *) type state = | Opened (** The {b file descriptor} is opened *) | Closed (** The {b file descriptor} has been closed by {!close}. It must not be used for any operation. *) | Aborted of exn (** The {b file descriptor} has been aborted, the only operation possible is {!close}, all others will fail. *) val state : file_descr -> state (** [state fd] returns the state of [fd] *) val unix_file_descr : file_descr -> Unix.file_descr (** Returns the underlying unix {b file descriptor}. It always succeeds, even if the {b file descriptor}'s state is not {!Open}. *) val of_unix_file_descr : ?blocking : bool -> ?set_flags : bool -> Unix.file_descr -> file_descr (** Creates a lwt {b file descriptor} from a unix one. [blocking] is the blocking mode of the file-descriptor, and describes how Lwt will use it. In non-blocking mode, read/write on this file descriptor are made using non-blocking IO; in blocking mode they are made using the current async method. If [blocking] is not specified it is guessed according to the file kind: socket and pipes are in non-blocking mode and others are in blocking mode. If [set_flags] is [true] (the default) then the file flags are modified according to the [blocking] argument, otherwise they are left unchanged. Note that the blocking mode is less efficient than the non-blocking one, so it should be used only for file descriptors that does not support asynchronous operations, such as regular files, or for shared descriptors such as {!stdout}, {!stderr} or {!stdin}. *) val blocking : file_descr -> bool Lwt.t (** [blocking fd] returns whether [fd] is used in blocking or non-blocking mode. *) val set_blocking : ?set_flags : bool -> file_descr -> bool -> unit (** [set_blocking fd b] puts [fd] in blocking or non-blocking mode. If [set_flags] is [true] (the default) then the file flags are modified, otherwise the modification is only done at the application level. *) val abort : file_descr -> exn -> unit (** [abort fd exn] makes all current and further uses of the file descriptor fail with the given exception. This put the {b file descriptor} into the {!Aborted} state. If the {b file descriptor} is closed, this does nothing, if it is aborted, this replace the abort exception by [exn]. Note that this only works for reading and writing operations on file descriptors supporting non-blocking mode. *) (** {2 Process handling} *) val fork : unit -> int (** [fork ()] does the same as [Unix.fork]. You must use this function instead of [Unix.fork] when you want to use Lwt in the child process. Notes: - in the child process all pending jobs are canceled, - if you are going to use Lwt in the parent and the child, it is a good idea to call {!Lwt_io.flush_all} before callling {!fork} to avoid double-flush. *) type process_status = Unix.process_status = | WEXITED of int | WSIGNALED of int | WSTOPPED of int type wait_flag = Unix.wait_flag = | WNOHANG | WUNTRACED val wait : unit -> (int * process_status) Lwt.t (** Wrapper for [Unix.wait] *) val waitpid : wait_flag list -> int -> (int * process_status) Lwt.t (** Wrapper for [Unix.waitpid] *) (** Resource usages *) type resource_usage = { ru_utime : float; (** User time used *) ru_stime : float; (** System time used *) } val wait4 : wait_flag list -> int -> (int * process_status * resource_usage) Lwt.t (** [wait4 flags pid] returns [(pid, status, rusage)] where [(pid, status)] is the same result as [Unix.waitpid flags pid], and [rusage] contains accounting information about the child. On windows it will always returns [{ utime = 0.0; stime = 0.0 }]. *) val wait_count : unit -> int (** Returns the number of threads waiting for a child to terminate. *) val system : string -> process_status Lwt.t (** Executes the given command, waits until it terminates, and return its termination status. The string is interpreted by the shell [/bin/sh] on Unix and [cmd.exe] on Windows. The result [WEXITED 127] indicates that the shell couldn't be executed. *) (** {2 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 | O_SHARE_DELETE | O_CLOEXEC 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 -> Bytes.t -> int -> int -> int Lwt.t (** [read fd buf ofs len] has the same semantic as [Unix.read], but is cooperative *) val write : file_descr -> Bytes.t -> int -> int -> int Lwt.t (** [write fd buf ofs len] has the same semantic as [Unix.write], but is cooperative *) val write_string : file_descr -> string -> int -> int -> int Lwt.t (** See {!write}. *) 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 *) (** {2 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] *) (** {2 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. *) (** {2 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 file_exists : string -> bool Lwt.t (** [file_exists name] tests if a file named [name] exists. *) val isatty : file_descr -> bool Lwt.t (** Wrapper for [Unix.isatty] *) (** {2 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] *) val file_exists : string -> bool Lwt.t (** [file_exists name] tests if a file named [name] exists. *) end (** {2 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] *) (** {2 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] *) (** {2 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] *) (** {2 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.readdir]. *) val readdir_n : dir_handle -> int -> string array Lwt.t (** [readdir_n handle count] reads at most [count] entry from the given directory. It is more efficient than calling [readdir] [count] times. If the length of the returned array is smaller than [count], this means that the end of the directory has been reached. *) val rewinddir : dir_handle -> unit Lwt.t (** Wrapper for [Unix.rewinddir] *) val closedir : dir_handle -> unit Lwt.t (** Wrapper for [Unix.closedir] *) val files_of_directory : string -> string Lwt_stream.t (** [files_of_directory dir] returns the stream of all files of [dir]. *) (** {2 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] *) (** {2 Symbolic links} *) val symlink : string -> string -> unit Lwt.t (** Wrapper for [Unix.symlink] *) val readlink : string -> string Lwt.t (** Wrapper for [Unix.readlink] *) (** {2 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] *) (** {2 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] *) (** {2 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 that can be used to stop monitoring [signum]. *) val on_signal_full : int -> (signal_handler_id -> int -> unit) -> signal_handler_id (** [on_signal_full f] is the same as [on_signal f] except that [f] also receive the signal handler identifier as argument so it can disable it. *) val disable_signal_handler : signal_handler_id -> unit (** Stops receiving this signal *) val signal_count : unit -> int (** Returns the number of registered signal handler. *) val reinstall_signal_handler : int -> unit (** [reinstall_signal_handler signum] if any signal handler is registered for this signal with {!on_signal}, it reinstall the signal handler (with [Sys.set_signal]). This is usefull in case another part of the program install another signal handler. *) (** {2 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] connections at one time. - if no connection is available right now, it returns a sleeping thread - if more than 1 and less than [count] are available, it returns all of them - if more than [count] are available, it returns the next [count] of them - if an error happens, it returns the connections that have been successfully accepted so far and the error [accept_n] has the advantage of improving performance. 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 -> Bytes.t -> int -> int -> msg_flag list -> int Lwt.t (** Wrapper for [Unix.recv] *) val recvfrom : file_descr -> Bytes.t -> int -> int -> msg_flag list -> (int * sockaddr) Lwt.t (** Wrapper for [Unix.recvfrom] *) val send : file_descr -> Bytes.t -> int -> int -> msg_flag list -> int Lwt.t (** Wrapper for [Unix.send] *) val sendto : file_descr -> Bytes.t -> 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 messages. It returns a tuple whose first field is the number of bytes received and second is a list of received file descriptors. The messages themselves will be recorded in the provided [io_vectors] list. 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-descriptors. It returns the number of bytes sent. 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 credentials information from the given socket. On some platforms, obtaining the peer pid is not possible and it will be set to [-1]. If obtaining credentials is not possible on the current system, it raises [Lwt_sys.Not_available "get_credentials"]. This call is not available on windows. *) (** {3 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] *) (** {3 Multicast functions} *) val mcast_set_loop : file_descr -> bool -> unit (** Whether sent multicast messages are received by the sending host *) val mcast_set_ttl : file_descr -> int -> unit (** Set TTL/hops value *) val mcast_add_membership : file_descr -> ?ifname:Unix.inet_addr -> Unix.inet_addr -> unit (** [mcast_add_membership fd ~ifname addr] joins the multicast group [addr] on the network interface [ifname]. *) val mcast_drop_membership : file_descr -> ?ifname:Unix.inet_addr -> Unix.inet_addr -> unit (** [mcast_drop_membership fd ~ifname addr] leaves the multicast group [addr] on the network interface [ifname]. *) (** {2 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] *) (** {2 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] *) (** {2 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 execute action, and if it can not be performed immediately without blocking, it is registered for later. In the latter case, if the thread is canceled, [action] is removed from [set]. *) val check_descriptor : file_descr -> unit (** [check_descriptor fd] raise an exception if [fd] is not in the state {!Open} *) val register_action : io_event -> file_descr -> (unit -> 'a) -> 'a Lwt.t (** [register_action set fd action] registers [action] on [fd]. When [fd] becomes [readable]/[writable] [action] is called. Note: - you must call [check_descriptor fd] before calling [register_action] - you should prefer using {!wrap_syscall} *) type 'a job (** Type of job descriptions. A job description describe how to call a C function and how to get its result. The C function may be executed in another system thread. *) val execute_job : ?async_method : async_method -> job : 'a job -> result : ('a job -> 'b) -> free : ('a job -> unit) -> 'b Lwt.t (** This is the old and deprecated way of running a job. Use {!run_job} in new code. *) val run_job : ?async_method : async_method -> 'a job -> 'a Lwt.t (** [run_job ?async_method job] starts [job] and wait for its termination. The async method is choosen follow: - if the optional parameter [async_method] is specified, it is used, - otherwise if the local key {!async_method_key} is set in the current thread, it is used, - otherwise the default method (returned by {!default_async_method}) is used. If the method is {!Async_none} then the job is run synchronously and may block the current system thread, thus blocking all Lwt threads. If the method is {!Async_detach} then the job is run in another system thread, unless the the maximum number of worker threads has been reached (as given by {!pool_size}). If the method is {!Async_switch} then the job is run synchronously and if it blocks, execution will continue in another system thread (unless the limit is reached). *) val abort_jobs : exn -> unit (** [abort_jobs exn] make all pending jobs to fail with exn. Note that this does not abort the real job (i.e. the C function executing it), just the lwt thread for it. *) val cancel_jobs : unit -> unit (** [cancel_jobs ()] is the same as [abort_jobs Lwt.Canceled]. *) val wait_for_jobs : unit -> unit Lwt.t (** Wait for all pending jobs to terminate. *) (** {2 Notifications} *) (** Lwt internally use a pipe to send notification to the main thread. The following functions allow to use this pipe. *) val make_notification : ?once : bool -> (unit -> unit) -> int (** [new_notifier ?once f] registers a new notifier. It returns the id of the notifier. Each time a notification with this id is received, [f] is called. if [once] is specified, then the notification is stopped after the first time it is received. It defaults to [false]. *) val send_notification : int -> unit (** [send_notification id] sends a notification. This function is thread-safe. *) val stop_notification : int -> unit (** Stop the given notification. Note that you should not reuse the id after the notification has been stopped, the result is unspecified if you do so. *) val call_notification : int -> unit (** Call the handler associated to the given notification. Note that if the notification was defined with [once = true] it is removed. *) val set_notification : int -> (unit -> unit) -> unit (** [set_notification id f] replace the function associated to the notification by [f]. It raises [Not_found] if the given notification is not found. *) (** {2 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. *) (** {2 CPUs} *) val get_cpu : unit -> int (** [get_cpu ()] returns the number of the CPU the current thread is running on. *) val get_affinity : ?pid : int -> unit -> int list (** [get_affinity ?pid ()] returns the list of CPUs the process with pid [pid] is allowed to run on. If [pid] is not specified then the affinity of the current process is returned. *) val set_affinity : ?pid : int -> int list -> unit (** [set_affinity ?pid cpus] sets the list of CPUs the given process is allowed to run on. *) (**/**) val run : 'a Lwt.t -> 'a (* Same as {!Lwt_main.run} *) val has_wait4 : bool (* Deprecated, use [Lwt_sys.have `wait4]. *) lwt-2.5.2/src/unix/lwt_unix_stubs.c000066400000000000000000001215651270742521300173520ustar00rootroot00000000000000/* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_unix_stubs * Copyright (C) 2009-2010 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. */ #include "lwt_config.h" #define _GNU_SOURCE #define _POSIX_PTHREAD_SEMANTICS #include #include #include #include #include #include #include #include #include #include #include #include #include #if !defined(LWT_ON_WINDOWS) && defined(SIGRTMIN) && defined(SIGRTMAX) #define LWT_UNIX_SIGNAL_ASYNC_SWITCH SIGRTMIN #define LWT_UNIX_HAVE_ASYNC_SWITCH #include #else #endif #include "lwt_unix.h" #if !defined(LWT_ON_WINDOWS) # include # include # include # include # include # include # include # include # include # include # include # include # include # include # include # include # include #endif #if defined(HAVE_EVENTFD) # include #endif //#define DEBUG_MODE #if defined(DEBUG_MODE) # include # define DEBUG(fmt, ...) { fprintf(stderr, "lwt-debug[%d]: %s: " fmt "\n", (pid_t)syscall(SYS_gettid), __FUNCTION__, ##__VA_ARGS__); fflush(stderr); } #else # define DEBUG(fmt, ...) #endif /* +-----------------------------------------------------------------+ | OS-dependent functions | +-----------------------------------------------------------------+ */ #if defined(LWT_ON_WINDOWS) # include "lwt_unix_windows.c" #else # include "lwt_unix_unix.c" #endif /* +-----------------------------------------------------------------+ | Utils | +-----------------------------------------------------------------+ */ void *lwt_unix_malloc(size_t size) { void *ptr = malloc(size); if (ptr == NULL) { perror("cannot allocate memory"); abort(); } return ptr; } void *lwt_unix_realloc(void *ptr, size_t size) { void *new_ptr = realloc(ptr, size); if (new_ptr == NULL) { perror("cannot allocate memory"); abort(); } return new_ptr; } char *lwt_unix_strdup(char *str) { char *new_str = strdup(str); if (new_str == NULL) { perror("cannot allocate memory"); abort(); } return new_str; } void lwt_unix_not_available(char const *feature) { caml_raise_with_arg(*caml_named_value("lwt:not-available"), caml_copy_string(feature)); } /* +-----------------------------------------------------------------+ | Operation on bigarrays | +-----------------------------------------------------------------+ */ CAMLprim value lwt_unix_blit(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_from_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_to_bytes(value val_buf1, value val_ofs1, value val_buf2, value val_ofs2, value val_len) { memcpy(String_val(val_buf2) + Long_val(val_ofs2), (char*)Caml_ba_data_val(val_buf1) + Long_val(val_ofs1), Long_val(val_len)); return Val_unit; } CAMLprim value lwt_unix_fill_bytes(value val_buf, value val_ofs, value val_len, value val_char) { memset((char*)Caml_ba_data_val(val_buf) + Long_val(val_ofs), Int_val(val_char), Long_val(val_len)); return Val_unit; } CAMLprim value lwt_unix_mapped(value v_bstr) { return Val_bool(Caml_ba_array_val(v_bstr)->flags & CAML_BA_MAPPED_FILE); } /* +-----------------------------------------------------------------+ | Byte order | +-----------------------------------------------------------------+ */ value lwt_unix_system_byte_order() { #ifdef ARCH_BIG_ENDIAN return Val_int(1); #else return Val_int(0); #endif } /* +-----------------------------------------------------------------+ | Threading | +-----------------------------------------------------------------+ */ #if defined(HAVE_PTHREAD) void lwt_unix_launch_thread(void* (*start)(void*), void* data) { pthread_t thread; pthread_attr_t attr; int result; pthread_attr_init(&attr); /* The thread is created in detached state so we do not have to join it when it terminates: */ pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); result = pthread_create(&thread, &attr, start, data); if (result) unix_error(result, "launch_thread", Nothing); pthread_attr_destroy (&attr); } lwt_unix_thread lwt_unix_thread_self() { return pthread_self(); } int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2) { return pthread_equal(thread1, thread2); } void lwt_unix_mutex_init(lwt_unix_mutex *mutex) { pthread_mutex_init(mutex, NULL); } void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex) { pthread_mutex_destroy(mutex); } void lwt_unix_mutex_lock(lwt_unix_mutex *mutex) { pthread_mutex_lock(mutex); } void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex) { pthread_mutex_unlock(mutex); } void lwt_unix_condition_init(lwt_unix_condition *condition) { pthread_cond_init(condition, NULL); } void lwt_unix_condition_destroy(lwt_unix_condition *condition) { pthread_cond_destroy(condition); } void lwt_unix_condition_signal(lwt_unix_condition *condition) { pthread_cond_signal(condition); } void lwt_unix_condition_broadcast(lwt_unix_condition *condition) { pthread_cond_broadcast(condition); } void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex) { pthread_cond_wait(condition, mutex); } #elif defined(LWT_ON_WINDOWS) void lwt_unix_launch_thread(void* (*start)(void*), void* data) { HANDLE handle = CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start, data, 0, NULL); if (handle) CloseHandle(handle); } lwt_unix_thread lwt_unix_thread_self() { return GetCurrentThreadId(); } int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2) { return thread1 == thread2; } void lwt_unix_mutex_init(lwt_unix_mutex *mutex) { InitializeCriticalSection(mutex); } void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex) { DeleteCriticalSection(mutex); } void lwt_unix_mutex_lock(lwt_unix_mutex *mutex) { EnterCriticalSection(mutex); } void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex) { LeaveCriticalSection(mutex); } struct wait_list { HANDLE event; struct wait_list *next; }; struct lwt_unix_condition { CRITICAL_SECTION mutex; struct wait_list *waiters; }; void lwt_unix_condition_init(lwt_unix_condition *condition) { InitializeCriticalSection(&condition->mutex); condition->waiters = NULL; } void lwt_unix_condition_destroy(lwt_unix_condition *condition) { DeleteCriticalSection(&condition->mutex); } void lwt_unix_condition_signal(lwt_unix_condition *condition) { struct wait_list *node; EnterCriticalSection(&condition->mutex); node = condition->waiters; if (node) { condition->waiters = node->next; SetEvent(node->event); } LeaveCriticalSection(&condition->mutex); } void lwt_unix_condition_broadcast(lwt_unix_condition *condition) { struct wait_list *node; EnterCriticalSection(&condition->mutex); for (node = condition->waiters; node; node = node->next) SetEvent(node->event); condition->waiters = NULL; LeaveCriticalSection(&condition->mutex); } void lwt_unix_condition_wait(lwt_unix_condition *condition, lwt_unix_mutex *mutex) { struct wait_list node; /* Create the event for the notification. */ node.event = CreateEvent(NULL, FALSE, FALSE, NULL); /* Add the node to the condition. */ EnterCriticalSection(&condition->mutex); node.next = condition->waiters; condition->waiters = &node; LeaveCriticalSection(&condition->mutex); /* Release the mutex. */ LeaveCriticalSection(mutex); /* Wait for a signal. */ WaitForSingleObject(node.event, INFINITE); /* The event is no more used. */ CloseHandle(node.event); /* Re-acquire the mutex. */ EnterCriticalSection(mutex); } #else # error "no threading library available!" #endif /* +-----------------------------------------------------------------+ | Socketpair on windows | +-----------------------------------------------------------------+ */ #if defined(LWT_ON_WINDOWS) static void lwt_unix_socketpair(int domain, int type, int protocol, SOCKET sockets[2]) { union { struct sockaddr_in inaddr; struct sockaddr addr; } a; SOCKET listener; int addrlen = sizeof(a.inaddr); int reuse = 1; DWORD err; sockets[0] = INVALID_SOCKET; sockets[1] = INVALID_SOCKET; listener = socket(domain, type, protocol); if (listener == INVALID_SOCKET) goto failure; memset(&a, 0, sizeof(a)); a.inaddr.sin_family = domain; a.inaddr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); a.inaddr.sin_port = 0; if (setsockopt(listener, SOL_SOCKET, SO_REUSEADDR, (char*) &reuse, sizeof(reuse)) == -1) goto failure; if (bind(listener, &a.addr, sizeof(a.inaddr)) == SOCKET_ERROR) goto failure; memset(&a, 0, sizeof(a)); if (getsockname(listener, &a.addr, &addrlen) == SOCKET_ERROR) goto failure; a.inaddr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); a.inaddr.sin_family = AF_INET; if (listen(listener, 1) == SOCKET_ERROR) goto failure; sockets[0] = socket(domain, type, protocol); if (sockets[0] == INVALID_SOCKET) goto failure; if (connect(sockets[0], &a.addr, sizeof(a.inaddr)) == SOCKET_ERROR) goto failure; sockets[1] = accept(listener, NULL, NULL); if (sockets[1] == INVALID_SOCKET) goto failure; closesocket(listener); return; failure: err = WSAGetLastError(); closesocket(listener); closesocket(sockets[0]); closesocket(sockets[1]); win32_maperr(err); uerror("socketpair", Nothing); } static int socket_domain_table[] = { PF_UNIX, PF_INET }; static int socket_type_table[] = { SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET }; CAMLprim value lwt_unix_socketpair_stub(value domain, value type, value protocol) { CAMLparam3(domain, type, protocol); CAMLlocal1(result); SOCKET sockets[2]; lwt_unix_socketpair(socket_domain_table[Int_val(domain)], socket_type_table[Int_val(type)], Int_val(protocol), sockets); result = caml_alloc_tuple(2); Store_field(result, 0, win_alloc_socket(sockets[0])); Store_field(result, 1, win_alloc_socket(sockets[1])); CAMLreturn(result); } #endif /* +-----------------------------------------------------------------+ | Notifications | +-----------------------------------------------------------------+ */ /* The mutex used to send and receive notifications. */ static lwt_unix_mutex notification_mutex; /* All pending notifications. */ static long *notifications = NULL; /* The size of the notification buffer. */ static long notification_count = 0; /* The index to the next available cell in the notification buffer. */ static long notification_index = 0; /* The mode currently used for notifications. */ enum notification_mode { /* Not yet initialized. */ NOTIFICATION_MODE_NOT_INITIALIZED, /* Initialized but no mode defined. */ NOTIFICATION_MODE_NONE, /* Using an eventfd. */ NOTIFICATION_MODE_EVENTFD, /* Using a pipe. */ NOTIFICATION_MODE_PIPE, /* Using a pair of sockets (only on windows). */ NOTIFICATION_MODE_WINDOWS }; /* The current notification mode. */ static enum notification_mode notification_mode = NOTIFICATION_MODE_NOT_INITIALIZED; /* Send one notification. */ static int (*notification_send)(); /* Read one notification. */ static int (*notification_recv)(); static void init_notifications() { lwt_unix_mutex_init(¬ification_mutex); notification_count = 4096; notifications = (long*)lwt_unix_malloc(notification_count * sizeof(long)); } static void resize_notifications() { long new_notification_count = notification_count * 2; long *new_notifications = (long*)lwt_unix_malloc(new_notification_count * sizeof(long)); memcpy((void*)new_notifications, (void*)notifications, notification_count * sizeof(long)); free(notifications); notifications = new_notifications; notification_count = new_notification_count; } void lwt_unix_send_notification(int id) { int ret; #if !defined(LWT_ON_WINDOWS) sigset_t new_mask; sigset_t old_mask; int error; sigfillset(&new_mask); pthread_sigmask(SIG_SETMASK, &new_mask, &old_mask); #else DWORD error; #endif lwt_unix_mutex_lock(¬ification_mutex); if (notification_index > 0) { /* There is already a pending notification in the buffer, no need to signal the main thread. */ if (notification_index == notification_count) resize_notifications(); notifications[notification_index++] = id; } else { /* There is none, notify the main thread. */ notifications[notification_index++] = id; ret = notification_send(); #if defined(LWT_ON_WINDOWS) if (ret == SOCKET_ERROR) { error = WSAGetLastError(); if (error != WSANOTINITIALISED) { lwt_unix_mutex_unlock(¬ification_mutex); win32_maperr(error); uerror("send_notification", Nothing); } /* else we're probably shutting down, so ignore the error */ } #else if (ret < 0) { error = errno; lwt_unix_mutex_unlock(¬ification_mutex); pthread_sigmask(SIG_SETMASK, &old_mask, NULL); unix_error(error, "send_notification", Nothing); } #endif } lwt_unix_mutex_unlock(¬ification_mutex); #if !defined(LWT_ON_WINDOWS) pthread_sigmask(SIG_SETMASK, &old_mask, NULL); #endif } value lwt_unix_send_notification_stub(value id) { lwt_unix_send_notification(Long_val(id)); return Val_unit; } value lwt_unix_recv_notifications() { int ret, i, current_index; value result; #if !defined(LWT_ON_WINDOWS) sigset_t new_mask; sigset_t old_mask; int error; sigfillset(&new_mask); pthread_sigmask(SIG_SETMASK, &new_mask, &old_mask); #else DWORD error; #endif lwt_unix_mutex_lock(¬ification_mutex); /* Receive the signal. */ ret = notification_recv(); #if defined(LWT_ON_WINDOWS) if (ret == SOCKET_ERROR) { error = WSAGetLastError(); lwt_unix_mutex_unlock(¬ification_mutex); win32_maperr(error); uerror("recv_notifications", Nothing); } #else if (ret < 0) { error = errno; lwt_unix_mutex_unlock(¬ification_mutex); pthread_sigmask(SIG_SETMASK, &old_mask, NULL); unix_error(error, "recv_notifications", Nothing); } #endif do { /* release the mutex while calling caml_alloc, which may call gc and switch the thread, resulting in a classical deadlock, when thread in question tries another send */ current_index = notification_index; lwt_unix_mutex_unlock(¬ification_mutex); result = caml_alloc_tuple(current_index); lwt_unix_mutex_lock(¬ification_mutex); /* check that no new notifications appeared meanwhile (rare) */ } while (current_index != notification_index); /* Read all pending notifications. */ for (i = 0; i < notification_index; i++) Field(result, i) = Val_long(notifications[i]); /* Reset the index. */ notification_index = 0; lwt_unix_mutex_unlock(¬ification_mutex); #if !defined(LWT_ON_WINDOWS) pthread_sigmask(SIG_SETMASK, &old_mask, NULL); #endif return result; } #if defined(LWT_ON_WINDOWS) static SOCKET set_close_on_exec(SOCKET socket) { SOCKET new_socket; if (!DuplicateHandle(GetCurrentProcess(), (HANDLE)socket, GetCurrentProcess(), (HANDLE*)&new_socket, 0L, FALSE, DUPLICATE_SAME_ACCESS)) { win32_maperr(GetLastError()); uerror("set_close_on_exec", Nothing); } closesocket(socket); return new_socket; } static SOCKET socket_r, socket_w; static int windows_notification_send() { char buf = '!'; return send(socket_w, &buf, 1, 0); } static int windows_notification_recv() { char buf; return recv(socket_r, &buf, 1, 0); } value lwt_unix_init_notification() { SOCKET sockets[2]; switch (notification_mode) { case NOTIFICATION_MODE_NOT_INITIALIZED: notification_mode = NOTIFICATION_MODE_NONE; init_notifications(); break; case NOTIFICATION_MODE_WINDOWS: notification_mode = NOTIFICATION_MODE_NONE; closesocket(socket_r); closesocket(socket_w); break; case NOTIFICATION_MODE_NONE: break; default: caml_failwith("notification system in unknown state"); } /* Since pipes do not works with select, we need to use a pair of sockets. */ lwt_unix_socketpair(AF_INET, SOCK_STREAM, IPPROTO_TCP, sockets); socket_r = set_close_on_exec(sockets[0]); socket_w = set_close_on_exec(sockets[1]); notification_mode = NOTIFICATION_MODE_WINDOWS; notification_send = windows_notification_send; notification_recv = windows_notification_recv; return win_alloc_socket(socket_r); } #else /* defined(LWT_ON_WINDOWS) */ static void set_close_on_exec(int fd) { int flags = fcntl(fd, F_GETFD, 0); if (flags == -1 || fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1) uerror("set_close_on_exec", Nothing); } #if defined(HAVE_EVENTFD) static int notification_fd; static int eventfd_notification_send() { uint64_t buf = 1; return write(notification_fd, (char*)&buf, 8); } static int eventfd_notification_recv() { uint64_t buf; return read(notification_fd, (char*)&buf, 8); } #endif /* defined(HAVE_EVENTFD) */ static int notification_fds[2]; static int pipe_notification_send() { char buf; return write(notification_fds[1], &buf, 1); } static int pipe_notification_recv() { char buf; return read(notification_fds[0], &buf, 1); } value lwt_unix_init_notification() { switch (notification_mode) { #if defined(HAVE_EVENTFD) case NOTIFICATION_MODE_EVENTFD: notification_mode = NOTIFICATION_MODE_NONE; if (close(notification_fd) == -1) uerror("close", Nothing); break; #endif case NOTIFICATION_MODE_PIPE: notification_mode = NOTIFICATION_MODE_NONE; if (close(notification_fds[0]) == -1) uerror("close", Nothing); if (close(notification_fds[1]) == -1) uerror("close", Nothing); break; case NOTIFICATION_MODE_NOT_INITIALIZED: notification_mode = NOTIFICATION_MODE_NONE; init_notifications(); break; case NOTIFICATION_MODE_NONE: break; default: caml_failwith("notification system in unknown state"); } #if defined(HAVE_EVENTFD) notification_fd = eventfd(0, 0); if (notification_fd != -1) { notification_mode = NOTIFICATION_MODE_EVENTFD; notification_send = eventfd_notification_send; notification_recv = eventfd_notification_recv; set_close_on_exec(notification_fd); return Val_int(notification_fd); } #endif if (pipe(notification_fds) == -1) uerror("pipe", Nothing); set_close_on_exec(notification_fds[0]); set_close_on_exec(notification_fds[1]); notification_mode = NOTIFICATION_MODE_PIPE; notification_send = pipe_notification_send; notification_recv = pipe_notification_recv; return Val_int(notification_fds[0]); } #endif /* defined(LWT_ON_WINDOWS) */ /* +-----------------------------------------------------------------+ | Signals | +-----------------------------------------------------------------+ */ #ifndef NSIG #define NSIG 64 #endif /* Notifications id for each monitored signal. */ static int signal_notifications[NSIG]; CAMLextern int caml_convert_signal_number (int); /* Send a notification when a signal is received. */ static void handle_signal(int signum) { if (signum >= 0 && signum < NSIG) { int id = signal_notifications[signum]; if (id != -1) { #if defined(LWT_ON_WINDOWS) /* The signal handler must be reinstalled if we use the signal function. */ signal(signum, handle_signal); #endif lwt_unix_send_notification(id); } } } #if defined(LWT_ON_WINDOWS) /* Handle Ctrl+C on windows. */ static BOOL WINAPI handle_break(DWORD event) { int id = signal_notifications[SIGINT]; if (id == -1 || (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT)) return FALSE; lwt_unix_send_notification(id); return TRUE; } #endif /* Install a signal handler. */ CAMLprim value lwt_unix_set_signal(value val_signum, value val_notification) { #if !defined(LWT_ON_WINDOWS) struct sigaction sa; #endif int signum = caml_convert_signal_number(Int_val(val_signum)); int notification = Int_val(val_notification); if (signum < 0 || signum >= NSIG) caml_invalid_argument("Lwt_unix.on_signal: unavailable signal"); signal_notifications[signum] = notification; #if defined(LWT_ON_WINDOWS) if (signum == SIGINT) { if (!SetConsoleCtrlHandler(handle_break, TRUE)) { signal_notifications[signum] = -1; win32_maperr(GetLastError()); uerror("SetConsoleCtrlHandler", Nothing); } } else { if (signal(signum, handle_signal) == SIG_ERR) { signal_notifications[signum] = -1; uerror("signal", Nothing); } } #else sa.sa_handler = handle_signal; sa.sa_flags = 0; sigemptyset(&sa.sa_mask); if (sigaction(signum, &sa, NULL) == -1) { signal_notifications[signum] = -1; uerror("sigaction", Nothing); } #endif return Val_unit; } /* Remove a signal handler. */ CAMLprim value lwt_unix_remove_signal(value val_signum) { #if !defined(LWT_ON_WINDOWS) struct sigaction sa; #endif /* The signal number is valid here since it was when we did the set_signal. */ int signum = caml_convert_signal_number(Int_val(val_signum)); signal_notifications[signum] = -1; #if defined(LWT_ON_WINDOWS) if (signum == SIGINT) SetConsoleCtrlHandler(NULL, FALSE); else signal(signum, SIG_DFL); #else sa.sa_handler = SIG_DFL; sa.sa_flags = 0; sigemptyset(&sa.sa_mask); sigaction(signum, &sa, NULL); #endif return Val_unit; } /* Mark all signals as non-monitored. */ CAMLprim value lwt_unix_init_signals(value Unit) { int i; for (i = 0; i < NSIG; i++) signal_notifications[i] = -1; return Val_unit; } /* +-----------------------------------------------------------------+ | Job execution | +-----------------------------------------------------------------+ */ /* Execute the given job. */ static void execute_job(lwt_unix_job job) { DEBUG("executing the job"); lwt_unix_mutex_lock(&job->mutex); /* Mark the job as running. */ job->state = LWT_UNIX_JOB_STATE_RUNNING; /* Set the thread of the job. */ job->thread = lwt_unix_thread_self(); lwt_unix_mutex_unlock(&job->mutex); /* Execute the job. */ job->worker(job); DEBUG("job done"); lwt_unix_mutex_lock(&job->mutex); DEBUG("marking the job has done"); /* Job is done. If the main thread stopped until now, asynchronous notification is not necessary. */ job->state = LWT_UNIX_JOB_STATE_DONE; /* Send a notification if the main thread continued its execution before the job terminated. */ if (job->fast == 0) { lwt_unix_mutex_unlock(&job->mutex); DEBUG("notifying the main thread"); lwt_unix_send_notification(job->notification_id); } else { lwt_unix_mutex_unlock(&job->mutex); DEBUG("not notifying the main thread"); } } /* +-----------------------------------------------------------------+ | Thread pool | +-----------------------------------------------------------------+ */ /* Number of thread waiting for a job in the pool. */ static int thread_waiting_count = 0; /* Number of started threads. */ static int thread_count = 0; /* Maximum number of system threads that can be started. */ static int pool_size = 1000; /* Condition on which pool threads are waiting. */ static lwt_unix_condition pool_condition; /* Queue of pending jobs. It points to the last enqueued job. */ static lwt_unix_job pool_queue = NULL; /* The mutex which protect access to [pool_queue], [pool_condition] and [thread_waiting_count]. */ static lwt_unix_mutex pool_mutex; /* +-----------------------------------------------------------------+ | Thread switching | +-----------------------------------------------------------------+ */ #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) #define STACK_SIZE (256 * 1024) /* Possible states of the main thread (i.e. the one executing the ocaml code). */ enum main_state { /* The main thread is running. */ STATE_RUNNING, /* The main thread is doing a blocking call that has not yet terminated. */ STATE_BLOCKED, }; /* State of the main thread. */ static enum main_state main_state = STATE_RUNNING; /* The main thread. */ static lwt_unix_thread main_thread; /* A node in a list of stack frames. */ struct stack_frame { /* The stack frame itself. */ sigjmp_buf checkpoint; /* The next available one. */ struct stack_frame *next; }; /* Stack frames available to do a blocking call. */ static struct stack_frame *blocking_call_enter = NULL; /* Mutex to protect access to [blocking_call_enter]. */ static lwt_unix_mutex blocking_call_enter_mutex; /* Where to go when the blocking call is done, or when it get scheduled. */ static sigjmp_buf blocking_call_leave; /* Where to go to become a worjer */ static struct stack_frame *become_worker = NULL; /* Value returned to the main thread when a blocking call terminates without being scheduled. */ #define CALL_SUCCEEDED 1 /* Value returned to the old main thread whan a blocking call terminates but has been scheduled. */ #define CALL_SCHEDULED 2 /* The job to be executed on the first available alternative stack. */ static lwt_unix_job blocking_call = NULL; /* The stack frame used for the current blocking call. */ static struct stack_frame *blocking_call_frame = NULL; /* Flag which become [1] once the stack has been allocated. */ static int stack_allocated; /* Function executed on an alternative stack. */ static void altstack_worker() { struct stack_frame *node; sigjmp_buf buf; if (stack_allocated == 1) return; stack_allocated = 1; /* The first passage is to register a new stack frame. */ node = lwt_unix_new(struct stack_frame); if (sigsetjmp(node->checkpoint, 1) == 0) { /* Add it to the list of available stack frames. */ lwt_unix_mutex_lock(&blocking_call_enter_mutex); node->next = blocking_call_enter; blocking_call_enter = node; lwt_unix_mutex_unlock(&blocking_call_enter_mutex); } else { /* Save the job to execute and the current stack frame before another thread can become the main thread. */ lwt_unix_job job = blocking_call; struct stack_frame *frame = blocking_call_frame; /* Mark the main thread as blocked. */ main_state = STATE_BLOCKED; DEBUG("signaling the pool condition variable"); /* Maybe wakeup a worker so it can become the main thread. */ lwt_unix_mutex_lock(&pool_mutex); lwt_unix_condition_signal(&pool_condition); lwt_unix_mutex_unlock(&pool_mutex); DEBUG("executing the blocking call"); /* Execute the blocking call. */ execute_job(job); DEBUG("blocking call done"); lwt_unix_mutex_lock(&pool_mutex); if (lwt_unix_thread_equal(main_thread, lwt_unix_thread_self())) { /* We stayed the main thread, continue the execution normally. */ main_state = STATE_RUNNING; lwt_unix_mutex_unlock(&pool_mutex); DEBUG("blocing call terminated without blocking, resuming"); /* Leave the blocking call. */ siglongjmp(blocking_call_leave, CALL_SUCCEEDED); } else { /* We did not stayed the main thread, we now become a worker. */ assert(become_worker != NULL); /* Take and remove the first worker checkpoint. */ node = become_worker; become_worker = node->next; lwt_unix_mutex_unlock(&pool_mutex); DEBUG("blocking call terminated after blocking, becoming a worker"); /* Add the stack frame used for this call to the list of available ones. */ lwt_unix_mutex_lock(&blocking_call_enter_mutex); frame->next = blocking_call_enter; blocking_call_enter = frame; /* Release the mutex only after the jump. */ memcpy(&buf, &(node->checkpoint), sizeof(sigjmp_buf)); free(node); siglongjmp(buf, 1); } } } /* Allocate a new stack for doing blocking calls. */ void alloc_new_stack() { DEBUG("allocate a new stack"); stack_t old_stack, new_stack; struct sigaction old_sa, new_sa; /* Create the new stack. */ new_stack.ss_flags = 0; new_stack.ss_size = STACK_SIZE; new_stack.ss_sp = lwt_unix_malloc(STACK_SIZE); /* Change the stack used for signals. */ sigaltstack(&new_stack, &old_stack); stack_allocated = 0; /* Set up the custom signal handler. */ new_sa.sa_handler = altstack_worker; new_sa.sa_flags = SA_ONSTACK; sigemptyset(&new_sa.sa_mask); sigaction(LWT_UNIX_SIGNAL_ASYNC_SWITCH, &new_sa, &old_sa); /* Save the stack frame. */ raise(LWT_UNIX_SIGNAL_ASYNC_SWITCH); /* Restore the old signal handler. */ sigaction(LWT_UNIX_SIGNAL_ASYNC_SWITCH, &old_sa, NULL); /* Restore the old alternative stack. */ sigaltstack(&old_stack, NULL); } #endif /* defined(LWT_UNIX_HAVE_ASYNC_SWITCH) */ /* +-----------------------------------------------------------------+ | Threading stuff initialization | +-----------------------------------------------------------------+ */ /* Whether threading has been initialized. */ static int threading_initialized = 0; /* Initialize the pool of thread. */ void initialize_threading() { if (threading_initialized == 0) { lwt_unix_mutex_init(&pool_mutex); lwt_unix_condition_init(&pool_condition); #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) lwt_unix_mutex_init(&blocking_call_enter_mutex); main_thread = lwt_unix_thread_self(); #endif threading_initialized = 1; } } /* +-----------------------------------------------------------------+ | Worker loop | +-----------------------------------------------------------------+ */ /* Function executed by threads of the pool. */ static void* worker_loop(void *data) { lwt_unix_job job = (lwt_unix_job)data; #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) struct stack_frame *node; #endif #if defined(HAVE_PTHREAD) /* Block all signals, otherwise ocaml handlers defined with the module Sys may be executed in this thread, oops... */ sigset_t mask; sigfillset(&mask); pthread_sigmask(SIG_SETMASK, &mask, NULL); #endif /* Execute the initial job if any. */ if (job != NULL) execute_job(job); while (1) { DEBUG("entering waiting section"); lwt_unix_mutex_lock(&pool_mutex); /* One more thread is waiting for work. */ thread_waiting_count++; DEBUG("waiting for something to do"); /* Wait for something to do. */ #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) while (pool_queue == NULL && main_state == STATE_RUNNING) lwt_unix_condition_wait(&pool_condition, &pool_mutex); #else while (pool_queue == NULL) lwt_unix_condition_wait(&pool_condition, &pool_mutex); #endif DEBUG("received something to do"); /* This thread is busy. */ thread_waiting_count--; #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) if (main_state == STATE_BLOCKED) { DEBUG("main thread is blocked"); DEBUG("\e[1;31mswitching\e[0m"); /* If the main thread is blocked, we become the main thread. */ main_thread = lwt_unix_thread_self(); /* The new main thread is running again. */ main_state = STATE_RUNNING; node = lwt_unix_new(struct stack_frame); /* Save the stack frame so the old main thread can become a worker when the blocking call terminates. */ if (sigsetjmp(node->checkpoint, 1) == 0) { DEBUG("checkpoint for future worker done"); /* Save the stack frame in the list of worker checkpoints. */ node->next = become_worker; become_worker = node; DEBUG("going back to the ocaml code"); /* Go to before the blocking call. */ siglongjmp(blocking_call_leave, CALL_SCHEDULED); } DEBUG("transformation to worker done"); /* This thread is not running caml code anymore. */ //caml_c_thread_unregister(); /* Release this mutex. It was locked before the jump. */ lwt_unix_mutex_unlock(&blocking_call_enter_mutex); } else { #endif /* defined(LWT_UNIX_HAVE_ASYNC_SWITCH) */ DEBUG("taking a job to execute"); /* Take the first queued job. */ job = pool_queue->next; /* Remove it from the queue. */ if (job->next == job) pool_queue = NULL; else pool_queue->next = job->next; lwt_unix_mutex_unlock(&pool_mutex); /* Execute the job. */ execute_job(job); #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) } #endif } return NULL; } /* +-----------------------------------------------------------------+ | Jobs | +-----------------------------------------------------------------+ */ /* Description of jobs. */ struct custom_operations job_ops = { "lwt.unix.job", custom_finalize_default, custom_compare_default, custom_hash_default, custom_serialize_default, custom_deserialize_default }; /* Get the job structure contained in a custom value. */ #define Job_val(v) *(lwt_unix_job*)Data_custom_val(v) value lwt_unix_alloc_job(lwt_unix_job job) { value val_job = caml_alloc_custom(&job_ops, sizeof(lwt_unix_job), 0, 1); Job_val(val_job) = job; return val_job; } void lwt_unix_free_job(lwt_unix_job job) { if (job->async_method != LWT_UNIX_ASYNC_METHOD_NONE) lwt_unix_mutex_destroy(&job->mutex); free(job); } CAMLprim value lwt_unix_start_job(value val_job, value val_async_method) { lwt_unix_job job = Job_val(val_job); #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) struct stack_frame *node; #endif lwt_unix_async_method async_method = Int_val(val_async_method); int done = 0; /* 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); } done = job->state == LWT_UNIX_JOB_STATE_DONE; if (done) { /* Wait for the mutex to be released because the job is going to be freed immediately. */ lwt_unix_mutex_lock(&job->mutex); lwt_unix_mutex_unlock(&job->mutex); } return Val_bool(done); case LWT_UNIX_ASYNC_METHOD_SWITCH: #if defined(LWT_UNIX_SIGNAL_ASYNC_SWITCH) if (SIGRTMIN > SIGRTMAX) caml_invalid_argument("the switch method is not supported"); if (threading_initialized == 0) initialize_threading(); lwt_unix_mutex_init(&job->mutex); job->thread = main_thread; /* Ensures there is at least one thread that can become the main thread. */ if (thread_waiting_count == 0) { thread_count++; lwt_unix_launch_thread(worker_loop, NULL); } if (blocking_call_enter == NULL) alloc_new_stack(); DEBUG("taking a stack frame for doing a blocking call"); /* Take and remove the first available stack frame for system calls. */ lwt_unix_mutex_lock(&blocking_call_enter_mutex); assert(blocking_call_enter != NULL); node = blocking_call_enter; blocking_call_enter = node->next; lwt_unix_mutex_unlock(&blocking_call_enter_mutex); /* Save the stack frame to leave the blocking call. */ switch (sigsetjmp(blocking_call_leave, 1)) { case 0: /* Save the job to do. */ blocking_call = job; /* Save the stack frame that will be used for this call in case it get scheduled. */ blocking_call_frame = node; DEBUG("jumping to do a blocking call"); /* Jump to an alternative stack and do the call. */ siglongjmp(node->checkpoint, 1); case CALL_SUCCEEDED: DEBUG("resuming without being scheduled"); /* Re-add the stack frame used for the call to the list of available ones. */ lwt_unix_mutex_lock(&blocking_call_enter_mutex); node->next = blocking_call_enter; blocking_call_enter = node; lwt_unix_mutex_unlock(&blocking_call_enter_mutex); return Val_true; case CALL_SCHEDULED: DEBUG("resuming after being scheduled"); /* This mutex was locked before we did the jump. */ lwt_unix_mutex_unlock(&pool_mutex); /* This thread is now running caml code. */ //caml_c_thread_register(); done = job->state == LWT_UNIX_JOB_STATE_DONE; if (done) { lwt_unix_mutex_lock(&job->mutex); lwt_unix_mutex_unlock(&job->mutex); } return Val_bool(done); } #else /* defined(LWT_UNIX_SIGNAL_ASYNC_SWITCH) */ caml_invalid_argument("the switch method is not supported"); #endif } return Val_false; } CAMLprim value lwt_unix_check_job(value val_job, value val_notification_id) { lwt_unix_job job = Job_val(val_job); value result; DEBUG("checking job"); switch (job->async_method) { case LWT_UNIX_ASYNC_METHOD_NONE: return Val_int(1); case LWT_UNIX_ASYNC_METHOD_DETACH: case LWT_UNIX_ASYNC_METHOD_SWITCH: lwt_unix_mutex_lock(&job->mutex); /* We are not waiting anymore. */ job->fast = 0; /* Set the notification id for asynchronous wakeup. */ job->notification_id = Int_val(val_notification_id); result = Val_bool(job->state == LWT_UNIX_JOB_STATE_DONE); lwt_unix_mutex_unlock(&job->mutex); DEBUG("job done: %d", Int_val(result)); return result; } return Val_int(0); } CAMLprim value lwt_unix_self_result(value val_job) { lwt_unix_job job = Job_val(val_job); return job->result(job); } CAMLprim value lwt_unix_run_job_sync(value val_job) { lwt_unix_job job = Job_val(val_job); /* So lwt_unix_free_job won't try to destroy the mutex. */ job->async_method = LWT_UNIX_ASYNC_METHOD_NONE; caml_enter_blocking_section(); job->worker(job); caml_leave_blocking_section(); return job->result(job); } CAMLprim value lwt_unix_reset_after_fork(value Unit) { if (threading_initialized) { #if defined(LWT_UNIX_HAVE_ASYNC_SWITCH) /* Reset the main thread. */ main_thread = lwt_unix_thread_self (); #endif /* There is no more waiting threads. */ thread_waiting_count = 0; /* There is no more threads. */ thread_count = 0; /* Empty the queue. */ pool_queue = NULL; } return Val_unit; } /* +-----------------------------------------------------------------+ | Statistics and control | +-----------------------------------------------------------------+ */ CAMLprim value lwt_unix_pool_size(value Unit) { 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(value Unit) { return Val_int(thread_count); } CAMLprim value lwt_unix_thread_waiting_count(value Unit) { return Val_int(thread_waiting_count); } lwt-2.5.2/src/unix/lwt_unix_unix.c000066400000000000000000002422541270742521300171740ustar00rootroot00000000000000/* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Lwt_unix_unix * Copyright (C) 2009-2010 Jérémie Dimino * 2009 Mauricio Fernandez * 2010 Pierre Chambart * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. */ /* Unix (non windows) version of stubs. */ #define ARGS(args...) args #include #include #include #include #include #include /* +-----------------------------------------------------------------+ | Test for readability/writability | +-----------------------------------------------------------------+ */ CAMLprim value lwt_unix_readable(value fd) { struct pollfd pollfd; pollfd.fd = Int_val(fd); pollfd.events = POLLIN; pollfd.revents = 0; if (poll(&pollfd, 1, 0) < 0) uerror("readable", Nothing); return (Val_bool(pollfd.revents & POLLIN)); } CAMLprim value lwt_unix_writable(value fd) { struct pollfd pollfd; pollfd.fd = Int_val(fd); pollfd.events = POLLOUT; pollfd.revents = 0; if (poll(&pollfd, 1, 0) < 0) uerror("writable", 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(value Unit) { long page_size = sysconf(_SC_PAGESIZE); if (page_size < 0) page_size = 4096; return Val_long(page_size); } #ifdef __CYGWIN__ LWT_NOT_AVAILABLE4(unix_mincore) #else 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; } #endif /* +-----------------------------------------------------------------+ | read/write | +-----------------------------------------------------------------+ */ CAMLprim value lwt_unix_read(value val_fd, value val_buf, value val_ofs, value val_len) { long ret; ret = read(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len)); if (ret == -1) uerror("read", Nothing); return Val_long(ret); } CAMLprim value lwt_unix_bytes_read(value val_fd, value val_buf, value val_ofs, value val_len) { long ret; ret = read(Int_val(val_fd), (char*)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs), Long_val(val_len)); if (ret == -1) uerror("read", Nothing); return Val_long(ret); } CAMLprim value lwt_unix_write(value val_fd, value val_buf, value val_ofs, value val_len) { long ret; ret = write(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len)); if (ret == -1) uerror("write", Nothing); return Val_long(ret); } CAMLprim value lwt_unix_bytes_write(value val_fd, value val_buf, value val_ofs, value val_len) { long ret; ret = write(Int_val(val_fd), (char*)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs), Long_val(val_len)); if (ret == -1) uerror("write", Nothing); return Val_long(ret); } /* +-----------------------------------------------------------------+ | recv/send | +-----------------------------------------------------------------+ */ static int msg_flag_table[] = { MSG_OOB, MSG_DONTROUTE, MSG_PEEK }; value lwt_unix_recv(value fd, value buf, value ofs, value len, value flags) { int ret; ret = recv(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), convert_flag_list(flags, msg_flag_table)); if (ret == -1) uerror("recv", Nothing); return Val_int(ret); } value lwt_unix_bytes_recv(value fd, value buf, value ofs, value len, value flags) { int ret; ret = recv(Int_val(fd), (char*)Caml_ba_array_val(buf)->data + Long_val(ofs), Long_val(len), convert_flag_list(flags, msg_flag_table)); if (ret == -1) uerror("recv", Nothing); return Val_int(ret); } value lwt_unix_send(value fd, value buf, value ofs, value len, value flags) { int ret; ret = send(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), convert_flag_list(flags, msg_flag_table)); if (ret == -1) uerror("send", Nothing); return Val_int(ret); } value lwt_unix_bytes_send(value fd, value buf, value ofs, value len, value flags) { int ret; ret = send(Int_val(fd), (char*)Caml_ba_array_val(buf)->data + Long_val(ofs), Long_val(len), convert_flag_list(flags, msg_flag_table)); if (ret == -1) uerror("send", Nothing); return Val_int(ret); } /* +-----------------------------------------------------------------+ | recvfrom/sendto | +-----------------------------------------------------------------+ */ extern int socket_domain_table[]; extern int socket_type_table[]; union sock_addr_union { struct sockaddr s_gen; struct sockaddr_un s_unix; struct sockaddr_in s_inet; struct sockaddr_in6 s_inet6; }; CAMLexport value alloc_sockaddr (union sock_addr_union * addr /*in*/, socklen_t addr_len, int close_on_error); value lwt_unix_recvfrom(value fd, value buf, value ofs, value len, value flags) { CAMLparam5(fd, buf, ofs, len, flags); CAMLlocal2(result, address); int ret; union sock_addr_union addr; socklen_t addr_len; addr_len = sizeof(addr); ret = recvfrom(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), convert_flag_list(flags, msg_flag_table), &addr.s_gen, &addr_len); if (ret == -1) uerror("recvfrom", Nothing); address = alloc_sockaddr(&addr, addr_len, -1); result = caml_alloc_tuple(2); Field(result, 0) = Val_int(ret); Field(result, 1) = address; CAMLreturn(result); } value lwt_unix_bytes_recvfrom(value fd, value buf, value ofs, value len, value flags) { CAMLparam5(fd, buf, ofs, len, flags); CAMLlocal2(result, address); int ret; union sock_addr_union addr; socklen_t addr_len; addr_len = sizeof(addr); ret = recvfrom(Int_val(fd), (char*)Caml_ba_data_val(buf) + Long_val(ofs), Long_val(len), convert_flag_list(flags, msg_flag_table), &addr.s_gen, &addr_len); if (ret == -1) uerror("recvfrom", Nothing); address = alloc_sockaddr(&addr, addr_len, -1); result = caml_alloc_tuple(2); Field(result, 0) = Val_int(ret); Field(result, 1) = address; CAMLreturn(result); } extern void get_sockaddr (value mladdr, union sock_addr_union * addr /*out*/, socklen_t * addr_len /*out*/); value lwt_unix_sendto(value fd, value buf, value ofs, value len, value flags, value dest) { union sock_addr_union addr; socklen_t addr_len; int ret; get_sockaddr(dest, &addr, &addr_len); ret = sendto(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len), convert_flag_list(flags, msg_flag_table), &addr.s_gen, addr_len); if (ret == -1) uerror("send", Nothing); return Val_int(ret); } CAMLprim value lwt_unix_sendto_byte(value *argv, int argc) { return lwt_unix_sendto(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } value lwt_unix_bytes_sendto(value fd, value buf, value ofs, value len, value flags, value dest) { union sock_addr_union addr; socklen_t addr_len; int ret; get_sockaddr(dest, &addr, &addr_len); ret = sendto(Int_val(fd), (char*)Caml_ba_data_val(buf) + Long_val(ofs), Long_val(len), convert_flag_list(flags, msg_flag_table), &addr.s_gen, addr_len); if (ret == -1) uerror("send", Nothing); return Val_int(ret); } CAMLprim value lwt_unix_bytes_sendto_byte(value *argv, int argc) { return lwt_unix_bytes_sendto(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } /* +-----------------------------------------------------------------+ | {recv/send}_msg | +-----------------------------------------------------------------+ */ /* Convert a caml list of io-vectors into a C array io io-vector structures */ static void store_iovs(struct iovec *iovs, value iovs_val) { CAMLparam0(); CAMLlocal2(list, x); for(list = iovs_val; Is_block(list); list = Field(list, 1), iovs++) { x = Field(list, 0); iovs->iov_base = &Byte(String_val(Field(x, 0)), Long_val(Field(x, 1))); iovs->iov_len = Long_val(Field(x, 2)); } CAMLreturn0; } static void bytes_store_iovs(struct iovec *iovs, value iovs_val) { CAMLparam0(); CAMLlocal2(list, x); for(list = iovs_val; Is_block(list); list = Field(list, 1), iovs++) { x = Field(list, 0); iovs->iov_base = (char*)Caml_ba_data_val(Field(x, 0)) + Long_val(Field(x, 1)); iovs->iov_len = Long_val(Field(x, 2)); } CAMLreturn0; } static value wrapper_recv_msg(int fd, int n_iovs, struct iovec *iovs) { CAMLparam0(); CAMLlocal3(list, result, x); struct msghdr msg; memset(&msg, 0, sizeof(msg)); msg.msg_iov = iovs; msg.msg_iovlen = n_iovs; #if defined(HAVE_FD_PASSING) msg.msg_controllen = CMSG_SPACE(256 * sizeof(int)); msg.msg_control = alloca(msg.msg_controllen); memset(msg.msg_control, 0, msg.msg_controllen); #endif int ret = recvmsg(fd, &msg, 0); if (ret == -1) uerror("recv_msg", Nothing); list = Val_int(0); #if defined(HAVE_FD_PASSING) struct cmsghdr *cm; for (cm = CMSG_FIRSTHDR(&msg); cm; cm = CMSG_NXTHDR(&msg, cm)) if (cm->cmsg_level == SOL_SOCKET && cm->cmsg_type == SCM_RIGHTS) { int *fds = (int*)CMSG_DATA(cm); int nfds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int); int i; for(i = nfds - 1; i >= 0; i--) { x = caml_alloc_tuple(2); Store_field(x, 0, Val_int(fds[i])); Store_field(x, 1, list); list = x; }; break; }; #endif result = caml_alloc_tuple(2); Store_field(result, 0, Val_int(ret)); Store_field(result, 1, list); CAMLreturn(result); } CAMLprim value lwt_unix_recv_msg(value val_fd, value val_n_iovs, value val_iovs) { int n_iovs = Int_val(val_n_iovs); struct iovec iovs[n_iovs]; store_iovs(iovs, val_iovs); return wrapper_recv_msg(Int_val(val_fd), n_iovs, iovs); } CAMLprim value lwt_unix_bytes_recv_msg(value val_fd, value val_n_iovs, value val_iovs) { int n_iovs = Int_val(val_n_iovs); struct iovec iovs[n_iovs]; bytes_store_iovs(iovs, val_iovs); return wrapper_recv_msg(Int_val(val_fd), n_iovs, iovs); } static value wrapper_send_msg(int fd, int n_iovs, struct iovec *iovs, value val_n_fds, value val_fds) { CAMLparam2(val_n_fds, val_fds); struct msghdr msg; memset(&msg, 0, sizeof(msg)); msg.msg_iov = iovs; msg.msg_iovlen = n_iovs; int n_fds = Int_val(val_n_fds); #if defined(HAVE_FD_PASSING) if (n_fds > 0) { msg.msg_controllen = CMSG_SPACE(n_fds * sizeof(int)); msg.msg_control = alloca(msg.msg_controllen); memset(msg.msg_control, 0, msg.msg_controllen); struct cmsghdr *cm; cm = CMSG_FIRSTHDR(&msg); cm->cmsg_level = SOL_SOCKET; cm->cmsg_type = SCM_RIGHTS; cm->cmsg_len = CMSG_LEN(n_fds * sizeof(int)); int *fds = (int*)CMSG_DATA(cm); for(; Is_block(val_fds); val_fds = Field(val_fds, 1), fds++) *fds = Int_val(Field(val_fds, 0)); }; #else if (n_fds > 0) lwt_unix_not_available("fd_passing"); #endif int ret = sendmsg(fd, &msg, 0); if (ret == -1) uerror("send_msg", Nothing); CAMLreturn(Val_int(ret)); } CAMLprim value lwt_unix_send_msg(value val_fd, value val_n_iovs, value val_iovs, value val_n_fds, value val_fds) { int n_iovs = Int_val(val_n_iovs); struct iovec iovs[n_iovs]; store_iovs(iovs, val_iovs); return wrapper_send_msg(Int_val(val_fd), n_iovs, iovs, val_n_fds, val_fds); } CAMLprim value lwt_unix_bytes_send_msg(value val_fd, value val_n_iovs, value val_iovs, value val_n_fds, value val_fds) { int n_iovs = Int_val(val_n_iovs); struct iovec iovs[n_iovs]; bytes_store_iovs(iovs, val_iovs); return wrapper_send_msg(Int_val(val_fd), n_iovs, iovs, val_n_fds, val_fds); } /* +-----------------------------------------------------------------+ | Credentials | +-----------------------------------------------------------------+ */ #if defined(HAVE_GET_CREDENTIALS_LINUX) # define CREDENTIALS_TYPE struct ucred # define CREDENTIALS_FIELD(id) id #elif defined(HAVE_GET_CREDENTIALS_NETBSD) # define CREDENTIALS_TYPE struct sockcred # define CREDENTIALS_FIELD(id) sc_ ## id #elif defined(HAVE_GET_CREDENTIALS_OPENBSD) # define CREDENTIALS_TYPE struct sockpeercred # define CREDENTIALS_FIELD(id) id #elif defined(HAVE_GET_CREDENTIALS_FREEBSD) # define CREDENTIALS_TYPE struct cmsgcred # define CREDENTIALS_FIELD(id) cmsgcred_ ## id #endif #if defined(CREDENTIALS_TYPE) CAMLprim value lwt_unix_get_credentials(value fd) { CAMLparam1(fd); CAMLlocal1(res); CREDENTIALS_TYPE cred; socklen_t cred_len = sizeof(cred); if (getsockopt(Int_val(fd), SOL_SOCKET, SO_PEERCRED, &cred, &cred_len) == -1) uerror("get_credentials", Nothing); res = caml_alloc_tuple(3); Store_field(res, 0, Val_int(cred.CREDENTIALS_FIELD(pid))); Store_field(res, 1, Val_int(cred.CREDENTIALS_FIELD(uid))); Store_field(res, 2, Val_int(cred.CREDENTIALS_FIELD(gid))); CAMLreturn(res); } #elif defined(HAVE_GETPEEREID) CAMLprim value lwt_unix_get_credentials(value fd) { CAMLparam1(fd); CAMLlocal1(res); uid_t euid; gid_t egid; if (getpeereid(Int_val(fd), &euid, &egid) == -1) uerror("get_credentials", Nothing); res = caml_alloc_tuple(3); Store_field(res, 0, Val_int(-1)); Store_field(res, 1, Val_int(euid)); Store_field(res, 2, Val_int(egid)); CAMLreturn(res); } #else LWT_NOT_AVAILABLE1(unix_get_credentials) #endif /* +-----------------------------------------------------------------+ | Multicast functions | +-----------------------------------------------------------------+ */ static int socket_domain (int fd) { /* Return the socket domain, PF_INET or PF_INET6. Fails for non-IP protos. fd must be a socket! */ union sock_addr_union addr; socklen_t l; l = sizeof(addr); if (getsockname(fd, &addr.s_gen, &l) == -1) uerror("getsockname", Nothing); switch (addr.s_gen.sa_family) { case AF_INET: return PF_INET; case AF_INET6: return PF_INET6; default: invalid_argument("Not an Internet socket"); } return 0; } CAMLprim value lwt_unix_mcast_set_loop (value fd, value flag) { int t, r, f; t = socket_domain(Int_val(fd)); f = Bool_val(flag); r = 0; switch (t) { case PF_INET: r = setsockopt (Int_val(fd), IPPROTO_IP, IP_MULTICAST_LOOP, (void *) &f, sizeof(f)); break; default: invalid_argument("lwt_unix_mcast_set_loop"); }; if (r == -1) uerror("setsockopt",Nothing); return Val_unit; } CAMLprim value lwt_unix_mcast_set_ttl (value fd, value ttl) { int t, r, v; int fd_sock; fd_sock = Int_val(fd); t = socket_domain(fd_sock); v = Int_val(ttl); r = 0; switch (t) { case PF_INET: r = setsockopt(fd_sock, IPPROTO_IP, IP_MULTICAST_TTL, (void *) &v, sizeof(v)); break; default: invalid_argument("lwt_unix_mcast_set_ttl"); }; if (r == -1) uerror("setsockopt",Nothing); return Val_unit; } /* Keep this in sync with the type Lwt_unix.mcast_action */ #define VAL_MCAST_ACTION_ADD (Val_int(0)) #define VAL_MCAST_ACTION_DROP (Val_int(1)) #define GET_INET_ADDR(v) (*((struct in_addr *) (v))) CAMLprim value lwt_unix_mcast_modify_membership (value fd, value v_action, value if_addr, value group_addr) { int t, r; int fd_sock; int optname; fd_sock = Int_val(fd); t = socket_domain(fd_sock); r = 0; switch (t) { case PF_INET: { struct ip_mreq mreq; if (string_length(group_addr) != 4 || string_length(if_addr) != 4 ) invalid_argument("lwt_unix_mcast_modify: Not an IPV4 address"); memcpy(&mreq.imr_multiaddr, &GET_INET_ADDR(group_addr), 4); memcpy(&mreq.imr_interface, &GET_INET_ADDR(if_addr), 4); switch (v_action) { case VAL_MCAST_ACTION_ADD: optname = IP_ADD_MEMBERSHIP; break; default: optname = IP_DROP_MEMBERSHIP; break; } r = setsockopt(fd_sock, IPPROTO_IP, optname, (void *) &mreq, sizeof(mreq)); break; } default: invalid_argument("lwt_unix_mcast_modify_membership"); }; if (r == -1) uerror("setsockopt", Nothing); return Val_unit; } /* +-----------------------------------------------------------------+ | wait4 | +-----------------------------------------------------------------+ */ /* Some code duplicated from OCaml's otherlibs/unix/wait.c */ CAMLextern int caml_convert_signal_number (int); CAMLextern int caml_rev_convert_signal_number (int); #if !defined(__ANDROID__) #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); } #else LWT_NOT_AVAILABLE2(unix_wait4) #endif /* +-----------------------------------------------------------------+ | CPUs | +-----------------------------------------------------------------+ */ #if defined(HAVE_GETCPU) CAMLprim value lwt_unix_get_cpu(value Unit) { int cpu = sched_getcpu(); if (cpu < 0) uerror("sched_getcpu", Nothing); return Val_int(cpu); } #else LWT_NOT_AVAILABLE1(unix_get_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; } #else LWT_NOT_AVAILABLE1(unix_get_affinity) LWT_NOT_AVAILABLE2(unix_set_affinity) #endif /* +-----------------------------------------------------------------+ | JOB: guess_blocking | +-----------------------------------------------------------------+ */ struct job_guess_blocking { struct lwt_unix_job job; int fd; int result; }; static void worker_guess_blocking(struct job_guess_blocking *job) { struct stat stat; if (fstat(job->fd, &stat) == 0) job->result = !(S_ISFIFO(stat.st_mode) || S_ISSOCK(stat.st_mode)); else job->result = 1; } static value result_guess_blocking(struct job_guess_blocking *job) { value result = Val_bool(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_guess_blocking_job(value val_fd) { LWT_UNIX_INIT_JOB(job, guess_blocking, 0); job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: wait_mincore | +-----------------------------------------------------------------+ */ #ifdef __CYGWIN__ LWT_NOT_AVAILABLE2(unix_wait_mincore_job) #else struct job_wait_mincore { struct lwt_unix_job job; char *ptr; }; static void worker_wait_mincore(struct job_wait_mincore *job) { /* Read the byte to force the kernel to fetch the page: */ char dummy; memcpy(&dummy, job->ptr, 1); } static value result_wait_mincore(struct job_wait_mincore *job) { lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_wait_mincore_job(value val_buffer, value val_offset) { LWT_UNIX_INIT_JOB(job, wait_mincore, 0); job->ptr = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); return lwt_unix_alloc_job(&(job->job)); } #endif /* +-----------------------------------------------------------------+ | JOB: open | +-----------------------------------------------------------------+ */ #ifndef O_NONBLOCK #define O_NONBLOCK O_NDELAY #endif #ifndef O_DSYNC #define O_DSYNC 0 #endif #ifndef O_SYNC #define O_SYNC 0 #endif #ifndef O_RSYNC #define O_RSYNC 0 #endif static int open_flag_table[] = { O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC, 0, #ifdef O_CLOEXEC O_CLOEXEC #else #define NEED_CLOEXEC_EMULATION 0 #endif }; #ifdef NEED_CLOEXEC_EMULATION static int open_cloexec_table[14] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 }; #endif struct job_open { struct lwt_unix_job job; int flags; int perms; int fd; int blocking; int error_code; char *name; char data[]; }; static void worker_open(struct job_open *job) { int fd; fd = open(job->name, job->flags, job->perms); #if defined(NEED_CLOEXEC_EMULATION) && defined(FD_CLOEXEC) if (fd >= 0 && job->fd) { int flags = fcntl(fd, F_GETFD, 0); if (flags == -1 || fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1) { int serrno = errno; close(fd); errno = serrno; fd = -1; } } #endif job->fd = fd; job->error_code = errno; if (fd >= 0) { struct stat stat; if (fstat(fd, &stat) < 0) job->blocking = 1; else job->blocking = !(S_ISFIFO(stat.st_mode) || S_ISSOCK(stat.st_mode)); } } static value result_open(struct job_open *job) { int fd = job->fd; LWT_UNIX_CHECK_JOB_ARG(job, fd < 0, "open", job->name); value result = caml_alloc_tuple(2); Field(result, 0) = Val_int(fd); Field(result, 1) = Val_bool(job->blocking); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_open_job(value name, value flags, value perms) { LWT_UNIX_INIT_JOB_STRING(job, open, 0, name); #ifdef NEED_CLOEXEC_EMULATION job->fd = convert_flag_list(flags, open_cloexec_table) != 0; #endif job->flags = convert_flag_list(flags, open_flag_table); job->perms = Int_val(perms); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: read | +-----------------------------------------------------------------+ */ struct job_read { struct lwt_unix_job job; /* The file descriptor. */ int fd; /* The amount of data to read. */ long length; /* The OCaml string. */ value string; /* The offset in the string. */ long offset; /* The result of the read syscall. */ long result; /* The value of errno. */ int error_code; /* The temporary buffer. */ char buffer[]; }; static void worker_read(struct job_read *job) { job->result = read(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_read(struct job_read *job) { long result = job->result; if (result < 0) { int error_code = job->error_code; caml_remove_generational_global_root(&(job->string)); lwt_unix_free_job(&job->job); unix_error(error_code, "read", Nothing); } else { memcpy(String_val(job->string) + job->offset, job->buffer, result); caml_remove_generational_global_root(&(job->string)); lwt_unix_free_job(&job->job); return Val_long(result); } } CAMLprim value lwt_unix_read_job(value val_fd, value val_buffer, value val_offset, value val_length) { long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, read, length); job->fd = Int_val(val_fd); job->length = length; job->string = val_buffer; job->offset = Long_val(val_offset); caml_register_generational_global_root(&(job->string)); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: bytes_read | +-----------------------------------------------------------------+ */ struct job_bytes_read { struct lwt_unix_job job; /* The file descriptor. */ int fd; /* The destination buffer. */ char *buffer; /* The offset in the string. */ long offset; /* The amount of data to read. */ long length; /* The result of the read syscall. */ long result; /* The value of errno. */ int error_code; }; static void worker_bytes_read(struct job_bytes_read *job) { job->result = read(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_bytes_read(struct job_bytes_read *job) { long result = job->result; LWT_UNIX_CHECK_JOB(job, result < 0, "read"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buf, value val_ofs, value val_len) { LWT_UNIX_INIT_JOB(job, bytes_read, 0); job->fd = Int_val(val_fd); job->buffer = (char*)Caml_ba_data_val(val_buf) + Long_val(val_ofs); job->length = Long_val(val_len); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: write | +-----------------------------------------------------------------+ */ struct job_write { struct lwt_unix_job job; int fd; long length; long result; int error_code; char buffer[]; }; static void worker_write(struct job_write *job) { job->result = write(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_write(struct job_write *job) { long result = job->result; LWT_UNIX_CHECK_JOB(job, result < 0, "write"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length) { long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, write, length); job->fd = Int_val(val_fd); job->length = length; memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: bytes_write | +-----------------------------------------------------------------+ */ struct job_bytes_write { struct lwt_unix_job job; int fd; char *buffer; long length; long result; int error_code; }; static void worker_bytes_write(struct job_bytes_write *job) { job->result = write(job->fd, job->buffer, job->length); job->error_code = errno; } static value result_bytes_write(struct job_bytes_write *job) { long result = job->result; LWT_UNIX_CHECK_JOB(job, result < 0, "write"); lwt_unix_free_job(&job->job); return Val_long(result); } CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length) { LWT_UNIX_INIT_JOB(job, bytes_write, 0); job->fd = Int_val(val_fd); job->buffer = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); job->length = Long_val(val_length); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: stat | +-----------------------------------------------------------------+ */ struct job_stat { struct lwt_unix_job job; struct stat stat; int result; int error_code; char *name; char data[]; }; static value copy_stat(int use_64, struct stat *buf) { CAMLparam0(); CAMLlocal5(atime, mtime, ctime, offset, v); atime = copy_double((double) buf->st_atime + (NANOSEC(buf, a) / 1000000000.0)); mtime = copy_double((double) buf->st_mtime + (NANOSEC(buf, m) / 1000000000.0)); ctime = copy_double((double) buf->st_ctime + (NANOSEC(buf, c) / 1000000000.0)); offset = use_64 ? caml_copy_int64(buf->st_size) : Val_int(buf->st_size); v = alloc_small(12, 0); Field(v, 0) = Val_int (buf->st_dev); Field(v, 1) = Val_int (buf->st_ino); switch (buf->st_mode & S_IFMT) { case S_IFREG: Field(v, 2) = Val_int(0); break; case S_IFDIR: Field(v, 2) = Val_int(1); break; case S_IFCHR: Field(v, 2) = Val_int(2); break; case S_IFBLK: Field(v, 2) = Val_int(3); break; case S_IFLNK: Field(v, 2) = Val_int(4); break; case S_IFIFO: Field(v, 2) = Val_int(5); break; case S_IFSOCK: Field(v, 2) = Val_int(6); break; default: Field(v, 2) = Val_int(0); break; } Field(v, 3) = Val_int(buf->st_mode & 07777); Field(v, 4) = Val_int(buf->st_nlink); Field(v, 5) = Val_int(buf->st_uid); Field(v, 6) = Val_int(buf->st_gid); Field(v, 7) = Val_int(buf->st_rdev); Field(v, 8) = offset; Field(v, 9) = atime; Field(v, 10) = mtime; Field(v, 11) = ctime; CAMLreturn(v); } static void worker_stat(struct job_stat *job) { job->result = stat(job->name, &job->stat); job->error_code = errno; } static value result_stat(struct job_stat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "stat", job->name); value result = copy_stat(0, &job->stat); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_stat_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, stat, 0, name); return lwt_unix_alloc_job(&(job->job)); } static value result_stat_64(struct job_stat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "stat", job->name); value result = copy_stat(1, &job->stat); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_stat_64_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, stat, 0, name); job->job.result = (lwt_unix_job_result)result_stat_64; return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: lstat | +-----------------------------------------------------------------+ */ struct job_lstat { struct lwt_unix_job job; struct stat lstat; int result; int error_code; char *name; char data[]; }; static void worker_lstat(struct job_lstat *job) { job->result = lstat(job->name, &job->lstat); job->error_code = errno; } static value result_lstat(struct job_lstat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "lstat", job->name); value result = copy_stat(0, &(job->lstat)); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_lstat_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, lstat, 0, name); return lwt_unix_alloc_job(&(job->job)); } static value result_lstat_64(struct job_lstat *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "lstat", job->name); value result = copy_stat(1, &(job->lstat)); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_lstat_64_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, lstat, 0, name); job->job.result = (lwt_unix_job_result)result_lstat_64; return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: fstat | +-----------------------------------------------------------------+ */ struct job_fstat { struct lwt_unix_job job; int fd; struct stat fstat; int result; int error_code; }; static void worker_fstat(struct job_fstat *job) { job->result = fstat(job->fd, &(job->fstat)); job->error_code = errno; } static value result_fstat(struct job_fstat *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "fstat"); value result = copy_stat(0, &(job->fstat)); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_fstat_job(value val_fd) { LWT_UNIX_INIT_JOB(job, fstat, 0); job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } static value result_fstat_64(struct job_fstat *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "fstat"); value result = copy_stat(1, &(job->fstat)); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_fstat_64_job(value val_fd) { LWT_UNIX_INIT_JOB(job, fstat, 0); job->job.result = (lwt_unix_job_result)result_fstat_64; job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: isatty | +-----------------------------------------------------------------+ */ struct job_isatty { struct lwt_unix_job job; int fd; int result; }; static void worker_isatty(struct job_isatty *job) { job->result = isatty(job->fd); } static value result_isatty(struct job_isatty *job) { value result = Val_bool(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_isatty_job(value val_fd) { LWT_UNIX_INIT_JOB(job, isatty, 0); job->fd = Int_val(val_fd); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: opendir | +-----------------------------------------------------------------+ */ struct job_opendir { struct lwt_unix_job job; DIR* result; int error_code; char* path; char data[]; }; static void worker_opendir(struct job_opendir* job) { job->result = opendir(job->path); job->error_code = errno; } static value result_opendir(struct job_opendir* job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result == NULL, "opendir", job->path); value result = caml_alloc_small(1, Abstract_tag); DIR_Val(result) = job->result; lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_opendir_job(value path) { LWT_UNIX_INIT_JOB_STRING(job, opendir, 0, path); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: closedir | +-----------------------------------------------------------------+ */ struct job_closedir { struct lwt_unix_job job; int result; int error_code; DIR* dir; }; static void worker_closedir(struct job_closedir* job) { job->result = closedir(job->dir); job->error_code = errno; } static value result_closedir(struct job_closedir* job) { LWT_UNIX_CHECK_JOB(job, job->dir < 0, "closedir"); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_closedir_job(value dir) { LWT_UNIX_INIT_JOB(job, closedir, 0); job->dir = DIR_Val(dir); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: rewinddir | +-----------------------------------------------------------------+ */ struct job_rewinddir { struct lwt_unix_job job; DIR* dir; }; static void worker_rewinddir(struct job_rewinddir *job) { rewinddir(job->dir); } static value result_rewinddir(struct job_rewinddir *job) { lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_rewinddir_job(value dir) { LWT_UNIX_INIT_JOB(job, rewinddir, 0); job->dir = DIR_Val(dir); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: readdir | +-----------------------------------------------------------------+ */ struct job_readdir { struct lwt_unix_job job; DIR *dir; struct dirent *entry; struct dirent *ptr; int result; }; static void worker_readdir(struct job_readdir *job) { job->entry = lwt_unix_malloc(offsetof(struct dirent, d_name) + fpathconf(dirfd(job->dir), _PC_NAME_MAX) + 1); job->result = readdir_r(job->dir, job->entry, &job->ptr); } static value result_readdir(struct job_readdir *job) { int result = job->result; if (result) { free(job->entry); lwt_unix_free_job(&job->job); unix_error(result, "readdir", Nothing); } else if (job->ptr == NULL) { free(job->entry); lwt_unix_free_job(&job->job); caml_raise_end_of_file(); } else { value name = caml_copy_string(job->entry->d_name); free(job->entry); lwt_unix_free_job(&job->job); return name; } } CAMLprim value lwt_unix_readdir_job(value val_dir) { LWT_UNIX_INIT_JOB(job, readdir, 0); job->dir = DIR_Val(val_dir); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: readdir_n | +-----------------------------------------------------------------+ */ struct job_readdir_n { struct lwt_unix_job job; DIR *dir; long count; int error_code; struct dirent *entries[]; }; static void worker_readdir_n(struct job_readdir_n *job) { size_t size = offsetof(struct dirent, d_name) + fpathconf(dirfd(job->dir), _PC_NAME_MAX) + 1; long i; for(i = 0; i < job->count; i++) { struct dirent *ptr; struct dirent *entry = (struct dirent *)lwt_unix_malloc(size); int result = readdir_r(job->dir, entry, &ptr); /* An error happened. */ if (result != 0) { /* Free already read entries. */ free(entry); long j; for(j = 0; j < i; j++) free(job->entries[j]); /* Return an error. */ job->error_code = result; return; } /* End of directory reached */ if (ptr == NULL) { free(entry); break; } job->entries[i] = entry; } job->count = i; job->error_code = 0; } static value result_readdir_n(struct job_readdir_n *job) { CAMLparam0(); CAMLlocal1(result); int error_code = job->error_code; if (error_code) { lwt_unix_free_job(&job->job); unix_error(error_code, "readdir", Nothing); } else { result = caml_alloc(job->count, 0); long i; for(i = 0; i < job->count; i++) { Store_field(result, i, caml_copy_string(job->entries[i]->d_name)); free(job->entries[i]); } CAMLreturn(result); } } CAMLprim value lwt_unix_readdir_n_job(value val_dir, value val_count) { long count = Long_val(val_count); LWT_UNIX_INIT_JOB(job, readdir_n, sizeof(struct dirent*) * count); job->dir = DIR_Val(val_dir); job->count = count; return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: readlink | +-----------------------------------------------------------------+ */ struct job_readlink { struct lwt_unix_job job; char *buffer; ssize_t result; int error_code; char *name; char data[]; }; static void worker_readlink(struct job_readlink *job) { ssize_t buffer_size = 1024; ssize_t link_length; for (;;) { job->buffer = lwt_unix_malloc(buffer_size + 1); link_length = readlink(job->name, job->buffer, buffer_size); if (link_length < 0) { free(job->buffer); job->result = -1; job->error_code = errno; return; } if (link_length < buffer_size) { job->buffer[link_length] = 0; job->result = link_length; return; } else { free(job->buffer); buffer_size *= 2; } } } static value result_readlink(struct job_readlink *job) { LWT_UNIX_CHECK_JOB_ARG(job, job->result < 0, "readlink", job->name); value result = caml_copy_string(job->buffer); free(job->buffer); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_readlink_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, readlink, 0, name); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: lockf | +-----------------------------------------------------------------+ */ struct job_lockf { struct lwt_unix_job job; int fd; int command; long length; int result; int error_code; }; #if defined(F_GETLK) && defined(F_SETLK) && defined(F_SETLKW) static void worker_lockf(struct job_lockf *job) { struct flock l; l.l_whence = 1; if (job->length < 0) { l.l_start = job->length; l.l_len = -job->length; } else { l.l_start = 0L; l.l_len = job->length; } switch (job->command) { case 0: /* F_ULOCK */ l.l_type = F_UNLCK; job->result = fcntl(job->fd, F_SETLK, &l); job->error_code = errno; break; case 1: /* F_LOCK */ l.l_type = F_WRLCK; job->result = fcntl(job->fd, F_SETLKW, &l); job->error_code = errno; break; case 2: /* F_TLOCK */ l.l_type = F_WRLCK; job->result = fcntl(job->fd, F_SETLK, &l); job->error_code = errno; break; case 3: /* F_TEST */ l.l_type = F_WRLCK; job->result = fcntl(job->fd, F_GETLK, &l); if (job->result != -1) { if (l.l_type == F_UNLCK) { job->result = 0; } else { job->result = -1; job->error_code = EACCES; } } break; case 4: /* F_RLOCK */ l.l_type = F_RDLCK; job->result = fcntl(job->fd, F_SETLKW, &l); job->error_code = errno; break; case 5: /* F_TRLOCK */ l.l_type = F_RDLCK; job->result = fcntl(job->fd, F_SETLK, &l); job->error_code = errno; break; default: job->result = -1; job->error_code = EINVAL; } } #else static int lock_command_table[] = { F_ULOCK, F_LOCK, F_TLOCK, F_TEST, F_LOCK, F_TLOCK }; static void worker_lockf(struct job_lockf *job) { job->result = lockf(job->fd, lock_command_table[job->command], job->length); job->error_code = errno; } #endif static value result_lockf(struct job_lockf *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "lockf"); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_lockf_job(value val_fd, value val_command, value val_length) { LWT_UNIX_INIT_JOB(job, lockf, 0); job->fd = Int_val(val_fd); job->command = Int_val(val_command); job->length = Long_val(val_length); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: getlogin | +-----------------------------------------------------------------+ */ #if !defined(__ANDROID__) struct job_getlogin { struct lwt_unix_job job; char buffer[1024]; int result; }; static void worker_getlogin(struct job_getlogin *job) { job->result = getlogin_r(job->buffer, 1024); } static value result_getlogin(struct job_getlogin *job) { int result = job->result; if (result) { lwt_unix_free_job(&job->job); unix_error(result, "getlogin", Nothing); } else { value v = caml_copy_string(job->buffer); lwt_unix_free_job(&job->job); return v; } } CAMLprim value lwt_unix_getlogin_job(value Unit) { LWT_UNIX_INIT_JOB(job, getlogin, 0); return lwt_unix_alloc_job(&job->job); } #else LWT_NOT_AVAILABLE1(unix_getlogin_job) #endif /* +-----------------------------------------------------------------+ | JOBs: get{pw,gr}{nam,uid} | +-----------------------------------------------------------------+ */ #if !defined(__ANDROID__) 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); #if !defined(__BEOS__) gecos = copy_string(entry->pw_gecos); #else gecos = copy_string(""); #endif dir = copy_string(entry->pw_dir); shell = copy_string(entry->pw_shell); res = alloc_small(7, 0); Field(res, 0) = name; Field(res, 1) = passwd; Field(res, 2) = Val_int(entry->pw_uid); Field(res, 3) = Val_int(entry->pw_gid); Field(res, 4) = gecos; Field(res, 5) = dir; Field(res, 6) = shell; End_roots(); return res; } static value alloc_group_entry(struct group *entry) { value res; value name = Val_unit, pass = Val_unit, mem = Val_unit; Begin_roots3 (name, pass, mem); name = copy_string(entry->gr_name); pass = copy_string(entry->gr_passwd); mem = copy_string_array((const char**)entry->gr_mem); res = alloc_small(4, 0); Field(res, 0) = name; Field(res, 1) = pass; Field(res, 2) = Val_int(entry->gr_gid); Field(res, 3) = mem; End_roots(); return res; } #define JOB_GET_ENTRY(INIT, FUNC, CONF, TYPE, ARG, ARG_DECL, FAIL_ARG) \ struct job_##FUNC { \ struct lwt_unix_job job; \ struct TYPE entry; \ struct TYPE *ptr; \ char *buffer; \ int result; \ ARG_DECL; \ }; \ \ static void worker_##FUNC(struct job_##FUNC *job) \ { \ size_t buffer_size = sysconf(_SC_##CONF##_R_SIZE_MAX); \ if (buffer_size == (size_t) -1) buffer_size = 16384; \ job->buffer = (char*)lwt_unix_malloc(buffer_size); \ job->result = FUNC##_r(job->ARG, &job->entry, job->buffer, buffer_size, &job->ptr); \ } \ \ static value result_##FUNC(struct job_##FUNC *job) \ { \ int result = job->result; \ if (result) { \ value arg = FAIL_ARG; \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ unix_error(result, #FUNC, arg); \ } else if (job->ptr == NULL) { \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ caml_raise_not_found(); \ } else { \ value entry = alloc_##TYPE##_entry(&job->entry); \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ return entry; \ } \ } \ \ CAMLprim value lwt_unix_##FUNC##_job(value ARG) \ { \ INIT; \ return lwt_unix_alloc_job(&job->job); \ } JOB_GET_ENTRY(LWT_UNIX_INIT_JOB_STRING(job, getpwnam, 0, name), getpwnam, GETPW, passwd, name, char *name; char data[], caml_copy_string(job->name)) JOB_GET_ENTRY(LWT_UNIX_INIT_JOB_STRING(job, getgrnam, 0, name), getgrnam, GETGR, group, name, char *name; char data[], caml_copy_string(job->name)) JOB_GET_ENTRY(LWT_UNIX_INIT_JOB(job, getpwuid, 0); job->uid = Int_val(uid), getpwuid, GETPW, passwd, uid, int uid, Nothing) JOB_GET_ENTRY(LWT_UNIX_INIT_JOB(job, getgrgid, 0); job->gid = Int_val(gid), getgrgid, GETGR, group, gid, int gid, Nothing) #else LWT_NOT_AVAILABLE1(unix_getpwnam_job) LWT_NOT_AVAILABLE1(unix_getgrnam_job) LWT_NOT_AVAILABLE1(unix_getpwuid_job) LWT_NOT_AVAILABLE1(unix_getgrgid_job) #endif /* Helper functions for not re-entrant functions */ /* keep test in sync with discover.ml */ #if !defined(HAS_GETHOSTBYADDR_R) || (HAS_GETHOSTBYADDR_R != 7 && HAS_GETHOSTBYADDR_R != 8) #define NON_R_GETHOSTBYADDR 1 #endif /* keep test in sync with discover.ml */ #if !defined(HAS_GETHOSTBYNAME_R) || (HAS_GETHOSTBYNAME_R != 5 && HAS_GETHOSTBYNAME_R != 6) #define NON_R_GETHOSTBYNAME 1 #endif #if defined(NON_R_GETHOSTBYADDR) || defined(NON_R_GETHOSTBYNAME) static char ** c_copy_addr_array(char ** src, int addr_len) { if ( src == NULL ){ return NULL; } char ** p = src; size_t i = 0 ; while ( *p ){ i++; p++; } const size_t ar_len = i; p = malloc((ar_len+1) * sizeof(char*)); if ( p == NULL ){ return NULL; } for ( i = 0 ; i < ar_len ; ++i ){ p[i] = malloc(addr_len); if ( p[i] == NULL ){ size_t j; for ( j = 0 ; j < i ; j++ ){ free(p[j]); } free(p); return NULL; } memcpy(p[i],src[i],addr_len); } p[ar_len] = NULL; return p; } #endif #if !defined(HAVE_NETDB_REENTRANT) || defined(NON_R_GETHOSTBYADDR) || defined(NON_R_GETHOSTBYNAME) static char ** c_copy_string_array(char **src) { char ** p = src; size_t i = 0 ; size_t len ; if ( src == NULL ){ return NULL; } while ( *p ){ i++; p++; } len = i; p = malloc((len+1) * sizeof(char *)); if ( p == NULL ){ return NULL; } for ( i = 0 ; i < len ; ++i ){ p[i] = strdup(src[i]); if ( p[i] == NULL ){ size_t j; for ( j = 0 ; j < i ; j++ ){ free(p[j]); } free(p); return NULL; } } p[len] = NULL; return p; } static void c_free_string_array(char ** src) { if ( src ){ char ** p = src; while (*p){ free(*p); ++p; } free(src); } } static inline char * s_strdup (const char *s){ return (strdup( s == NULL ? "" : s )); } #endif /* +-----------------------------------------------------------------+ | JOB: gethostname | +-----------------------------------------------------------------+ */ struct job_gethostname { struct lwt_unix_job job; char *buffer; int result; int error_code; }; static void worker_gethostname(struct job_gethostname *job) { int buffer_size = 64; int err; for (;;) { job->buffer = lwt_unix_malloc(buffer_size + 1); err = gethostname(job->buffer, buffer_size); if (err == -1 && errno == ENAMETOOLONG) { free(job->buffer); buffer_size *= 2; } else if (err == -1) { free(job->buffer); job->result = -1; job->error_code = errno; return; } else { job->buffer[buffer_size] = 0; job->result = 0; return; } } } static value result_gethostname(struct job_gethostname *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "gethostname"); value result = caml_copy_string(job->buffer); free(job->buffer); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_gethostname_job(value Unit) { LWT_UNIX_INIT_JOB(job, gethostname, 0); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: gethostbyname | +-----------------------------------------------------------------+ */ #define NETDB_BUFFER_SIZE 10000 struct job_gethostbyname { struct lwt_unix_job job; struct hostent entry; struct hostent *ptr; #ifndef NON_R_GETHOSTBYNAME char buffer[NETDB_BUFFER_SIZE]; #endif char *name; char data[]; }; CAMLexport value alloc_inet_addr (struct in_addr * inaddr); #define GET_INET_ADDR(v) (*((struct in_addr *) (v))) CAMLexport value alloc_inet6_addr (struct in6_addr * inaddr); #define GET_INET6_ADDR(v) (*((struct in6_addr *) (v))) static value alloc_one_addr(char const *a) { struct in_addr addr; memmove (&addr, a, 4); return alloc_inet_addr(&addr); } static value alloc_one_addr6(char const *a) { struct in6_addr addr; memmove(&addr, a, 16); return alloc_inet6_addr(&addr); } static value alloc_host_entry(struct hostent *entry) { value res; value name = Val_unit, aliases = Val_unit; value addr_list = Val_unit, adr = Val_unit; Begin_roots4 (name, aliases, addr_list, adr); name = copy_string((char *)(entry->h_name)); /* PR#4043: protect against buggy implementations of gethostbynamee() that return a NULL pointer in h_aliases */ if (entry->h_aliases) aliases = copy_string_array((const char**)entry->h_aliases); else aliases = Atom(0); if (entry->h_length == 16) addr_list = alloc_array(alloc_one_addr6, (const char**)entry->h_addr_list); else addr_list = alloc_array(alloc_one_addr, (const char**)entry->h_addr_list); res = alloc_small(4, 0); Field(res, 0) = name; Field(res, 1) = aliases; switch (entry->h_addrtype) { case PF_UNIX: Field(res, 2) = Val_int(0); break; case PF_INET: Field(res, 2) = Val_int(1); break; default: /*PF_INET6 */ Field(res, 2) = Val_int(2); break; } Field(res, 3) = addr_list; End_roots(); return res; } #if defined(NON_R_GETHOSTBYADDR) || defined(NON_R_GETHOSTBYNAME) static struct hostent * hostent_dup(struct hostent *orig) { if ( orig == NULL ){ return NULL; } struct hostent *h = malloc(sizeof *h); if ( h == NULL ){ return NULL; } h->h_name = s_strdup(orig->h_name); if ( !h->h_name ){ goto nomem1; } if ( !orig->h_aliases ){ h->h_aliases = NULL; } else { h->h_aliases = c_copy_string_array(orig->h_aliases); if ( !h->h_aliases){ goto nomem2; } } if ( !orig->h_addr_list ){ h->h_addr_list = NULL; } else { h->h_addr_list = c_copy_addr_array(orig->h_addr_list,orig->h_length); if ( !h->h_addr_list ){ goto nomem3; } } h->h_addrtype = orig->h_addrtype; h->h_length = orig->h_length; return h; nomem3: c_free_string_array(h->h_aliases); nomem2: free(h->h_name); nomem1: free(h); return NULL; } static void hostent_free(struct hostent *h) { if ( h ){ c_free_string_array(h->h_addr_list); c_free_string_array(h->h_aliases); free(h->h_name); free(h); } } #endif static void worker_gethostbyname(struct job_gethostbyname *job) { #if HAS_GETHOSTBYNAME_R == 5 int h_errno; job->ptr = gethostbyname_r(job->name, &job->entry, job->buffer, NETDB_BUFFER_SIZE, &h_errno); #elif HAS_GETHOSTBYNAME_R == 6 int h_errno; if (gethostbyname_r(job->name, &job->entry, job->buffer, NETDB_BUFFER_SIZE, &(job->ptr), &h_errno) != 0) job->ptr = NULL; #else job->ptr = gethostbyname(job->name); if (job->ptr) { job->ptr= hostent_dup(job->ptr); if ( job->ptr ){ job->entry = *job->ptr; } } #endif } static value result_gethostbyname(struct job_gethostbyname *job) { if (job->ptr == NULL) { lwt_unix_free_job(&job->job); caml_raise_not_found(); } else { value entry = alloc_host_entry(&job->entry); #ifdef NON_R_GETHOSTBYNAME hostent_free(job->ptr); #endif lwt_unix_free_job(&job->job); return entry; } } CAMLprim value lwt_unix_gethostbyname_job(value name) { LWT_UNIX_INIT_JOB_STRING(job, gethostbyname, 0, name); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: gethostbyaddr | +-----------------------------------------------------------------+ */ struct job_gethostbyaddr { struct lwt_unix_job job; struct in_addr addr; struct hostent entry; struct hostent *ptr; #ifndef NON_R_GETHOSTBYADDR char buffer[NETDB_BUFFER_SIZE]; #endif }; static void worker_gethostbyaddr(struct job_gethostbyaddr *job) { #if HAS_GETHOSTBYADDR_R == 7 int h_errno; job->ptr = gethostbyaddr_r(&job->addr, 4, AF_INET, &job->entry, job->buffer, NETDB_BUFFER_SIZE, &h_errno); #elif HAS_GETHOSTBYADDR_R == 8 int h_errno; 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 = gethostbyaddr(&job->addr, 4, AF_INET); if (job->ptr) { job->ptr = hostent_dup(job->ptr); if ( job->ptr ){ job->entry = *job->ptr; } } #endif } static value result_gethostbyaddr(struct job_gethostbyaddr *job) { if (job->ptr == NULL) { lwt_unix_free_job(&job->job); caml_raise_not_found(); } else { value entry = alloc_host_entry(&job->entry); #ifdef NON_R_GETHOSTBYADDR hostent_free(job->ptr); #endif lwt_unix_free_job(&job->job); return entry; } } CAMLprim value lwt_unix_gethostbyaddr_job(value val_addr) { LWT_UNIX_INIT_JOB(job, gethostbyaddr, 0); job->addr = GET_INET_ADDR(val_addr); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOBs: getprotoby{name,number}, getservby{name,port} | +-----------------------------------------------------------------+ */ static value alloc_protoent(struct protoent *entry) { value res; value name = Val_unit, aliases = Val_unit; Begin_roots2 (name, aliases); name = copy_string(entry->p_name); aliases = copy_string_array((const char**)entry->p_aliases); res = alloc_small(3, 0); Field(res,0) = name; Field(res,1) = aliases; Field(res,2) = Val_int(entry->p_proto); End_roots(); return res; } static value alloc_servent(struct servent *entry) { value res; value name = Val_unit, aliases = Val_unit, proto = Val_unit; Begin_roots3 (name, aliases, proto); name = copy_string(entry->s_name); aliases = copy_string_array((const char**)entry->s_aliases); proto = copy_string(entry->s_proto); res = alloc_small(4, 0); Field(res,0) = name; Field(res,1) = aliases; Field(res,2) = Val_int(ntohs(entry->s_port)); Field(res,3) = proto; End_roots(); return res; } #if defined(HAVE_NETDB_REENTRANT) #define JOB_GET_ENTRY2(INIT, FUNC, TYPE, ARGS_VAL, ARGS_DECL, ARGS_CALL) \ struct job_##FUNC { \ struct lwt_unix_job job; \ struct TYPE entry; \ struct TYPE *ptr; \ char *buffer; \ ARGS_DECL; \ }; \ \ static void worker_##FUNC(struct job_##FUNC *job) \ { \ size_t size = 1024; \ for (;;) { \ job->buffer = (char*)lwt_unix_malloc(size); \ \ int result = FUNC##_r(ARGS_CALL, &job->entry, job->buffer, size, &job->ptr); \ \ switch (result) { \ case 0: \ return; \ case ERANGE: \ free(job->buffer); \ size += 1024; \ break; \ case ENOENT: \ default: \ job->ptr = NULL; \ return; \ } \ } \ } \ \ static value result_##FUNC(struct job_##FUNC *job) \ { \ if (job->ptr == NULL) { \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ caml_raise_not_found(); \ } else { \ value res = alloc_##TYPE(&job->entry); \ free(job->buffer); \ lwt_unix_free_job(&job->job); \ return res; \ } \ } \ \ CAMLprim value lwt_unix_##FUNC##_job(ARGS_VAL) \ { \ INIT; \ return lwt_unix_alloc_job(&(job->job)); \ } #else /* defined(HAVE_NETDB_REENTRANT) */ static struct servent * servent_dup(const struct servent * serv) { struct servent * s; if (!serv){ return NULL; } s = malloc(sizeof *s); if ( s == NULL ){ goto nomem1; } s->s_name = s_strdup(serv->s_name); if ( s->s_name == NULL ){ goto nomem2; } s->s_proto = s_strdup(serv->s_proto); if ( s->s_proto == NULL ){ goto nomem3; } s->s_aliases = c_copy_string_array(serv->s_aliases); if ( s->s_aliases == NULL && serv->s_aliases != NULL ){ goto nomem4; } s->s_port = serv->s_port; return s; nomem4: free(s->s_proto); nomem3: free(s->s_name); nomem2: free(s); nomem1: return NULL; } static void servent_free(struct servent * s) { if ( ! s ){ return; } free(s->s_proto); free(s->s_name); c_free_string_array(s->s_aliases); free(s); } static struct protoent * protoent_dup(const struct protoent * proto) { if (!proto){ return NULL; } struct protoent * p = malloc(sizeof *p); if ( p == NULL ){ return NULL; } p->p_name = s_strdup(proto->p_name); if ( p->p_name == NULL ){ goto nomem1; } p->p_aliases = c_copy_string_array( proto->p_aliases ); if ( p->p_aliases == NULL && proto->p_aliases != NULL ){ goto nomem2; } p->p_proto = proto->p_proto; return p; nomem2: free(p->p_name); nomem1: free(p); return NULL; } static void protoent_free(struct protoent * p) { if ( p ){ free(p->p_name); c_free_string_array(p->p_aliases); free(p); } } #define JOB_GET_ENTRY2(INIT, FUNC, TYPE, ARGS_VAL, ARGS_DECL, ARGS_CALL) \ struct job_##FUNC { \ struct lwt_unix_job job; \ struct TYPE *entry; \ ARGS_DECL; \ }; \ \ static void worker_##FUNC(struct job_##FUNC *job) \ { \ job->entry = FUNC(ARGS_CALL); \ if ( job->entry ){ \ job->entry = TYPE ## _dup ( job->entry ); \ if (! job->entry ){ \ } \ } \ } \ \ static value result_##FUNC(struct job_##FUNC *job) \ { \ if (job->entry == NULL) { \ lwt_unix_free_job(&job->job); \ caml_raise_not_found(); \ } else { \ value res = alloc_##TYPE(job->entry); \ TYPE ## _free ( job->entry ); \ lwt_unix_free_job(&job->job); \ return res; \ } \ } \ \ CAMLprim value lwt_unix_##FUNC##_job(ARGS_VAL) \ { \ INIT; \ return lwt_unix_alloc_job(&(job->job)); \ } #endif /* defined(HAVE_NETDB_REENTRANT) */ JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB_STRING(job, getprotobyname, 0, name), getprotobyname, protoent, value name, char *name; char data[], job->name) JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB(job, getprotobynumber, 0); job->num = Int_val(num), getprotobynumber, protoent, value num, int num, job->num) JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB_STRING2(job, getservbyname, 0, name, proto), getservbyname, servent, ARGS(value name, value proto), char *name; char *proto; char data[], ARGS(job->name, job->proto)) JOB_GET_ENTRY2(LWT_UNIX_INIT_JOB_STRING(job, getservbyport, 0, proto); job->port = htons(Int_val(port)), getservbyport, servent, ARGS(value port, value proto), int port; char *proto; char data[], ARGS(job->port, job->proto)) /* +-----------------------------------------------------------------+ | JOB: getaddrinfo | +-----------------------------------------------------------------+ */ struct job_getaddrinfo { struct lwt_unix_job job; char *node; char *service; struct addrinfo hints; struct addrinfo *info; int result; char data[]; }; value cst_to_constr(int n, int *tbl, int size, int deflt) { int i; for (i = 0; i < size; i++) if (n == tbl[i]) return Val_int(i); return Val_int(deflt); } static value convert_addrinfo(struct addrinfo * a) { CAMLparam0(); CAMLlocal3(vres,vaddr,vcanonname); union sock_addr_union sa; socklen_t len; len = a->ai_addrlen; if (len > sizeof(sa)) len = sizeof(sa); memcpy(&sa.s_gen, a->ai_addr, len); vaddr = alloc_sockaddr(&sa, len, -1); vcanonname = copy_string(a->ai_canonname == NULL ? "" : a->ai_canonname); vres = alloc_small(5, 0); Field(vres, 0) = cst_to_constr(a->ai_family, socket_domain_table, 3, 0); Field(vres, 1) = cst_to_constr(a->ai_socktype, socket_type_table, 4, 0); Field(vres, 2) = Val_int(a->ai_protocol); Field(vres, 3) = vaddr; Field(vres, 4) = vcanonname; CAMLreturn(vres); } static void worker_getaddrinfo(struct job_getaddrinfo *job) { job->result = getaddrinfo(job->node[0]?job->node:NULL, job->service[0]?job->service:NULL, &job->hints, &job->info); } static value result_getaddrinfo(struct job_getaddrinfo *job) { CAMLparam0(); CAMLlocal3(vres, e, v); vres = Val_int(0); if (job->result == 0) { struct addrinfo *r; for (r = job->info; r; r = r->ai_next) { e = convert_addrinfo(r); v = caml_alloc_small(2, 0); Field(v, 0) = e; Field(v, 1) = vres; vres = v; } } if (job->info != NULL) freeaddrinfo(job->info); lwt_unix_free_job(&job->job); CAMLreturn(vres); } CAMLprim value lwt_unix_getaddrinfo_job(value node, value service, value hints) { LWT_UNIX_INIT_JOB_STRING2(job, getaddrinfo, 0, node, service); job->info = NULL; memset(&job->hints, 0, sizeof(struct addrinfo)); job->hints.ai_family = PF_UNSPEC; for (/*nothing*/; Is_block(hints); hints = Field(hints, 1)) { value v = Field(hints, 0); if (Is_block(v)) switch (Tag_val(v)) { case 0: /* AI_FAMILY of socket_domain */ job->hints.ai_family = socket_domain_table[Int_val(Field(v, 0))]; break; case 1: /* AI_SOCKTYPE of socket_type */ job->hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))]; break; case 2: /* AI_PROTOCOL of int */ job->hints.ai_protocol = Int_val(Field(v, 0)); break; } else switch (Int_val(v)) { case 0: /* AI_NUMERICHOST */ job->hints.ai_flags |= AI_NUMERICHOST; break; case 1: /* AI_CANONNAME */ job->hints.ai_flags |= AI_CANONNAME; break; case 2: /* AI_PASSIVE */ job->hints.ai_flags |= AI_PASSIVE; break; } } return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: getnameinfo | +-----------------------------------------------------------------+ */ struct job_getnameinfo { struct lwt_unix_job job; union sock_addr_union addr; socklen_t addr_len; int opts; char host[4096]; char serv[1024]; int result; }; static int getnameinfo_flag_table[] = { NI_NOFQDN, NI_NUMERICHOST, NI_NAMEREQD, NI_NUMERICSERV, NI_DGRAM }; static void worker_getnameinfo(struct job_getnameinfo *job) { job->result = getnameinfo((const struct sockaddr *)&job->addr.s_gen, job->addr_len, job->host, sizeof(job->host), job->serv, sizeof(job->serv), job->opts); } static value result_getnameinfo(struct job_getnameinfo *job) { CAMLparam0(); CAMLlocal3(vres, vhost, vserv); if (job->result) { lwt_unix_free_job(&job->job); caml_raise_not_found(); } else { vhost = caml_copy_string(job->host); vserv = caml_copy_string(job->serv); vres = caml_alloc_small(2, 0); Field(vres, 0) = vhost; Field(vres, 1) = vserv; CAMLreturn(vres); } } CAMLprim value lwt_unix_getnameinfo_job(value sockaddr, value opts) { LWT_UNIX_INIT_JOB(job, getnameinfo, 0); get_sockaddr(sockaddr, &job->addr, &job->addr_len); job->opts = convert_flag_list(opts, getnameinfo_flag_table); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | Termios conversion | +-----------------------------------------------------------------+ */ /* TODO: make it reentrant. */ enum { Bool, Enum, Speed, Char, End }; enum { Input, Output }; enum { Iflags, Oflags, Cflags, Lflags }; /* Number of fields in the terminal_io record field. Cf. unix.mli */ #define NFIELDS 38 /* Structure of the terminal_io record. Cf. unix.mli */ static long terminal_io_descr[] = { /* Input modes */ Bool, Iflags, IGNBRK, Bool, Iflags, BRKINT, Bool, Iflags, IGNPAR, Bool, Iflags, PARMRK, Bool, Iflags, INPCK, Bool, Iflags, ISTRIP, Bool, Iflags, INLCR, Bool, Iflags, IGNCR, Bool, Iflags, ICRNL, Bool, Iflags, IXON, Bool, Iflags, IXOFF, /* Output modes */ Bool, Oflags, OPOST, /* Control modes */ Speed, Output, Speed, Input, Enum, Cflags, 5, 4, CSIZE, CS5, CS6, CS7, CS8, Enum, Cflags, 1, 2, CSTOPB, 0, CSTOPB, Bool, Cflags, CREAD, Bool, Cflags, PARENB, Bool, Cflags, PARODD, Bool, Cflags, HUPCL, Bool, Cflags, CLOCAL, /* Local modes */ Bool, Lflags, ISIG, Bool, Lflags, ICANON, Bool, Lflags, NOFLSH, Bool, Lflags, ECHO, Bool, Lflags, ECHOE, Bool, Lflags, ECHOK, Bool, Lflags, ECHONL, /* Control characters */ Char, VINTR, Char, VQUIT, Char, VERASE, Char, VKILL, Char, VEOF, Char, VEOL, Char, VMIN, Char, VTIME, Char, VSTART, Char, VSTOP, End }; static struct { speed_t speed; int baud; } speedtable[] = { {B50, 50}, {B75, 75}, {B110, 110}, {B134, 134}, {B150, 150}, {B300, 300}, {B600, 600}, {B1200, 1200}, {B1800, 1800}, {B2400, 2400}, {B4800, 4800}, {B9600, 9600}, {B19200, 19200}, {B38400, 38400}, #ifdef B57600 {B57600, 57600}, #endif #ifdef B115200 {B115200, 115200}, #endif #ifdef B230400 {B230400, 230400}, #endif {B0, 0} }; #define NSPEEDS (sizeof(speedtable) / sizeof(speedtable[0])) static tcflag_t* choose_field(struct termios *terminal_status, long field) { switch (field) { case Iflags: return &terminal_status->c_iflag; case Oflags: return &terminal_status->c_oflag; case Cflags: return &terminal_status->c_cflag; case Lflags: return &terminal_status->c_lflag; default: return 0; } } static void encode_terminal_status(struct termios* terminal_status, value *dst) { long * pc; int i; for(pc = terminal_io_descr; *pc != End; dst++) { switch(*pc++) { case Bool: { tcflag_t * src = choose_field(terminal_status, *pc++); tcflag_t msk = *pc++; *dst = Val_bool(*src & msk); break; } case Enum: { tcflag_t * src = choose_field(terminal_status, *pc++); int ofs = *pc++; int num = *pc++; tcflag_t msk = *pc++; for (i = 0; i < num; i++) { if ((*src & msk) == pc[i]) { *dst = Val_int(i + ofs); break; } } pc += num; break; } case Speed: { int which = *pc++; speed_t speed = 0; *dst = Val_int(9600); /* in case no speed in speedtable matches */ switch (which) { case Output: speed = cfgetospeed(terminal_status); break; case Input: speed = cfgetispeed(terminal_status); break; } for (i = 0; i < NSPEEDS; i++) { if (speed == speedtable[i].speed) { *dst = Val_int(speedtable[i].baud); break; } } break; } case Char: { int which = *pc++; *dst = Val_int(terminal_status->c_cc[which]); break; } } } } static void decode_terminal_status(struct termios* terminal_status, value* src) { long * pc; int i; for (pc = terminal_io_descr; *pc != End; src++) { switch(*pc++) { case Bool: { tcflag_t * dst = choose_field(terminal_status, *pc++); tcflag_t msk = *pc++; if (Bool_val(*src)) *dst |= msk; else *dst &= ~msk; break; } case Enum: { tcflag_t * dst = choose_field(terminal_status, *pc++); int ofs = *pc++; int num = *pc++; tcflag_t msk = *pc++; i = Int_val(*src) - ofs; if (i >= 0 && i < num) { *dst = (*dst & ~msk) | pc[i]; } else { unix_error(EINVAL, "tcsetattr", Nothing); } pc += num; break; } case Speed: { int which = *pc++; int baud = Int_val(*src); int res = 0; for (i = 0; i < NSPEEDS; i++) { if (baud == speedtable[i].baud) { switch (which) { case Output: res = cfsetospeed(terminal_status, speedtable[i].speed); break; case Input: res = cfsetispeed(terminal_status, speedtable[i].speed); break; } if (res == -1) uerror("tcsetattr", Nothing); goto ok; } } unix_error(EINVAL, "tcsetattr", Nothing); ok: break; } case Char: { int which = *pc++; terminal_status->c_cc[which] = Int_val(*src); break; } } } } /* +-----------------------------------------------------------------+ | JOB: tcgetattr | +-----------------------------------------------------------------+ */ struct job_tcgetattr { struct lwt_unix_job job; int fd; struct termios termios; int result; int error_code; }; static void worker_tcgetattr(struct job_tcgetattr *job) { job->result = tcgetattr(job->fd, &job->termios); job->error_code = errno; } static value result_tcgetattr(struct job_tcgetattr *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "tcgetattr"); value res = caml_alloc_tuple(NFIELDS); encode_terminal_status(&job->termios, &Field(res, 0)); lwt_unix_free_job(&job->job); return res; } CAMLprim value lwt_unix_tcgetattr_job(value fd) { LWT_UNIX_INIT_JOB(job, tcgetattr, 0); job->fd = Int_val(fd); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | JOB: tcsetattr | +-----------------------------------------------------------------+ */ struct job_tcsetattr { struct lwt_unix_job job; int fd; int when; /* This array contains only non-allocated values. */ value termios[NFIELDS]; int result; int error_code; }; static int when_flag_table[] = { TCSANOW, TCSADRAIN, TCSAFLUSH }; static void worker_tcsetattr(struct job_tcsetattr *job) { struct termios termios; int result = tcgetattr(job->fd, &termios); if (result < 0) { job->result = result; job->error_code = errno; } else { decode_terminal_status(&termios, &(job->termios[0])); job->result = tcsetattr(job->fd, job->when, &termios); job->error_code = errno; } } static value result_tcsetattr(struct job_tcsetattr *job) { LWT_UNIX_CHECK_JOB(job, job->result < 0, "tcsetattr"); lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_tcsetattr_job(value fd, value when, value termios) { LWT_UNIX_INIT_JOB(job, tcsetattr, 0); job->fd = Int_val(fd); job->when = when_flag_table[Int_val(when)]; memcpy(&job->termios, &Field(termios, 0), NFIELDS * sizeof(value)); return lwt_unix_alloc_job(&job->job); } /* +-----------------------------------------------------------------+ | Unavailable primitives | +-----------------------------------------------------------------+ */ LWT_NOT_AVAILABLE1(unix_is_socket) LWT_NOT_AVAILABLE1(unix_socketpair_stub) LWT_NOT_AVAILABLE1(unix_system_job) LWT_NOT_AVAILABLE4(process_create_process) LWT_NOT_AVAILABLE1(process_wait_job) LWT_NOT_AVAILABLE2(process_terminate_process) lwt-2.5.2/src/unix/lwt_unix_windows.c000066400000000000000000000403131270742521300176730ustar00rootroot00000000000000/* Lightweight thread library for OCaml * 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(value Unit) { SYSTEM_INFO si; GetSystemInfo(&si); return Val_long(si.dwPageSize); } /* +-----------------------------------------------------------------+ | JOB: read | +-----------------------------------------------------------------+ */ struct job_read { struct lwt_unix_job job; union { HANDLE handle; SOCKET socket; } fd; int kind; DWORD length; DWORD result; DWORD error_code; value string; DWORD offset; char buffer[]; }; static void worker_read(struct job_read *job) { if (job->kind == KIND_SOCKET) { int ret; ret = recv(job->fd.socket, job->buffer, job->length, 0); if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); job->result = ret; } else { if (!ReadFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) job->error_code = GetLastError(); } } static value result_read(struct job_read *job) { value result; DWORD error = job->error_code; if (error) { caml_remove_generational_global_root(&job->string); lwt_unix_free_job(&job->job); win32_maperr(error); uerror("read", Nothing); } memcpy(String_val(job->string) + job->offset, job->buffer, job->result); result = Val_long(job->result); caml_remove_generational_global_root(&job->string); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_read_job(value val_fd, value val_string, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, read, length); job->kind = fd->kind; if (fd->kind == KIND_HANDLE) job->fd.handle = fd->fd.handle; else job->fd.socket = fd->fd.socket; job->length = length; job->error_code = 0; job->string = val_string; job->offset = Long_val(val_offset); caml_register_generational_global_root(&(job->string)); return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: bytes_read | +-----------------------------------------------------------------+ */ struct job_bytes_read { struct lwt_unix_job job; union { HANDLE handle; SOCKET socket; } fd; int kind; char *buffer; DWORD length; DWORD result; DWORD error_code; }; static void worker_bytes_read(struct job_bytes_read *job) { if (job->kind == KIND_SOCKET) { int ret; ret = recv(job->fd.socket, job->buffer, job->length, 0); if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); job->result = ret; } else { if (!ReadFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) job->error_code = GetLastError(); } } static value result_bytes_read(struct job_bytes_read *job) { value result; DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("bytes_read", Nothing); } result = Val_long(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buffer, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); LWT_UNIX_INIT_JOB(job, bytes_read, 0); job->kind = fd->kind; if (fd->kind == KIND_HANDLE) job->fd.handle = fd->fd.handle; else job->fd.socket = fd->fd.socket; job->buffer = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); job->length = Long_val(val_length); job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: write | +-----------------------------------------------------------------+ */ struct job_write { struct lwt_unix_job job; union { HANDLE handle; SOCKET socket; } fd; int kind; DWORD length; DWORD result; DWORD error_code; char buffer[]; }; static void worker_write(struct job_write *job) { if (job->kind == KIND_SOCKET) { int ret; ret = send(job->fd.socket, job->buffer, job->length, 0); if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); job->result = ret; } else { if (!WriteFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) job->error_code = GetLastError(); } } static value result_write(struct job_write *job) { value result; DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("write", Nothing); } result = Val_long(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); long length = Long_val(val_length); LWT_UNIX_INIT_JOB(job, write, length); job->kind = fd->kind; if (fd->kind == KIND_HANDLE) job->fd.handle = fd->fd.handle; else job->fd.socket = fd->fd.socket; memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length); job->length = length; job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: bytes_write | +-----------------------------------------------------------------+ */ struct job_bytes_write { struct lwt_unix_job job; union { HANDLE handle; SOCKET socket; } fd; int kind; char *buffer; DWORD length; DWORD result; DWORD error_code; }; static void worker_bytes_write(struct job_bytes_write *job) { if (job->kind == KIND_SOCKET) { int ret; ret = send(job->fd.socket, job->buffer, job->length, 0); if (ret == SOCKET_ERROR) job->error_code = WSAGetLastError(); job->result = ret; } else { if (!WriteFile(job->fd.handle, job->buffer, job->length, &(job->result), NULL)) job->error_code = GetLastError(); } } CAMLprim value result_bytes_write(struct job_bytes_write *job) { value result; DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("bytes_write", Nothing); } result = Val_long(job->result); lwt_unix_free_job(&job->job); return result; } CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); LWT_UNIX_INIT_JOB(job, bytes_write, 0); job->job.worker = (lwt_unix_job_worker)worker_bytes_write; job->kind = fd->kind; if (fd->kind == KIND_HANDLE) job->fd.handle = fd->fd.handle; else job->fd.socket = fd->fd.socket; job->buffer = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset); job->length = Long_val(val_length); job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } /* +-----------------------------------------------------------------+ | JOB: fsync | +-----------------------------------------------------------------+ */ struct job_fsync { struct lwt_unix_job job; HANDLE handle; DWORD error_code; }; static void worker_fsync(struct job_fsync *job) { if (!FlushFileBuffers(job->handle)) job->error_code = GetLastError(); } static value result_fsync(struct job_fsync *job) { DWORD error = job->error_code; if (error) { lwt_unix_free_job(&job->job); win32_maperr(error); uerror("fsync", Nothing); } lwt_unix_free_job(&job->job); return Val_unit; } CAMLprim value lwt_unix_fsync_job(value val_fd) { struct filedescr *fd = (struct filedescr *)Data_custom_val(val_fd); if (fd->kind != KIND_HANDLE) { caml_invalid_argument("Lwt_unix.fsync"); } else { LWT_UNIX_INIT_JOB(job, fsync, 0); job->handle = fd->fd.handle; job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } } /* +-----------------------------------------------------------------+ | JOB: system | +-----------------------------------------------------------------+ */ struct job_system { struct lwt_unix_job job; HANDLE handle; }; static void worker_system(struct job_system *job) { WaitForSingleObject(job->handle, INFINITE); } static value result_system(struct job_system *job) { HANDLE handle = job->handle; DWORD code; DWORD err; lwt_unix_free_job(&job->job); if (!GetExitCodeProcess(handle, &code)) { err = GetLastError(); CloseHandle(handle); win32_maperr(err); uerror("GetExitCodeProcess", Nothing); } CloseHandle(handle); return Val_int(code); } CAMLprim value lwt_unix_system_job(value cmdline) { STARTUPINFO si; PROCESS_INFORMATION pi; ZeroMemory(&si, sizeof(si)); ZeroMemory(&pi, sizeof(pi)); si.cb = sizeof(si); if (!CreateProcess(NULL, String_val(cmdline), NULL, NULL, TRUE, 0, NULL, NULL, &si, &pi)) { win32_maperr(GetLastError()); uerror("CreateProcess", Nothing); } else { LWT_UNIX_INIT_JOB(job, system, 0); CloseHandle(pi.hThread); job->handle = pi.hProcess; return lwt_unix_alloc_job(&(job->job)); } } /* +-----------------------------------------------------------------+ | Unavailable primitives | +-----------------------------------------------------------------+ */ LWT_NOT_AVAILABLE2(unix_mcast_set_loop) LWT_NOT_AVAILABLE2(unix_mcast_set_ttl) LWT_NOT_AVAILABLE4(unix_mcast_modify_membership) LWT_NOT_AVAILABLE1(unix_get_credentials) LWT_NOT_AVAILABLE1(unix_get_cpu) LWT_NOT_AVAILABLE1(unix_get_affinity) LWT_NOT_AVAILABLE2(unix_set_affinity) LWT_NOT_AVAILABLE5(unix_bytes_recv) LWT_NOT_AVAILABLE5(unix_bytes_send) LWT_NOT_AVAILABLE3(unix_bytes_recv_msg) LWT_NOT_AVAILABLE3(unix_bytes_send_msg) LWT_NOT_AVAILABLE6(unix_bytes_sendto) LWT_NOT_AVAILABLE6(unix_bytes_sendto_byte) LWT_NOT_AVAILABLE6(unix_madvise) LWT_NOT_AVAILABLE4(unix_mincore) LWT_NOT_AVAILABLE2(unix_wait_mincore_job) LWT_NOT_AVAILABLE1(unix_guess_blocking_job) LWT_NOT_AVAILABLE1(unix_readable) LWT_NOT_AVAILABLE1(unix_writable) LWT_NOT_AVAILABLE1(unix_open_job) LWT_NOT_AVAILABLE1(unix_stat_job) LWT_NOT_AVAILABLE1(unix_lstat_job) LWT_NOT_AVAILABLE1(unix_fstat_job) LWT_NOT_AVAILABLE1(unix_isatty_job) LWT_NOT_AVAILABLE1(unix_stat_64_job) LWT_NOT_AVAILABLE1(unix_lstat_64_job) LWT_NOT_AVAILABLE1(unix_fstat_64_job) LWT_NOT_AVAILABLE1(unix_opendir_job) LWT_NOT_AVAILABLE1(unix_readdir_job) LWT_NOT_AVAILABLE2(unix_readdir_n_job) LWT_NOT_AVAILABLE1(unix_rewinddir_job) LWT_NOT_AVAILABLE1(unix_closedir_job) LWT_NOT_AVAILABLE1(unix_readlink_job) LWT_NOT_AVAILABLE3(unix_lockf_job) LWT_NOT_AVAILABLE5(unix_recv) LWT_NOT_AVAILABLE5(unix_send) LWT_NOT_AVAILABLE5(unix_recvfrom) LWT_NOT_AVAILABLE6(unix_sendto) LWT_NOT_AVAILABLE6(unix_sendto_byte) LWT_NOT_AVAILABLE3(unix_recv_msg) LWT_NOT_AVAILABLE3(unix_send_msg) LWT_NOT_AVAILABLE1(unix_gethostname_job) LWT_NOT_AVAILABLE1(unix_gethostbyname_job) LWT_NOT_AVAILABLE1(unix_gethostbyaddr_job) LWT_NOT_AVAILABLE1(unix_getprotobyname_job) LWT_NOT_AVAILABLE1(unix_getprotobynumber_job) LWT_NOT_AVAILABLE2(unix_getservbyname_job) LWT_NOT_AVAILABLE2(unix_getservbyport_job) LWT_NOT_AVAILABLE3(unix_getaddrinfo_job) LWT_NOT_AVAILABLE2(unix_getnameinfo_job) LWT_NOT_AVAILABLE1(unix_tcgetattr_job) LWT_NOT_AVAILABLE3(unix_tcsetattr_job) LWT_NOT_AVAILABLE1(unix_getlogin_job) LWT_NOT_AVAILABLE1(unix_getpwnam_job) LWT_NOT_AVAILABLE1(unix_getgrnam_job) LWT_NOT_AVAILABLE1(unix_getpwuid_job) LWT_NOT_AVAILABLE1(unix_getgrgid_job) LWT_NOT_AVAILABLE4(unix_wait4) LWT_NOT_AVAILABLE5(unix_bytes_recvfrom) lwt-2.5.2/syntax/000077500000000000000000000000001270742521300136575ustar00rootroot00000000000000lwt-2.5.2/syntax/lwt-syntax-log.mldylib000066400000000000000000000001371270742521300201470ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 3dd8f18825465abee972eb9d78d04827) Pa_lwt_log # OASIS_STOP lwt-2.5.2/syntax/lwt-syntax-log.mllib000066400000000000000000000001371270742521300176120ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 3dd8f18825465abee972eb9d78d04827) Pa_lwt_log # OASIS_STOP lwt-2.5.2/syntax/lwt-syntax-options.mldylib000066400000000000000000000001431270742521300210560ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: b07bedaca1c4ada7f18a2dee3e3cb6a0) Pa_lwt_options # OASIS_STOP lwt-2.5.2/syntax/lwt-syntax-options.mllib000066400000000000000000000001431270742521300205210ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: b07bedaca1c4ada7f18a2dee3e3cb6a0) Pa_lwt_options # OASIS_STOP lwt-2.5.2/syntax/lwt-syntax.mldylib000066400000000000000000000001331270742521300173640ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 03396b0b9b2d52e4b95f591f2553b12d) Pa_lwt # OASIS_STOP lwt-2.5.2/syntax/lwt-syntax.mllib000066400000000000000000000001331270742521300170270ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 03396b0b9b2d52e4b95f591f2553b12d) Pa_lwt # OASIS_STOP lwt-2.5.2/syntax/pa_lwt.ml000066400000000000000000000215001270742521300154750ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 default_case = function | <:match_case< $a$ | $b$ >> -> default_case a || default_case b | <:match_case< $patt$ -> $_$ >> -> catch_all patt | _ -> false and catch_all = function | <:patt< _ >> | <:patt< $lid:_$ >> -> true | <:patt< $p$ as $_$ >> -> catch_all p | _ -> false in if default_case mc then mc else let _loc = Ast.loc_of_match_case mc in <:match_case< $mc$ | exn -> Lwt.fail exn >> let gen_binding l = let rec aux n = function | [] -> assert false | [(_loc, p, e)] -> <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ >> | (_loc, p, e) :: l -> <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ and $aux (n + 1) l$ >> in aux 0 l let gen_bind l e = let rec aux n = function | [] -> e | (_loc, p, e) :: l -> if !Pa_lwt_options.debug then <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> else <:expr< Lwt.bind $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> in aux 0 l let gen_top_bind _loc l = let rec aux n vars = function | [] -> <:expr< Lwt.return ($tup:Ast.exCom_of_list (List.rev vars)$) >> | (_loc, p, e) :: l -> let id = "__pa_lwt_" ^ string_of_int n in if !Pa_lwt_options.debug then <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> else <:expr< Lwt.bind $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> in aux 0 [] l EXTEND Gram GLOBAL: expr str_item; cases: [ [ "with"; c = match_case -> Some(gen_catch c) | -> None ] ]; finally: [ [ "finally"; f = sequence -> Some f | -> None ] ]; letb_binding: [ [ b1 = SELF; "and"; b2 = SELF -> b1 @ b2 | p = patt; "="; e = expr -> [(_loc, p, e)] ] ]; for_scheme: [ [ "="; s = sequence; "to"; e = sequence -> `CountTo(s, e) | "="; s = sequence; "downto"; e = sequence -> `CountDownTo(s, e) | "in"; e = sequence -> `IterOver(e) ] ]; expr: LEVEL "top" [ [ "try_lwt"; e = expr LEVEL ";"; c = cases; f = finally -> begin match c, f with | None, None -> if !Pa_lwt_options.debug then <:expr< Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) Lwt.fail >> else <:expr< Lwt.catch (fun () -> $e$) Lwt.fail >> | Some c, None -> if !Pa_lwt_options.debug then <:expr< Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (function $c$) >> else <:expr< Lwt.catch (fun () -> $e$) (function $c$) >> | None, Some f -> if !Pa_lwt_options.debug then <:expr< Lwt.backtrace_finalize (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (fun () -> (begin $f$ end)) >> else <:expr< Lwt.finalize (fun () -> $e$) (fun () -> (begin $f$ end)) >> | Some c, Some f -> if !Pa_lwt_options.debug then <:expr< Lwt.backtrace_try_bind (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (fun __pa_lwt_x -> Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) (begin $f$ end) (fun () -> Lwt.return __pa_lwt_x)) (fun __pa_lwt_e -> Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) (begin $f$ end) (fun () -> match __pa_lwt_e with $c$)) >> else <:expr< Lwt.try_bind (fun () -> $e$) (fun __pa_lwt_x -> Lwt.bind (begin $f$ end) (fun () -> Lwt.return __pa_lwt_x)) (fun __pa_lwt_e -> Lwt.bind (begin $f$ end) (fun () -> match __pa_lwt_e with $c$)) >> end | "lwt"; l = letb_binding; "in"; e = expr LEVEL ";" -> <:expr< let $gen_binding l$ in $gen_bind l e$ >> | "for_lwt"; p = patt; scheme = for_scheme; "do"; seq = do_sequence -> (match p, scheme with | <:patt< $lid:id$ >>, `CountTo(s, e) -> <:expr< let __pa_lwt_max = $e$ in let rec __pa_lwt_loop $lid:id$ = if $lid:id$ > __pa_lwt_max then Lwt.return () else Lwt.bind (begin $seq$ end) (fun () -> __pa_lwt_loop ($lid:id$ + 1)) in __pa_lwt_loop $s$ >> | <:patt< $lid:id$ >>, `CountDownTo(s, e) -> <:expr< let __pa_lwt_min = $e$ in let rec __pa_lwt_loop $lid:id$ = if $lid:id$ < __pa_lwt_min then Lwt.return () else Lwt.bind (begin $seq$ end) (fun () -> __pa_lwt_loop ($lid:id$ - 1)) in __pa_lwt_loop $s$ >> | p, `IterOver(e) -> <:expr< Lwt_stream.iter_s (fun $p$ -> $seq$) $e$ >> | _ -> Loc.raise _loc (Failure "syntax error")) | "raise_lwt"; e = SELF -> if !Pa_lwt_options.debug then <:expr< Lwt.fail (try raise $e$ with exn -> exn) >> else <:expr< Lwt.fail $e$ >> | "assert_lwt"; e = SELF -> <:expr< try Lwt.return (assert $e$) with exn -> Lwt.fail exn >> | "while_lwt"; cond = sequence; "do"; body = sequence; "done" -> <:expr< let rec __pa_lwt_loop () = if $cond$ then Lwt.bind (begin $body$ end) __pa_lwt_loop else Lwt.return () in __pa_lwt_loop () >> | "match_lwt"; e = sequence; "with"; c = match_case -> <:expr< Lwt.bind (begin $e$ end) (function $c$) >> ] ]; str_item: [ [ "lwt"; l = letb_binding -> begin match l with | [(_loc, p, e)] -> <:str_item< let $p$ = Lwt_main.run $e$ >> | _ -> <:str_item< let $tup:Ast.paCom_of_list (List.map (fun (_loc, p, e) -> p) l)$ = Lwt_main.run begin let $gen_binding l$ in $gen_top_bind _loc l$ end >> end | "lwt"; l = letb_binding; "in"; e = expr -> <:str_item< let () = Lwt_main.run (let $gen_binding l$ in $gen_bind l e$) >> ] ]; END (* Replace the anonymous bind [x >> y] by [x >>= fun _ -> y] or [x >>= fun () -> y] if the strict sequence flag is used. *) let map_anonymous_bind = object inherit Ast.map as super method expr e = match super#expr e with | <:expr@_loc< $lid:f$ $a$ $b$ >> when f = ">>" -> if !Pa_lwt_options.strict_sequence then <:expr< Lwt.bind $a$ (fun () -> $b$) >> else <:expr< Lwt.bind $a$ (fun _ -> $b$) >> | e -> e end let _ = AstFilters.register_str_item_filter map_anonymous_bind#str_item; AstFilters.register_topphrase_filter map_anonymous_bind#str_item lwt-2.5.2/syntax/pa_lwt.mli000066400000000000000000000067211270742521300156560ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 matching: {[ match_lwt with | -> ... | -> ]} *) lwt-2.5.2/syntax/pa_lwt_log.ml000066400000000000000000000107211270742521300163410ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Pa_lwt_log * Copyright (C) 2009 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) open Camlp4.PreCast let levels = [ "Fatal"; "Error"; "Warning"; "Notice"; "Info"; "Debug"; ] let module_name _loc = let file_name = Loc.file_name _loc in if file_name = "" then "" else String.capitalize (Filename.basename (try Filename.chop_extension file_name with Invalid_argument _ -> file_name)) let rec apply e = function | [] -> e | x :: l -> let _loc = Ast.loc_of_expr x in apply <:expr< $e$ $x$ >> l let split e = let rec aux section acc = function | <:expr@_loc< Lwt_log.$lid:func$ >> -> let len = String.length func in let fmt = len >= 2 && func.[len - 2] = '_' && func.[len - 1] = 'f' and ign = len >= 4 && func.[0] = 'i' && func.[1] = 'g' && func.[2] = 'n' && func.[3] = '_' in let level = match fmt, ign with | false, false -> func | true, false -> String.sub func 0 (len - 2) | false, true -> String.sub func 4 (len - 4) | true, true -> String.sub func 4 (len - 6) in let level = String.capitalize level in if level = "Debug" && (not !Pa_lwt_options.debug) then `Delete ign else if List.mem level levels then `Log(ign, func, section, level, acc) else `Not_a_log | <:expr@loc< $a$ $b$ >> -> begin match b with | <:expr< ~section >> -> aux `Label (b :: acc) a | <:expr@_loc< ~section:$section$ >> -> aux (`Expr section) (<:expr< ~section:__pa_log_section >> :: acc) a | b -> aux section (b :: acc) a end | _ -> `Not_a_log in aux `None [] e let make_loc _loc = <:expr< ($str:Loc.file_name _loc$, $int:string_of_int (Loc.start_line _loc)$, $int:string_of_int (Loc.start_off _loc - Loc.start_bol _loc)$) >> let map = object inherit Ast.map as super method expr e = let _loc = Ast.loc_of_expr e in match split e with | `Delete false -> <:expr< Lwt.return () >> | `Delete true -> <:expr< () >> | `Log(ign, func, `None, level, args) -> let args = List.map super#expr args in <:expr< if Lwt_log.$uid:level$ >= Lwt_log.Section.level Lwt_log.Section.main then $apply <:expr< Lwt_log.$lid:func$ ~location:$make_loc _loc$ >> args$ else $if ign then <:expr< () >> else <:expr< Lwt.return () >>$ >> | `Log(ign, func, `Label, level, args) -> let args = List.map super#expr args in <:expr< if Lwt_log.$uid:level$ >= Lwt_log.Section.level section then $apply <:expr< Lwt_log.$lid:func$ ~location:$make_loc _loc$ >> args$ else $if ign then <:expr< () >> else <:expr< Lwt.return () >>$ >> | `Log(ign, func, `Expr section, level, args) -> let args = List.map super#expr args in <:expr< let __pa_log_section = $section$ in if Lwt_log.$uid:level$ >= Lwt_log.Section.level __pa_log_section then $apply <:expr< Lwt_log.$lid:func$ ~location:$make_loc _loc$ >> args$ else $if ign then <:expr< () >> else <:expr< Lwt.return () >>$ >> | `Not_a_log -> super#expr e end let () = AstFilters.register_str_item_filter map#str_item; AstFilters.register_topphrase_filter map#str_item; lwt-2.5.2/syntax/pa_lwt_log.mli000066400000000000000000000026611270742521300165160ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 fail - it also add the command line flags "-lwt-debug" to keep all debug messages. By default debug messages are removed. *) lwt-2.5.2/syntax/pa_lwt_options.ml000066400000000000000000000022721270742521300172550ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Pa_lwt_options * Copyright (C) 2010 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) let debug = ref false let strict_sequence = ref false let () = Camlp4.Options.add "-lwt-debug" (Arg.Set debug) "debugging mode" let () = Camlp4.Options.add "-lwt-strict-sequence" (Arg.Set strict_sequence) "check left hand side of >> for non unit expressions " lwt-2.5.2/tests/000077500000000000000000000000001270742521300134735ustar00rootroot00000000000000lwt-2.5.2/tests/META000066400000000000000000000005241270742521300141450ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: f4d8512d6f7aadc1a86f911e1462aeef) version = "2.5.2" description = "Lightweight thread library for OCaml" requires = "lwt unix lwt.unix" archive(byte) = "test.cma" archive(byte, plugin) = "test.cma" archive(native) = "test.cmxa" archive(native, plugin) = "test.cmxs" exists_if = "test.cma" # OASIS_STOP lwt-2.5.2/tests/core/000077500000000000000000000000001270742521300144235ustar00rootroot00000000000000lwt-2.5.2/tests/core/main.ml000066400000000000000000000017701270742521300157060ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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_list.suite; ] lwt-2.5.2/tests/core/test_lwt.ml000066400000000000000000000422331270742521300166260ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Test_lwt * Copyright (C) 2010 Jérémie Dimino, Pierre Chambart * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) open Test open Lwt let ( <=> ) v v' = assert ( state v = v') let test_exn f v e = assert (try f v; false with exn -> exn = e) let f x = return ("test"^x) let g x = ("test"^x) exception Exn let key : int key = new_key () let with_async_exception_hook hook f = let save = !Lwt.async_exception_hook in Lwt.async_exception_hook := hook; try let x = f () in Lwt.async_exception_hook := save; x with exn -> Lwt.async_exception_hook := save; raise exn let suite = suite "lwt" [ test "0" (fun () -> return "test" <=> Return "test"; fail Exn <=> Fail Exn; bind (return "test") f <=> Return "testtest"; bind (fail Exn) return <=> Fail Exn; (return "test") >>= f <=> Return "testtest"; f =<< (return "test") <=> Return "testtest"; map g (return "test") <=> Return "testtest"; (return "test") >|= g <=> Return "testtest"; g =|< (return "test") <=> Return "testtest"; return true); test "1" (fun () -> catch return (fun e -> return ()) <=> Return (); catch (fun () -> fail Exn) (function Exn -> return ()| e -> assert false) <=> Return (); catch (fun () -> fail Exn) (fun e -> fail e) <=> Fail Exn; return true); test "2" (fun () -> try_bind return return ( fun e -> assert false ) <=> Return (); try_bind (fun () -> fail Exn) return (function Exn -> return ()| e -> assert false) <=> Return (); return true); test "3" (fun () -> finalize return return <=> Return (); finalize (fun () -> fail Exn) return <=> Fail Exn; return true); test "4" (fun () -> apply (fun () -> raise Exn) () <=> Fail Exn; return true); test "5" (fun () -> choose [return ()] <=> Return (); return () return () <=> Return (); return true); test "6" (fun () -> join [return ()] <=> Return (); return () <&> return () <=> Return (); return true); test "7" (fun () -> assert (ignore_result (return ()) = ()); test_exn ignore_result (fail Exn) Exn; return true); test "8" (fun () -> let t,w = wait () in t <=> Sleep; wakeup w (); t <=> Return (); return true); test "9" (fun () -> let t,w = wait () in wakeup_exn w Exn; t <=> Fail Exn; return true); test "10" (fun () -> let t,w = task () in t <=> Sleep; wakeup w (); t <=> Return (); return true); test "11" (fun () -> let t,w = wait () in let r1 = choose [t] in r1 <=> Sleep; choose [t;return ()] <=> Return (); join [fail Exn;t] <=> Sleep; let r2 = join [t] in r2 <=> Sleep; let r3 = join [t;return ()] in r3 <=> Sleep; wakeup w (); r1 <=> Return (); r2 <=> Return (); r3 <=> Return (); return true); test "12" (fun () -> let t,w = wait () in let t',w' = wait () in let r1 = join [return ();t] in let r2 = join [t;t'] in wakeup_exn w Exn; r1 <=> Fail Exn; r2 <=> Sleep; return true); test "13" (fun () -> let t,w = wait () in let t',w' = wait () in let r = bind (choose [t;t']) return in r <=> Sleep; wakeup w' (); r <=> Return (); let r' = bind (choose [t;t]) return in wakeup w (); r' <=> Return (); return true); test "14" (fun () -> assert ( poll (return ()) = Some () ); test_exn poll (fail Exn) Exn; let t,w = wait () in assert ( poll t = None ); return true); test_direct "15.1" (fun () -> let exns = ref [] in with_async_exception_hook (fun e -> exns := e :: !exns) (fun () -> let t, w = wait () in ignore_result t; wakeup w (); assert (!exns = []); let t, w = wait () in ignore_result t; wakeup_exn w Exn; assert (!exns = [Exn]); true)); test "16" (fun () -> let t,w = wait () in let r1 = catch (fun () -> t) (fun e -> return ()) in r1 <=> Sleep; let r2 = try_bind (fun () -> t) return ( fun e -> assert false ) in r2 <=> Sleep; wakeup w (); r1 <=> Return (); r2 <=> Return (); return true); (****) test "17" (fun () -> let t,w = task () in let t',w' = wait () in let t'' = return () in cancel t; cancel t'; cancel t''; t <=> Fail Canceled; t' <=> Sleep; t'' <=> Return () ; return true); test "18" (fun () -> let t,w = task () in let r = bind t return in cancel r; r <=> Fail Canceled; return true); test "19" (fun () -> let t,w = task () in on_cancel t (fun () -> ()); on_cancel (return ()) (fun () -> assert false); cancel t; on_cancel t (fun () -> ()); let t,w = wait () in on_cancel t (fun () -> ()); wakeup w (); return true); test "20" (fun () -> let t,w = task () in let t',w' = wait () in let r = pick [t;t'] in r <=> Sleep; wakeup w' (); r <=> Return (); t <=> Fail Canceled; return true); test "21" (fun () -> pick [return ()] <=> Return (); return true); test "22" (fun () -> let t,w = task () in let t',w' = wait () in let r = pick [t;t'] in cancel r; r <=> Fail Canceled; t <=> Fail Canceled; return true); test "23" (fun () -> let t,w = task () in let r = join [t] in cancel r; r <=> Fail Canceled; t <=> Fail Canceled; return true); test "24" (fun () -> let t,w = task () in let r = choose [t] in cancel r; r <=> Fail Canceled; t <=> Fail Canceled; return true); test "25" (fun () -> let t,w = task () in let r = catch (fun () -> t) (function Canceled -> return ()| _ -> assert false) in cancel r; r <=> Return (); t <=> Fail Canceled; return true); test "26" (fun () -> let t,w = task () in let r = try_bind (fun () -> t) (fun _ -> assert false) (function Canceled -> return ()| _ -> assert false) in cancel r; r <=> Return (); t <=> Fail Canceled; return true); test "27" (fun () -> let t,w = wait () in wakeup w (); test_exn (wakeup w) () (Invalid_argument "Lwt.wakeup_result"); return true); test "28" (fun () -> let t,w = task () in cancel t; wakeup w (); return true); test "29" (fun () -> let t,w = wait () in let t',w' = wait () in let r = bind t ( fun () -> t' ) in let r' = bind t ( fun () -> r ) in wakeup w (); r <=> Sleep; r' <=> Sleep; wakeup w' (); r <=> Return (); r' <=> Return (); return true); test "30" (fun () -> let t,w = wait () in let t',w' = wait () in let t'',w'' = wait () in let r = bind t ( fun () -> t' ) in let r' = bind t'' ( fun () -> r ) in wakeup w'' (); r <=> Sleep; r' <=> Sleep; wakeup w (); wakeup w' (); r' <=> Return (); r <=> Return (); return true); test "31" (fun () -> let t,w = wait () in let a = ref (return ()) in let r = bind t ( fun () -> !a ) in a := r; wakeup w (); return true); test "choose" (fun () -> let t1,w1 = wait () in let t2,w2 = wait () in let rec f = function | 0 -> [] | i -> (choose [t1;t2])::(f (i-1)) in let l = f 100 in t1 <=> Sleep; t2 <=> Sleep; List.iter (fun t -> t <=> Sleep) l; wakeup w1 (); List.iter (fun t -> t <=> Return ()) l; t1 <=> Return (); t2 <=> Sleep; return true); test "protected return" (fun () -> let t = return 1 in let t' = protected t in return ((state t' = Return 1) && (state t = Return 1))); test "protected fail" (fun () -> let t = fail Exn in let t' = protected t in return ((state t' = Fail Exn) && (state t = Fail Exn))); test "protected wait 1" (fun () -> let t,w = wait () in let t' = protected t in wakeup w 1; return ((state t' = Return 1) && (state t = Return 1))); test "protected wait 2" (fun () -> let t,w = wait () in let t' = protected t in wakeup_exn w Exn; return ((state t' = Fail Exn) && (state t = Fail Exn))); test "protected wait 3" (fun () -> let t,w = wait () in let t' = protected t in cancel t'; return ((state t' = Fail Canceled) && (state t = Sleep))); test "protected wait 4" (fun () -> let t,w = wait () in let t' = protected t in cancel t'; wakeup w 1; return ((state t' = Fail Canceled) && (state t = Return 1))); test "protected wait 5" (fun () -> let t,w = wait () in let t' = protected t in cancel t'; wakeup_exn w Exn; return ((state t' = Fail Canceled) && (state t = Fail Exn))); test "protected wait 6" (fun () -> let t,w = wait () in let t' = protected t in wakeup_exn w Exn; cancel t'; return ((state t' = Fail Exn) && (state t = Fail Exn))); test "protected wait 7" (fun () -> let t,w = wait () in let t' = protected t in wakeup w 1; cancel t'; return ((state t' = Return 1) && (state t = Return 1))); test "join 1" (fun () -> let t1 = fail Exn in let t2 = join [t1] in return ((state t1 = Fail Exn) && (state t2 = Fail Exn))); test "join 2" (fun () -> let t1,w1 = wait () in let t2 = join [t1] in wakeup_exn w1 Exn; return ((state t1 = Fail Exn) && (state t2 = Fail Exn))); test "join 3" (fun () -> let t1 = fail Exn in let t2,w2 = wait () in let t3 = fail Not_found in let t4 = join [t2;t1;t3] in return ((state t1 = Fail Exn) && (state t2 = Sleep) && (state t3 = Fail Not_found) && (state t4 = Sleep))); test "join 4" (fun () -> let t1 = fail Exn in let t2,w2 = wait () in let t3 = return () in let rec f = function | 0 -> return true | i -> let t = join [t2;t3;t1] in if ((state t1 = Fail Exn) && (state t2 = Sleep) && (state t = Sleep) && (state t3 = Return ())) then f (i-1) else return false in f 100); test "cancel loop" (fun () -> let rec loop () = Lwt_unix.yield () >>= fun () -> loop () in let t = loop () in cancel t; return (state t = Fail Canceled)); test "cancel loop 2" (fun () -> let rec loop () = Lwt_unix.yield () >>= fun () -> loop () in let t = loop () in Lwt_unix.yield () >>= fun () -> cancel t; return (state t = Fail Canceled)); test "nchoose" (fun () -> nchoose [return 1; return 2] >>= fun l -> return (l = [1; 2])); test "npick" (fun () -> npick [return 1; return 2] >>= fun l -> return (l = [1; 2])); test "bind/cancel 1" (fun () -> let waiter, wakener = wait () in let t = waiter >>= fun () -> 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 = waiter >>= fun () -> 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 = waiter1 >>= fun () -> Lwt.catch (fun () -> waiter2 >>= fun () -> fst (task ())) (function | Canceled -> return true | exn -> Lwt.fail exn) 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 () -> waiter >>= fun () -> return (get key = Some 2)) in wakeup wakener (); t)); test "on_cancel race condition" (fun () -> (* Queue of cancel-able pending threads. *) let queue = Lwt_sequence.create () in (* Add two cancel-able pending threads to the queue. *) let waiter1, wakener1 = task () in let node1 = Lwt_sequence.add_r wakener1 queue in let waiter2, wakener2 = task () in let node2 = Lwt_sequence.add_r wakener2 queue in (* Remove nodes when a thread is canceled. *) on_cancel waiter1 (fun () -> Lwt_sequence.remove node1); on_cancel waiter2 (fun () -> Lwt_sequence.remove node2); (* Add another one to the left of the on_cancel one: *) let waiter', wakener' = wait () in let t = bind waiter' (fun _ -> waiter1) in (* Send a value to the first thread of the queue when [t] fails. *) ignore ( Lwt.catch (fun () -> t) (fun _ -> (* Take the first thread from the queue and send it a value. *) wakeup (Lwt_sequence.take_l queue) 42; return 0) ); (* Terminate [waiter'] so [waiter1 <- Repr t] *) wakeup wakener' 0; (* now there are two thunk functions on [t]: - (fun _ -> wakeup (Lwt_sequence.take_l queue) 42; return 0); - (fun _ -> Lwt_sequence.remove node); *) (* Cancel [waiter1]. If on_cancel handlers are not executed before other thunk functions, [42] is lost. *) cancel waiter1; return (state waiter1 = Fail Canceled && state waiter2 = Return 42)); test "re-cancel" (fun () -> let waiter1, wakener1 = task () in let waiter2, wakener2 = task () in let waiter3, wakener3 = task () in let t1 = catch (fun () -> waiter1) (fun exn -> waiter2) in let t2 = bind t1 return in let t3 = bind waiter3 (fun () -> t1) in wakeup wakener3 (); cancel t3; cancel t2; return (List.for_all (fun t -> state t = Fail Canceled) [t1; t2; t3; waiter1; waiter2])); test "re-cancel choose" (fun () -> let waiter1, wakener1 = task () in let waiter2, wakener2 = task () in let t1 = catch (fun () -> waiter1) (fun exn -> waiter2) in let t2 = choose [t1] in cancel t2; cancel t2; return (state waiter1 = Fail Canceled && state waiter2 = Fail Canceled)); test "ignore_result 2" (fun () -> let exns = ref [] in with_async_exception_hook (fun e -> exns := e :: !exns) (fun () -> let waiter, wakener = wait () in let t1 = map (fun () -> 42) waiter in ignore_result ( waiter >>= fun () -> fail Exit ); let t2 = map (fun () -> "42") waiter in wakeup wakener (); return (!exns = [Exit] && state t1 = Return 42 && state t2 = Return "42"))); test "on_success exn 2" (fun () -> let exns = ref [] in with_async_exception_hook (fun e -> exns := e :: !exns) (fun () -> let waiter, wakener = wait () in let t1 = map (fun () -> 42) waiter in on_success waiter (fun () -> raise Exit); let t2 = map (fun () -> "42") waiter in wakeup wakener (); return (!exns = [Exit] && state t1 = Return 42 && state t2 = Return "42"))); ] lwt-2.5.2/tests/core/test_lwt_list.ml000066400000000000000000000066041270742521300176630ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 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 Lwt_list.iter_p [1;0;1]; test_exception Lwt_list.iter_p; return true); test "1" (fun () -> test_iter Lwt_list.iter_s [1;0;0]; test_exception Lwt_list.iter_s; return true); test "2" (fun () -> test_map Lwt_list.map_p [4;8;5]; test_exception Lwt_list.map_p; return true); test "3" (fun () -> test_map Lwt_list.map_s [4;7;8]; test_exception Lwt_list.map_s; return true); test "4" (fun () -> let l = [1;2;3] in let f acc v = return (v::acc) in let t = Lwt_list.fold_left_s f [] l in t <=> Return (List.rev l); return true); ] lwt-2.5.2/tests/core/test_lwt_stream.ml000066400000000000000000000244711270742521300202050ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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_mvar.take mvar >>= fun x -> 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_mvar.put mvar 1 >>= fun () -> t1 >>= fun x1 -> t2 >>= fun x2 -> t3 >>= fun x3 -> return ([x1; x2; x3] = [1; 1; 1])); test "of_list" (fun () -> let stream = Lwt_stream.of_list [1; 2; 3] in Lwt_stream.next stream >>= fun x1 -> Lwt_stream.next stream >>= fun x2 -> Lwt_stream.next stream >>= fun x3 -> 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_stream.next stream1 >>= fun x1_1 -> Lwt_stream.next stream2 >>= fun x2_1 -> Lwt_stream.next stream1 >>= fun x1_2 -> Lwt_stream.next stream1 >>= fun x1_3 -> Lwt_stream.next stream2 >>= fun x2_2 -> Lwt_stream.next stream2 >>= fun x2_3 -> 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_stream.to_list stream >>= fun l -> return (l = [1; 2; 3])); test "create 2" (fun () -> let stream, push = Lwt_stream.create () in push None; let t = Lwt_stream.next stream in return (Lwt.state t = Fail Lwt_stream.Empty)); test "create_bounded" (fun () -> let stream, push = Lwt_stream.create_bounded 3 in let acc = true in let acc = acc && state (push#push 1) = Return () in let acc = acc && state (push#push 2) = Return () in let acc = acc && state (push#push 3) = Return () in let t = push#push 4 in let acc = acc && state t = Sleep in let acc = acc && state (push#push 5) = Fail Lwt_stream.Full in let acc = acc && state (push#push 6) = Fail Lwt_stream.Full in let acc = acc && state (Lwt_stream.get stream) = Return (Some 1) in (* Lwt_stream uses wakeup_later so we have to wait a bit. *) Lwt_unix.yield () >>= fun () -> let acc = acc && state t = Return () in let acc = acc && state (Lwt_stream.get stream) = Return (Some 2) in let acc = acc && state (push#push 7) = Return () in push#close; let acc = acc && state (push#push 8) = Fail Lwt_stream.Closed in let acc = acc && state (Lwt_stream.to_list stream) = Return [3; 4; 7] in return acc); test "create_bounded close" (fun () -> let stream, push = Lwt_stream.create_bounded 1 in let acc = true in let acc = acc && state (push#push 1) = Return () in let iter_delayed = Lwt_stream.to_list stream in Lwt_unix.yield () >>= fun () -> push#close; Lwt_unix.yield () >>= fun () -> let acc = acc && state iter_delayed = Return [1] in return acc ); test "get_while" (fun () -> let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in Lwt_stream.get_while (fun x -> x < 3) stream >>= fun l1 -> Lwt_stream.to_list stream >>= fun l2 -> return (l1 = [1; 2] && l2 = [3; 4; 5])); test "peek" (fun () -> let stream = Lwt_stream.of_list [1; 2; 3; 4; 5] in Lwt_stream.peek stream >>= fun x -> Lwt_stream.peek stream >>= fun y -> Lwt_stream.to_list stream >>= fun l -> 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_stream.npeek 3 stream >>= fun x -> Lwt_stream.npeek 1 stream >>= fun y -> Lwt_stream.to_list stream >>= fun l -> 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_stream.get stream >>= fun x -> 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_stream.get stream >>= fun x -> 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_stream.get filtered >>= fun x -> 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_stream.get filtered >>= fun x -> 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_stream.last_new stream >>= fun x -> return (x = 3)); test "cancel push stream 1" (fun () -> let stream, push = Lwt_stream.create () in let t = Lwt_stream.next stream in cancel t; return (state t = Fail Canceled)); test "cancel push stream 2" (fun () -> let stream, push = Lwt_stream.create () in let t = Lwt_stream.next stream in cancel t; push (Some 1); let t' = Lwt_stream.next stream in return (state t' = Return 1)); test "cancel push stream 3" (fun () -> let stream, push = Lwt_stream.create () in let t1 = Lwt_stream.next stream in let t2 = Lwt_stream.next stream in cancel t1; push (Some 1); return (state t1 = Fail Canceled && state t2 = Return 1)); (* check if the push function keeps references to the elements in the stream *) test "push and GC" (fun () -> let w = Weak.create 5 in (* Count the number of reachable elements in the stream. *) let count () = let rec loop acc idx = if idx = Weak.length w then acc else match Weak.get w idx with | None -> loop acc (idx + 1) | Some v -> loop (acc + 1) (idx + 1) in loop 0 0 in (* Run some test and return the push function of the stream. *) let test () = let stream, push = Lwt_stream.create () in assert (count () = 0); let r1 = Some(ref 1) in push r1; Weak.set w 1 r1; let r2 = Some(ref 2) in push r2; Weak.set w 2 r2; let r3 = Some(ref 3) in push r3; Weak.set w 3 r3; assert (count () = 3); assert (state (Lwt_stream.next stream) = Return {contents = 1}); Gc.full_major (); (* Ocaml can consider that stream is unreachable before the next line, hence freeing the whole data. *) assert (count () <= 3); push in let push = test () in Gc.full_major (); (* At this point [stream] is unreachable. *) assert (count () = 0); (* We have that to force caml to keep a reference on [push]. *) push (Some(ref 4)); return true); test "map_exn" (fun () -> let open Lwt_stream in let l = [Value 1; Error Exit; Error (Failure "plop"); Value 42; Error End_of_file] in let q = ref l in let stream = Lwt_stream.from (fun () -> match !q with | [] -> return None | Value x :: l -> q := l; return (Some x) | Error e :: l -> q := l; Lwt.fail e) in Lwt_stream.to_list (Lwt_stream.map_exn stream) >>= fun l' -> return (l = l')); test "on_termination" (fun () -> let st = Lwt_stream.of_list [1; 2] in let b = ref false in Lwt_stream.on_termination st (fun () -> b := true); ignore (Lwt_stream.peek st); let b1 = !b = false in ignore (Lwt_stream.junk st); ignore (Lwt_stream.peek st); let b2 = !b = false in ignore (Lwt_stream.junk st); ignore (Lwt_stream.peek st); let b3 = !b = true in Lwt.return (b1 && b2 && b3)); test "choose_exhausted" (fun () -> Lwt_stream.(to_list (choose [of_list []])) >|= fun _ -> true); ] lwt-2.5.2/tests/ppx/000077500000000000000000000000001270742521300143025ustar00rootroot00000000000000lwt-2.5.2/tests/ppx/main.ml000066400000000000000000000103621270742521300155620ustar00rootroot00000000000000open Test open Lwt let suite = suite "ppx" [ test "let" (fun () -> let%lwt x = return 3 in return (x + 1 = 4) ) ; test "nested let" (fun () -> let%lwt x = return 3 in let%lwt y = return 4 in return (x + y = 7) ) ; test "and let" (fun () -> let%lwt x = return 3 and y = return 4 in return (x + y = 7) ) ; test "match" (fun () -> let x = Lwt.return (Some 3) in match%lwt x with | Some x -> return (x + 1 = 4) | None -> return false ) ; test "match-exn" (fun () -> let x = Lwt.return (Some 3) in let x' = Lwt.fail Not_found in let%lwt a = match%lwt x with | exception Not_found -> return false | Some x -> return (x = 3) | None -> return false and b = match%lwt x' with | exception Not_found -> return true | _ -> return false in Lwt.return (a && b) ) ; test "if" (fun () -> let x = Lwt.return true in let%lwt a = if%lwt x then Lwt.return_true else Lwt.return_false in let%lwt b = if%lwt x>|= not then Lwt.return_false else Lwt.return_true in (if%lwt x >|= not then Lwt.return_unit) >>= fun () -> Lwt.return (a && b) ) ; test "for" (* Test for proper sequencing *) (fun () -> let r = ref [] in let f x = let%lwt () = Lwt_unix.sleep 0.2 in Lwt.return (r := x :: !r) in let%lwt () = for%lwt x = 3 to 5 do f x done in return (!r = [5 ; 4 ; 3]) ) ; test "while" (* Test for proper sequencing *) (fun () -> let r = ref [] in let f x = let%lwt () = Lwt_unix.sleep 0.2 in Lwt.return (r := x :: !r) in let%lwt () = let c = ref 2 in while%lwt !c < 5 do incr c ; f !c done in return (!r = [5 ; 4 ; 3]) ) ; test "assert" (fun () -> let%lwt () = assert%lwt true in return true ) ; test "raise" (fun () -> Lwt.catch (fun () -> [%lwt raise Not_found]) (fun exn -> return (exn = Not_found)) ) ; test "try" (fun () -> try%lwt Lwt.fail Not_found with _ -> return true ) [@warning("@8@11")] ; test "try raise" (fun () -> try%lwt raise Not_found with _ -> return true ) [@warning("@8@11")] ; test "try fallback" (fun () -> try%lwt try%lwt Lwt.fail Not_found with Failure _ -> return false with Not_found -> return true ) [@warning("@8@11")] ; test "finally body" (fun () -> let x = ref false in begin (try%lwt return_unit with | _ -> return_unit ) [%finally x := true; return_unit] end >>= fun () -> return !x ) ; test "finally exn" (fun () -> let x = ref false in begin (try%lwt raise Not_found with | _ -> return_unit ) [%finally x := true; return_unit] end >>= fun () -> return !x ) ; test "finally exn default" (fun () -> let x = ref false in try%lwt ( raise Not_found )[%finally x := true; return_unit] >>= fun () -> return false with Not_found -> return !x ) ; test "sequence" (fun () -> let lst = ref [] in (lst := 2 :: !lst; Lwt.return_unit) >> (lst := 1 :: !lst; Lwt.return_unit) >> (Lwt.return (!lst = [1;2])) ) ; test "log" (fun () -> Lwt_log.ign_debug "bar"; Lwt_log.debug "foo" >>= fun () -> Lwt_log.info_f "baz" >>= fun () -> return_true ) ; test "structure let" (fun () -> let module M = struct let%lwt result = Lwt.return_true end in Lwt.return M.result ) ; ] let _ = Test.run "ppx" [ suite ] lwt-2.5.2/tests/preemptive/000077500000000000000000000000001270742521300156535ustar00rootroot00000000000000lwt-2.5.2/tests/preemptive/main.ml000066400000000000000000000017311270742521300171330ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Main * Copyright (C) 2009 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) Test.run "preemptive" [ Test_lwt_preemptive.suite; ] lwt-2.5.2/tests/preemptive/test_lwt_preemptive.ml000066400000000000000000000024041270742521300223120ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Test_lwt_io * Copyright (C) 2012 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) open Lwt open Test let suite = suite "lwt_preemptive" [ test "run_in_main" (fun () -> let f () = Lwt_preemptive.run_in_main (fun () -> Lwt_unix.sleep 0.01 >>= fun () -> return 42) in Lwt_preemptive.detach f () >>= fun x -> return (x = 42)); ] lwt-2.5.2/tests/react/000077500000000000000000000000001270742521300145715ustar00rootroot00000000000000lwt-2.5.2/tests/react/main.ml000066400000000000000000000017501270742521300160520ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Main * Copyright (C) 2009 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) Test.run "react" [ Test_lwt_event.suite; Test_lwt_signal.suite; ] lwt-2.5.2/tests/react/test_lwt_event.ml000066400000000000000000000056251270742521300202010ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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_react.E.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_react.E.to_stream event in push 1; push 2; push 3; Lwt.bind (Lwt_stream.nget 3 stream) (fun l -> return (l = [1; 2; 3]))); test "map_s" (fun () -> let l = ref [] in let event, push = React.E.create () in let event' = Lwt_react.E.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_react.E.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_react.E.of_stream stream) in ignore event; push (Some 1); push (Some 2); push (Some 3); Lwt.wakeup_paused (); return (!l = [3; 2; 1])); test "limit" (fun () -> let event, push = React.E.create () in let cond = Lwt_condition.create () in let event' = Lwt_react.E.limit (fun () -> Lwt_condition.wait cond) event in let l = ref [] in let event'' = React.E.map (fun x -> l := x :: !l) event' in ignore event'; ignore event''; push 1; push 0; push 2; (* overwrites previous 0 *) Lwt_condition.signal cond (); push 3; push 4; Lwt_condition.signal cond (); return (!l = [4; 3; 2; 1])); ] lwt-2.5.2/tests/react/test_lwt_signal.ml000066400000000000000000000030741270742521300203310ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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" [ test "limit" (fun () -> let s, push = React.S.create 0 in let cond = Lwt_condition.create () in let s' = Lwt_react.S.limit (fun () -> Lwt_condition.wait cond) s in let l = ref [] in let e = React.E.map (fun x -> l := x :: !l) (React.S.changes s') in ignore e; Lwt_condition.signal cond (); push 1; push 0; push 2; (* overwrites previous 0 *) Lwt_condition.signal cond (); push 3; push 4; Lwt_condition.signal cond (); return (!l = [4; 3; 2; 1])); ] lwt-2.5.2/tests/test.ml000066400000000000000000000055001270742521300150040ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Test * Copyright (C) 2009 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) open Lwt open Lwt_io type t = { name : string; run : unit -> bool; } type suite = { suite_name : string; suite_tests : t list; } let test_direct ~name ~run = { name = name; run = run } let test ~name ~run = { name = name; run = (fun () -> Lwt_main.run (run ())) } let suite ~name ~tests = { suite_name = name; suite_tests = tests } let run ~name ~suites = (* Count the number of tests in [suites] *) let total = List.fold_left (fun n { suite_tests = l } -> n + List.length l) 0 suites in Printf.printf "Running %d tests for library %S.\n%!" total name; (* Iterate over suites: *) let rec loop_suites failures number suites = match suites with | [] -> if failures = 0 then Printf.printf "\r\027[JDone. All tests succeeded.\n%!" else begin Printf.printf "\r\027[JDone. %d of %d tests failed.\n%!" failures total; exit 1 end | suite :: suites -> loop_tests failures suite.suite_name number suites suite.suite_tests (* Iterate over tests: *) and loop_tests failures suite_name number suites tests = match tests with | [] -> loop_suites failures number suites | test :: tests -> Printf.printf "\r\027[J(%d/%d) Running test %S from suite %S%!" number total test.name suite_name; try if test.run () then loop_tests failures suite_name (number + 1) suites tests else begin Printf.printf "\r\027[J\027[31;1mTest %S from suite %S failed.\027[0m\n%!" test.name suite_name; loop_tests (failures + 1) suite_name (number + 1) suites tests end with exn -> Printf.printf "\r\027[J\027[31;1mTest %S from suite %S failed. It raised: %S.\027[0m\n%!" test.name suite_name (Printexc.to_string exn); loop_tests (failures + 1) suite_name (number + 1) suites tests in loop_suites 0 1 suites lwt-2.5.2/tests/test.mldylib000066400000000000000000000001311270742521300160230ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 0cbc6611f5540bd0809a388dc95a615b) Test # OASIS_STOP lwt-2.5.2/tests/test.mli000066400000000000000000000030601270742521300151540ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Interface Test * Copyright (C) 2009 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (** Helpers for test *) type t (** Type of a test *) type suite (** Type of a suite of tests *) val test_direct : name : string -> run : (unit -> bool) -> t (** Defines a test. [run] must returns [true] if the test succeeded and [false] otherwise. *) val test : name : string -> run : (unit -> bool Lwt.t) -> t (** Defines a test which returns a thread. *) val suite : name : string -> tests : t list -> suite (** Defines a suite of tests *) val run : name : string -> suites : suite list -> unit (** Run all the given tests and exit the program with an exit code of [0] if all tests succeeded and with [1] otherwise. *) lwt-2.5.2/tests/test.mllib000066400000000000000000000001311270742521300154660ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 0cbc6611f5540bd0809a388dc95a615b) Test # OASIS_STOP lwt-2.5.2/tests/unix/000077500000000000000000000000001270742521300144565ustar00rootroot00000000000000lwt-2.5.2/tests/unix/main.ml000066400000000000000000000020301270742521300157270ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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; Test_lwt_process.suite; Test_mcast.suite; ] lwt-2.5.2/tests/unix/test_lwt_io.ml000066400000000000000000000044541270742521300173530ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 bytes = Bytes.create len in Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; sent := bytes :: !sent; return len) in write oc "foo" >>= fun () -> write oc "bar" >>= fun () -> if !sent <> [] then return false else Lwt_unix.yield () >>= fun () -> return (!sent = [Bytes.of_string "foobar"])); test "auto-flush in atomic" (fun () -> let sent = ref [] in let oc = make ~mode:output (fun buf ofs len -> let bytes = Bytes.create len in Lwt_bytes.blit_to_bytes buf ofs bytes 0 len; sent := bytes :: !sent; return len) in atomic (fun oc -> write oc "foo" >>= fun () -> write oc "bar" >>= fun () -> if !sent <> [] then return false else Lwt_unix.yield () >>= fun () -> return (!sent = [Bytes.of_string "foobar"])) oc); ] lwt-2.5.2/tests/unix/test_lwt_io_non_block.ml000066400000000000000000000041051270742521300213700ustar00rootroot00000000000000(* Lightweight thread library for OCaml * 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 () = open_file ~mode:input test_file >>= fun in_chan -> read in_chan >>= fun s -> close in_chan >>= fun () -> assert (s = file_contents); return () let suite = suite "lwt_io non blocking io" [ test "file does not exist" (fun () -> Lwt_unix.file_exists test_file >|= fun r -> not r); test "create file" (fun () -> open_file ~mode:output test_file >>= fun out_chan -> write out_chan file_contents >>= fun () -> close out_chan >>= fun () -> return true); test "file exists" (fun () -> Lwt_unix.file_exists test_file); test "read file" (fun () -> open_file ~mode:input test_file >>= fun in_chan -> read in_chan >>= fun s -> close in_chan >>= fun () -> return (s = file_contents)); test "many read file" (fun () -> let rec loop i = open_and_read_filename () >>= fun () -> if i > 10000 then return true else loop (i + 1) in loop 0); test "remove file" (fun () -> Unix.unlink test_file; return true); ] lwt-2.5.2/tests/unix/test_lwt_process.ml000066400000000000000000000005501270742521300204130ustar00rootroot00000000000000 open Lwt open Lwt_io open Test let suite = suite "lwt_process" [ test "lazy_undefined" (fun () -> Lwt_process.with_process_in ~timeout:1. ("sleep", [| "sleep"; "2" |]) (fun p -> Lwt.catch (fun () -> Lwt_io.read p#stdout) (fun _ -> Lwt.return "")) >>= fun _ -> Lwt.return_true) ] lwt-2.5.2/tests/unix/test_mcast.ml000066400000000000000000000056271270742521300171700ustar00rootroot00000000000000(* Lightweight thread library for OCaml * http://www.ocsigen.org/lwt * Module Test_mcast * Copyright (C) 2015 Nicolas Ojeda Bar * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * 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.Infix open Test let hello = Bytes.unsafe_of_string "Hello, World!" let mcast_addr = "225.0.0.1" let mcast_port = 4321 let with_fd f = let fd = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in Lwt.finalize (fun () -> f fd) (fun () -> Lwt_unix.close fd) let child join fd = (* Lwt_unix.setsockopt fd Lwt_unix.SO_REUSEADDR true; *) Lwt_unix.(bind fd (ADDR_INET (Unix.inet_addr_any, mcast_port))); if join then Lwt_unix.mcast_add_membership fd (Unix.inet_addr_of_string mcast_addr); let buf = Bytes.create 50 in Lwt_unix.read fd buf 0 50 >>= fun n -> (* Printf.printf "\nReceived multicast message %S\n%!" (Bytes.unsafe_to_string (Bytes.sub buf 0 n)); *) if Bytes.sub buf 0 n <> hello then Lwt.fail (Failure "unexpected multicast message") else Lwt.return_unit let parent set_loop fd = Lwt_unix.mcast_set_loop fd set_loop; let rec loop () = Lwt_unix.(sendto fd hello 0 (Bytes.length hello) [] (ADDR_INET (Unix.inet_addr_of_string mcast_addr, mcast_port))) >>= fun _ -> (* Printf.printf "\nSending multicast message %S to %s:%d\n%!" (Bytes.unsafe_to_string hello) *) (* mcast_addr mcast_port; *) Lwt_unix.sleep 0.2 >>= loop in loop () let test_mcast join set_loop = let should_timeout = not join || not set_loop in let t = Lwt_unix.with_timeout 0.5 (fun () -> Lwt.pick [ with_fd (child join); with_fd (parent set_loop) ]) in Lwt.catch (fun () -> t >>= fun x -> Lwt.return (`Ok x)) (fun e -> Lwt.return (`Fail e)) >>= function | `Fail Lwt_unix.Timeout -> Lwt.return should_timeout | `Fail e -> Printf.eprintf "\ntest_mcast: unexpected failure: %S\n%!" (Printexc.to_string e); Lwt.return false | `Ok () -> Lwt.return true let suite = suite "unix_mcast" [ test "mcast-join-loop" (fun () -> test_mcast true true); test "mcast-nojoin-loop" (fun () -> test_mcast false true); test "mcast-join-noloop" (fun () -> test_mcast true false); test "mcast-nojoin-noloop" (fun () -> test_mcast false false); ] lwt-2.5.2/utils/000077500000000000000000000000001270742521300134715ustar00rootroot00000000000000lwt-2.5.2/utils/ocamlinit000066400000000000000000000012211270742521300153670ustar00rootroot00000000000000(* -*- 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";; (* Syntax to use, you can replace that with #camlp4r if you prefer revised syntax: *) #camlp4o;; (* Load Lwt syntactic sugars: *) #require "lwt.syntax";; (* Open useful Lwt modules for scripting: *) open Lwt_unix;; open Lwt;; open Lwt_io;; open Lwt_process;; (* Useful definitions for interactive use of Lwt, so you can write: $ run& printl "plop";; or: $ let l = run& read_line stdin;; *) let ( & ) a b = a b;; let run = Lwt_main.run;; lwt-2.5.2/utils/style.css000066400000000000000000000050361270742521300153470ustar00rootroot00000000000000/* A style for ocamldoc. Daniel C. Buenzli, Jérémie Dimino */ body { padding: 0em; border: 0em; margin: 2em 10% 2em 10%; font-weight: normal; line-height: 130%; text-align: justify; background: white; color : black; min-width: 40ex; } pre, p, div, span, img, table, td, ol, ul, li { padding: 0em; border: 0em; margin: 0em } h1, h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { fontsize: 100%; margin-bottom: 1em padding: 1ex 0em 0em 0em; border: 0em; margin: 1em 0em 0em 0em; font-weight : bold; text-align: center; } h1 { font-size : 140% } h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { font-size : 100%; border-top-style : none; margin: 1ex 0em 0em 0em; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px; text-align: center; padding: 2px; } h2 { font-size : 120%; background-color: #90BDFF ; } h3 { background-color: #90DDFF; } h4 { background-color: #90EDFF; } h5 { background-color: #90FDFF; } h6 { background-color: #C0FFFF; } div.h7 { background-color: #E0FFFF; } div.h8 { background-color: #F0FFFF; } div.h9 { background-color: #FFFFFF; } .navbar { padding-bottom : 1em; margin-bottom: 1em; border-bottom: 1px solid #000000; border-bottom-style: dotted; } p { padding: 1em 0ex 0em 0em } a, a:link, a:visited, a:active, a:hover { color : #009; text-decoration: none } a:hover { color : #009; text-decoration : none; background-color: #5FFF88 } hr { border-style: none; } table { font-size : 100% /* Why ? */ } ul li { padding: 1em 0em 0em 0em; margin:0em 0em 0em 2.5ex } ol li { padding: 1em 0em 0em 0em; margin:0em 0em 0em 2em } pre { margin: 3ex 0em 1ex 0em; background-color: #edf0f9; } .keyword { font-weight: bold; color: #a020f0; } .keywordsign { font-weight: bold; color: #a020f0; } .typefieldcomment { color : #b22222; } .keywordsign { color: #a020f0; } .code { font-size: 120%; color: #5f5f5f; } .info { margin: 0em 0em 0em 2em } .comment { color : #b22222; } .constructor { color : #072 } .type { color : #228b22; } .string { color : #bc8f8f; } .warning { color : Red; font-weight : bold } div.sig_block { margin-left: 2em } .typetable { color : #b8860b; border-style : hidden } .indextable { border-style : hidden } .paramstable { border-style : hidden; padding: 5pt 5pt } .superscript { font-size : 80% } .subscript { font-size : 80% } lwt-2.5.2/utils/tuareg-1.45.6.patch000066400000000000000000000500711270742521300165350ustar00rootroot00000000000000diff --git a/tuareg.el b/tuareg.el index 7529577..e5b3b71 100644 --- a/tuareg.el +++ b/tuareg.el @@ -693,7 +693,7 @@ and `tuareg-xemacs-w3-manual' (XEmacs only)." "Return relative indentation of the keyword given in argument." (let ((ind (symbol-value (cdr (assoc kwop tuareg-keyword-alist)))) (looking-let-or-and (and look-for-let-or-and - (looking-at "\\<\\(let\\|and\\)\\>")))) + (looking-at "\\<\\(let\\|lwt\\|and\\)\\>")))) (if (string-match "\\<\\(with\\|function\\|parser?\\)\\>" kwop) (+ (if (and tuareg-let-always-indent looking-let-or-and (< ind tuareg-let-indent)) @@ -1015,7 +1015,8 @@ Regexp match data 0 points to the chars." '("module" "class" "functor" "object" "type" "val" "inherit" "include" "virtual" "constraint" "exception" "external" "open" "method" "and" "initializer" "to" "downto" "do" "done" "else" - "begin" "end" "let" "in" "then" "with")) + "begin" "end" "let" "in" "then" "with" + "lwt" "try_lwt" "for_lwt" "finally")) (setq abbrevs-changed nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1143,7 +1144,7 @@ Special keys for Tuareg mode:\\{tuareg-mode-map}" tuareg-font-lock-keywords (append (list - (list "\\<\\(external\\|open\\|include\\|rule\\|s\\(ig\\|truct\\)\\|module\\|functor\\|with[ \t\n]+\\(type\\|module\\)\\|val\\|type\\|method\\|virtual\\|constraint\\|class\\|in\\|inherit\\|initializer\\|let\\|rec\\|and\\|begin\\|object\\|end\\)\\>" + (list "\\<\\(external\\|open\\|include\\|rule\\|s\\(ig\\|truct\\)\\|module\\|functor\\|with[ \t\n]+\\(type\\|module\\)\\|val\\|type\\|method\\|virtual\\|constraint\\|class\\|in\\|inherit\\|initializer\\|let\\|lwt\\|rec\\|and\\|begin\\|object\\|end\\)\\>" 0 'tuareg-font-lock-governing-face nil nil)) (if tuareg-support-metaocaml (list (list "\\.<\\|>\\.\\|\\.~\\|\\.!" @@ -1152,19 +1153,19 @@ Special keys for Tuareg mode:\\{tuareg-mode-map}" (list (list "\\<\\(false\\|true\\)\\>" 0 'font-lock-constant-face nil nil) - (list "\\<\\(as\\|do\\(ne\\|wnto\\)?\\|else\\|for\\|if\\|m\\(atch\\|utable\\)\\|new\\|p\\(arser\\|rivate\\)\\|t\\(hen\\|o\\|ry\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|lazy\\|exception\\|raise\\|failwith\\|exit\\|assert\\|fun\\(ction\\)?\\)\\>" + (list "\\<\\(raise_lwt\\|as\\|do\\(ne\\|wnto\\)?\\|else\\|for\\(_lwt\\)?\\|if\\|m\\(atch\\|utable\\)\\|new\\|p\\(arser\\|rivate\\)\\|t\\(hen\\|o\\|ry\\(_lwt\\)?\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|lazy\\|exception\\|raise\\|failwith\\|exit\\|assert\\|fun\\(ction\\)?\\|finally\\)\\>" 0 'font-lock-keyword-face nil nil) (list "[][;,()|{}]\\|[@^!:*=<>&/%+~?#---]\\.?\\|\\.\\.\\.*\\|\\<\\(asr\\|asl\\|lsr\\|lsl\\|l?or\\|l?and\\|xor\\|not\\|mod\\|of\\|ref\\)\\>" 0 'tuareg-font-lock-operator-face nil nil) - (list (concat "\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(['_" tuareg-lower "]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)") + (list (concat "\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\|lwt\\)\\>[ \t\n]*\\(['_" tuareg-lower "]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)") 8 'font-lock-function-name-face 'keep nil) (list "\\[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" 3 'font-lock-function-name-face 'keep nil) (list "\\<\\(fun\\(ction\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_ \t()*,]\\)+\\)" 3 'font-lock-variable-name-face 'keep nil) - (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" + (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\|lwt\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" 4 'font-lock-variable-name-face 'keep nil) - (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" + (list "\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\|lwt\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" 6 'font-lock-variable-name-face 'keep nil) (list "\\<\\(open\\|\\(class\\([ \t\n]+type\\)?\\)\\([ \t\n]+virtual\\)?\\|inherit\\|include\\|module\\([ \t\n]+\\(type\\|rec\\)\\)?\\|type\\)\\>[ \t\n]*\\(['~?]*\\([_--->.* \t]\\|\\w\\|(['~?]*\\([_--->.,* \t]\\|\\w\\)*)\\)*\\)" 7 'font-lock-type-face 'keep nil) @@ -1279,7 +1280,7 @@ possible." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Indentation stuff -(defconst tuareg-keyword-regexp "\\<\\(object\\|initializer\\|and\\|c\\(onstraint\\|lass\\)\\|m\\(atch\\|odule\\|ethod\\|utable\\)\\|s\\(ig\\|truct\\)\\|begin\\|e\\(lse\\|x\\(ception\\|ternal\\)\\)\\|t\\(o\\|hen\\|ry\\|ype\\)\\|v\\(irtual\\|al\\)\\|w\\(h\\(ile\\|en\\)\\|ith\\)\\|i\\(f\\|n\\(herit\\)?\\)\\|f\\(or\\|un\\(ct\\(or\\|ion\\)\\)?\\)\\|let\\|do\\(wnto\\)?\\|parser?\\|rule\\|of\\)\\>\\|->\\|[;,|]" +(defconst tuareg-keyword-regexp "\\<\\(object\\|initializer\\|and\\|c\\(onstraint\\|lass\\)\\|m\\(atch\\|odule\\|ethod\\|utable\\)\\|s\\(ig\\|truct\\)\\|begin\\|e\\(lse\\|x\\(ception\\|ternal\\)\\)\\|t\\(o\\|hen\\|ry\\(_lwt\\)?\\|ype\\)\\|v\\(irtual\\|al\\)\\|w\\(h\\(ile\\|en\\)\\|ith\\)\\|i\\(f\\|n\\(herit\\)?\\)\\|f\\(inally\\|or\\(_lwt\\)?\\|un\\(ct\\(or\\|ion\\)\\)?\\)\\|l\\(e\\|w\\)t\\|do\\(wnto\\)?\\|parser?\\|rule\\|of\\)\\>\\|->\\|[;,|]" "Regexp for all recognized keywords.") (defconst tuareg-match-|-keyword-regexp @@ -1298,11 +1299,11 @@ considered as a special keyword.") "Regexp matching Caml keywords which act as end block delimiters.") (defconst tuareg-leading-kwop-regexp - (concat tuareg-matching-keyword-regexp "\\|\\\\|[|>]?\\]\\|>?}\\|[|)]\\|;;") + (concat tuareg-matching-keyword-regexp "\\|\\<\\(with\\|finally\\)\\>\\|[|>]?\\]\\|>?}\\|[|)]\\|;;") "Regexp matching Caml keywords which need special indentation.") (defconst tuareg-governing-phrase-regexp - "\\<\\(val\\|type\\|m\\(ethod\\|odule\\)\\|c\\(onstraint\\|lass\\)\\|in\\(herit\\|itializer\\)\\|ex\\(ternal\\|ception\\)\\|open\\|let\\|object\\|include\\)\\>" + "\\<\\(val\\|type\\|m\\(ethod\\|odule\\)\\|c\\(onstraint\\|lass\\)\\|in\\(herit\\|itializer\\)\\|ex\\(ternal\\|ception\\)\\|open\\|l\\(e\\|w\\)t\\|object\\|include\\)\\>" "Regexp matching tuareg phrase delimitors.") (defconst tuareg-governing-phrase-regexp-with-break @@ -1318,6 +1319,7 @@ considered as a special keyword.") ("begin" . tuareg-begin-indent) (".<" . tuareg-begin-indent) ("for" . tuareg-for-while-indent) + ("for_lwt" . tuareg-for-while-indent) ("while" . tuareg-for-while-indent) ("do" . tuareg-do-indent) ("type" . tuareg-type-indent) ; in some cases, `type' acts like a match @@ -1327,8 +1329,10 @@ considered as a special keyword.") ("then" . tuareg-if-then-else-indent) ("else" . tuareg-if-then-else-indent) ("let" . tuareg-let-indent) + ("lwt" . tuareg-let-indent) ("match" . tuareg-match-indent) ("try" . tuareg-try-indent) + ("try_lwt" . tuareg-try-indent) ("rule" . tuareg-rule-indent) ;; Case match keywords @@ -1338,6 +1342,7 @@ considered as a special keyword.") ("parser" . tuareg-parser-indent) ;; Default indentation keywords + ("finally" . tuareg-default-indent) ("when" . tuareg-default-indent) ("functor" . tuareg-default-indent) ("exception" . tuareg-default-indent) @@ -1372,6 +1377,7 @@ considered as a special keyword.") ("done" . tuareg-find-done-match) ("in" . tuareg-find-in-match) ("with" . tuareg-find-with-match) + ("finally" . tuareg-find-finally-match) ("else" . tuareg-find-else-match) ("then" . tuareg-find-match) ("do" . tuareg-find-do-match) @@ -1400,7 +1406,7 @@ Returns the actual text of the word, if found." (defconst tuareg-find-kwop-regexp (concat tuareg-matching-keyword-regexp - "\\|\\<\\(for\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|object\\)\\>\\|[][(){}]\\|\\*)")) + "\\|\\<\\(for\\(_lwt\\)?\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|object\\)\\>\\|[][(){}]\\|\\*)")) (defun tuareg-make-find-kwop-regexp (kwop-regexp) (concat tuareg-find-kwop-regexp "\\|" kwop-regexp)) @@ -1440,45 +1446,55 @@ If found, return the actual text of the keyword or operator." (defconst tuareg-find-,-match-regexp (tuareg-make-find-kwop-regexp - "\\<\\(and\\|match\\|begin\\|else\\|exception\\|then\\|try\\|with\\|or\\|fun\\|function\\|let\\|do\\)\\>\\|->\\|[[{(]")) + "\\<\\(and\\|match\\|begin\\|else\\|exception\\|then\\|try\\(_lwt\\)?\\|with\\|or\\|fun\\|function\\|l\\(e\\|w\\)t\\|do\\)\\>\\|->\\|[[{(]")) (defun tuareg-find-,-match () (tuareg-find-kwop tuareg-find-,-match-regexp)) (defconst tuareg-find-with-match-regexp (tuareg-make-find-kwop-regexp - "\\<\\(match\\|try\\|module\\|begin\\|with\\)\\>\\|[[{(]")) + "\\<\\(match\\|try\\(_lwt\\)?\\|module\\|begin\\|with\\)\\>\\|[[{(]")) (defun tuareg-find-with-match () (let ((kwop (tuareg-find-kwop tuareg-find-with-match-regexp "\\"))) - (if (string= kwop "with") + (if (or (string= kwop "with")) (progn (tuareg-find-with-match) (tuareg-find-with-match))) kwop)) +(defun tuareg-find-finally-match () + (let ((kwop (tuareg-find-kwop tuareg-find-with-match-regexp + "\\"))) + (if (or (string= kwop "with")) + (tuareg-find-with-match)) + kwop)) + (defconst tuareg-find-in-match-regexp - (tuareg-make-find-kwop-regexp "\\")) + (tuareg-make-find-kwop-regexp "\\")) (defun tuareg-find-in-match () (let ((kwop (tuareg-find-kwop tuareg-find-in-match-regexp "\\"))) (cond ((string= kwop "and") (tuareg-find-in-match)) (t kwop)))) (defconst tuareg-find-else-match-regexp - (tuareg-make-find-kwop-regexp ";\\|->\\|\\")) + (tuareg-make-find-kwop-regexp ";\\|->\\|\\<\\(with\\|finally\\)\\>")) (defun tuareg-find-else-match () (let ((kwop (tuareg-find-kwop tuareg-find-else-match-regexp - "->\\|\\<\\(with\\|then\\)\\>"))) + "->\\|\\<\\(with\\|finally\\|then\\)\\>"))) (cond ((string= kwop "then") (tuareg-find-match)) ((string= kwop "with") (tuareg-find-with-match)) + ((string= kwop "finally") + (tuareg-find-finally-match)) ((string= kwop "->") (setq kwop (tuareg-find-->-match)) (while (string= kwop "|") (setq kwop (tuareg-find-|-match))) - (if (string= kwop "with") - (tuareg-find-with-match)) + (cond + ((string= kwop "with") (tuareg-find-with-match)) + ((string= kwop "finally") (tuareg-find-finally-match))) (tuareg-find-else-match)) ((string= kwop ";") (tuareg-find-semi-colon-match) @@ -1497,7 +1513,7 @@ If found, return the actual text of the keyword or operator." (tuareg-find-do-match) kwop))) (defconst tuareg-find-and-match-regexp - "\\<\\(do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|then\\|\\(down\\)?to\\)\\>\\|\\<\\(for\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|class\\)\\>\\|[][(){}]\\|\\*)\\|\\<\\(rule\\|exception\\|let\\|in\\|type\\|val\\|module\\)\\>") + "\\<\\(do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|then\\|\\(down\\)?to\\)\\>\\|\\<\\(for\\(_lwt\\)\\|while\\|do\\|if\\|begin\\|s\\(ig\\|truct\\)\\|class\\)\\>\\|[][(){}]\\|\\*)\\|\\<\\(rule\\|exception\\|l\\(e\\|w\\)t\\|in\\|type\\|val\\|module\\)\\>") (defconst tuareg-find-and-match-regexp-dnr (concat tuareg-find-and-match-regexp "\\|\\")) (defun tuareg-find-and-match (&optional do-not-recurse) @@ -1519,7 +1535,7 @@ If found, return the actual text of the keyword or operator." (t kwop)))) (defconst tuareg-find-=-match-regexp - (tuareg-make-find-kwop-regexp "\\<\\(val\\|let\\|m\\(ethod\\|odule\\)\\|type\\|class\\|when\\|i[fn]\\)\\>\\|=")) + (tuareg-make-find-kwop-regexp "\\<\\(val\\|l\\(e\\\|w\\)t\\|m\\(ethod\\|odule\\)\\|type\\|class\\|when\\|i[fn]\\)\\>\\|=")) (defun tuareg-find-=-match () (let ((kwop (tuareg-find-kwop tuareg-find-=-match-regexp "\\<\\(and\\|in\\)\\>\\|="))) @@ -1542,7 +1558,7 @@ If found, return the actual text of the keyword or operator." (defun tuareg-captive-= () (save-excursion (tuareg-find-=-match) - (looking-at "\\<\\(let\\|if\\|when\\|module\\|type\\|class\\)\\>"))) + (looking-at "\\<\\(l\\(e\\|w\\)t\\|if\\|when\\|module\\|type\\|class\\)\\>"))) (defconst tuareg-find-|-match-regexp (tuareg-make-find-kwop-regexp @@ -1575,7 +1591,7 @@ If found, return the actual text of the keyword or operator." (t kwop)))) (defconst tuareg-find-->-match-regexp - (tuareg-make-find-kwop-regexp "\\<\\(external\\|val\\|method\\|let\\|with\\|fun\\(ction\\|ctor\\)?\\|parser\\)\\>\\|[|:;]")) + (tuareg-make-find-kwop-regexp "\\<\\(external\\|val\\|method\\|l\\(e\\|w\\)t\\|with\\|fun\\(ction\\|ctor\\)?\\|parser\\)\\>\\|[|:;]")) (defun tuareg-find-->-match () (let ((kwop (tuareg-find-kwop tuareg-find-->-match-regexp "\\"))) (cond @@ -1600,7 +1616,7 @@ If found, return the actual text of the keyword or operator." kwop))))))) (defconst tuareg-find-semi-colon-match-regexp - (tuareg-make-find-kwop-regexp ";[ \t]*\\((\\*\\|$\\)\\|->\\|\\<\\(let\\|method\\|with\\|try\\|initializer\\)\\>")) + (tuareg-make-find-kwop-regexp ";[ \t]*\\((\\*\\|$\\)\\|->\\|\\<\\(l\\(e\\|w\\)t\\|method\\|with\\|finally\\|try\\(_lwt\\)?\\|initializer\\)\\>")) (defun tuareg-find-semi-colon-match (&optional leading-semi-colon) (tuareg-find-kwop tuareg-find-semi-colon-match-regexp "\\<\\(in\\|end\\|and\\|do\\|with\\)\\>") @@ -1644,7 +1660,7 @@ If found, return the actual text of the keyword or operator." (tuareg-find-in-match) (tuareg-back-to-paren-or-indentation) (+ (current-column) tuareg-in-indent)) - ((looking-at "\\") + ((looking-at "\\") (+ (current-column) tuareg-let-indent)) (t (tuareg-back-to-paren-or-indentation t) (+ (current-column) tuareg-default-indent)))) @@ -1660,7 +1676,7 @@ If found, return the actual text of the keyword or operator." (if (and (looking-at "\\<\\(type\\|module\\)\\>") (> (point) (point-min)) (save-excursion (tuareg-find-meaningful-word) - (looking-at "\\<\\(module\\|with\\|and\\|let\\)\\>"))) + (looking-at "\\<\\(module\\|with\\|and\\|l\\(e\\|w\\)t\\)\\>"))) (progn (tuareg-find-meaningful-word) (+ (current-column) tuareg-default-indent)) @@ -1669,7 +1685,7 @@ If found, return the actual text of the keyword or operator." (if phrase-break tuareg-find-phrase-indentation-regexp-pb tuareg-find-phrase-indentation-regexp) - "\\<\\(end\\|and\\|with\\|in\\)\\>")) + "\\<\\(end\\|and\\|with\\|finally\\|in\\)\\>")) (tmpkwop nil) (curr nil)) (if (and kwop (string= kwop "and")) (setq kwop (tuareg-find-and-match))) @@ -1698,7 +1714,7 @@ If found, return the actual text of the keyword or operator." (if (string= tmpkwop "and") (setq tmpkwop (tuareg-find-and-match))) (setq curr (point)) - (and (string= tmpkwop "let") + (and (or (string= tmpkwop "let") (string= tmpkwop "lwt")) (not (tuareg-looking-at-expression-let)))))) (goto-char curr) (tuareg-find-phrase-indentation phrase-break)) @@ -1706,12 +1722,14 @@ If found, return the actual text of the keyword or operator." (end-of-line) (tuareg-skip-blank-and-comments) (current-column)) - ((string= kwop "let") + ((or (string= tmpkwop "let") (string= tmpkwop "lwt")) (if (tuareg-looking-at-expression-let) (tuareg-find-phrase-indentation phrase-break) (current-column))) ((string= kwop "with") (current-column)) + ((string= kwop "finally") + (current-column)) ((string= kwop "end") (current-column)) ((string= kwop "in") @@ -1765,12 +1783,12 @@ Returns t iff skipped to indentation." (if forward-in tuareg-back-to-paren-or-indentation-in-regexp tuareg-back-to-paren-or-indentation-regexp)) - "\\")) + "\\")) (retval)) - (if (string= kwop "with") + (if (or (string= kwop "with") (string= kwop "finally")) (let ((with-point (point))) (setq kwop (tuareg-find-with-match)) - (if (or (string= kwop "match") (string= kwop "try")) + (if (or (string= kwop "match") (string= kwop "try") (string= kwop "try_lwt")) (tuareg-find-kwop tuareg-back-to-paren-or-indentation-regexp "\\") @@ -1778,6 +1796,7 @@ Returns t iff skipped to indentation." (setq retval (cond ((string= kwop "with") nil) + ((string= kwop "finally") nil) ((string= kwop "in") (tuareg-in-indentation-p)) ((looking-at "[[{(]") (tuareg-search-forward-paren) nil) ((looking-at "\\.<") @@ -1792,7 +1811,7 @@ Returns t iff skipped to indentation." ((and forward-in (string= kwop "in")) (tuareg-find-in-match) (tuareg-back-to-paren-or-indentation forward-in) - (if (looking-at "\\<\\(let\\|and\\)\\>") + (if (looking-at "\\<\\(l\\(e\\|w\\)t\\|and\\)\\>") (forward-char tuareg-in-indent)) nil) (t retval))))) @@ -1993,7 +2012,7 @@ Returns t iff skipped to indentation." (+ tuareg-type-indent tuareg-|-extra-unindent)))) ((looking-at - "\\<\\(val\\|let\\|m\\(ethod\\|odule\\)\\|class\\|when\\|\\|for\\|if\\)\\>") + "\\<\\(val\\|l\\(e\\|w\\)t\\|m\\(ethod\\|odule\\)\\|class\\|when\\|\\|for\\|if\\)\\>") (let ((matched-string (tuareg-match-string 0))) (tuareg-back-to-paren-or-indentation t) (setq current-column-module-type (current-column)) @@ -2020,12 +2039,12 @@ Returns t iff skipped to indentation." (not (and tuareg-support-metaocaml (looking-at "\\.") (char-equal ?> (preceding-char)))) - (or (looking-at "[[({;=]\\|\\<\\(begin\\|i[fn]\\|do\\|t\\(ry\\|hen\\)\\|else\\|match\\|wh\\(ile\\|en\\)\\)\\>") + (or (looking-at "[[({;=]\\|\\<\\(begin\\|i[fn]\\|do\\|t\\(ry\\(_lwt\\)?\\|hen\\)\\|else\\|match\\|wh\\(ile\\|en\\)\\)\\>") (looking-at tuareg-operator-regexp))))) (defun tuareg-looking-at-false-module () (save-excursion (tuareg-find-meaningful-word) - (looking-at "\\<\\(let\\|with\\|and\\)\\>"))) + (looking-at "\\<\\(l\\(e\\|w\\)t\\|with\\|and\\)\\>"))) (defun tuareg-looking-at-false-sig-struct () (save-excursion (tuareg-find-module) @@ -2109,7 +2128,7 @@ Compute new indentation based on Caml syntax." (t (current-column)))) ((tuareg-in-literal-p) (current-column)) - ((looking-at "\\") + ((looking-at "\\") (if (tuareg-looking-at-expression-let) (if (tuareg-looking-at-in-let) (progn @@ -2339,7 +2358,7 @@ by |, insert one |." (tuareg-beginning-of-literal-or-comment) (skip-chars-backward " \t\n"))) (defconst tuareg-beginning-phrase-regexp - "^#[ \t]*[a-z][_a-z]*\\>\\|\\<\\(end\\|type\\|module\\|sig\\|struct\\|class\\|exception\\|open\\|let\\)\\>\\|;;" + "^#[ \t]*[a-z][_a-z]*\\>\\|\\<\\(end\\|type\\|module\\|sig\\|struct\\|class\\|exception\\|open\\|l\\(e\\|w\\)t\\)\\>\\|;;" "Regexp matching tuareg phrase delimitors.") (defun tuareg-find-phrase-beginning () "Find `real' phrase beginning and return point." @@ -2351,7 +2370,7 @@ by |, insert one |." (tuareg-find-kwop tuareg-beginning-phrase-regexp) (while (and (> (point) (point-min)) (< (point) old-point) (or (not (looking-at tuareg-beginning-phrase-regexp)) - (and (looking-at "\\") + (and (looking-at "\\") (tuareg-looking-at-expression-let)) (and (looking-at "\\") (tuareg-looking-at-false-module)) @@ -3280,7 +3299,7 @@ current phrase else insert a newline and indent." ;; Designed from original code by M. Quercia (defconst tuareg-definitions-regexp - "\\<\\(and\\|val\\|type\\|module\\|class\\|exception\\|let\\)\\>" + "\\<\\(and\\|val\\|type\\|module\\|class\\|exception\\|l\\(e\\|w\\)t\\)\\>" "Regexp matching definition phrases.") (defconst tuareg-definitions-bind-skip-regexp lwt-2.5.2/utils/tuareg-2.0.4.patch000066400000000000000000000565151270742521300164540ustar00rootroot00000000000000--- tuareg-2.0.4/tuareg.el 2010-11-14 15:22:06.000000000 +0100 +++ tuareg-2.0.4-lwt/tuareg.el 2012-05-09 18:02:04.811798035 +0200 @@ -1046,7 +1046,7 @@ '("module" "class" "functor" "object" "type" "val" "inherit" "include" "virtual" "constraint" "exception" "external" "open" "method" "and" "initializer" "to" "downto" "do" "done" "else" - "begin" "end" "let" "in" "then" "with")) + "begin" "end" "let" "lwt" "in" "then" "with")) (setq abbrevs-changed nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1174,39 +1174,39 @@ (setq tuareg-font-lock-keywords `(,@(and (tuareg-editing-ls3) - '(("\\<\\(let[ \t\n]+\\(clock\\|node\\|static\\)\\|present\\|automaton\\|where\\|match\\|with\\|do\\|done\\|unless\\|until\\|reset\\|every\\)\\>" + '(("\\<\\(let[ \t\n]+\\(clock\\|node\\|static\\)\\|present\\|automaton\\|where\\|match\\|match_lwt\\|with\\|do\\|done\\|unless\\|until\\|reset\\|every\\)\\>" 0 tuareg-font-lock-governing-face nil nil))) - ("\\<\\(external\\|open\\|include\\|rule\\|s\\(ig\\|truct\\)\\|module\\|functor\\|with[ \t\n]+\\(type\\|module\\)\\|val\\|type\\|method\\|virtual\\|constraint\\|class\\|in\\|inherit\\|initializer\\|let\\|rec\\|object\\|and\\|begin\\|end\\)\\>" + ("\\<\\(external\\|open\\|include\\|rule\\|s\\(ig\\|truct\\)\\|module\\|functor\\|with[ \t\n]+\\(type\\|module\\)\\|val\\|type\\|method\\|virtual\\|constraint\\|class\\|in\\|inherit\\|initializer\\|let\\|lwt\\|rec\\|object\\|and\\|begin\\|end\\)\\>" 0 tuareg-font-lock-governing-face nil nil) ,@(and tuareg-support-metaocaml '(("\\.<\\|>\\.\\|\\.~\\|\\.!" 0 tuareg-font-lock-multistage-face nil nil))) ("\\<\\(false\\|true\\)\\>" 0 font-lock-constant-face nil nil) - ("\\<\\(as\\|do\\(ne\\|wnto\\)?\\|else\\|for\\|if\\|mutable\\|new\\|p\\(arser\\|rivate\\)\\|t\\(hen\\|o\\|ry\\)\\|wh\\(en\\|ile\\)\\|match\\|with\\|lazy\\|exception\\|raise\\|failwith[f]?\\|exit\\|assert\\|fun\\(ction\\)?\\)\\>" + ("\\<\\(as\\|do\\(ne\\|wnto\\)?\\|else\\|for\\|for_lwt\\|if\\|mutable\\|new\\|p\\(arser\\|rivate\\)\\|t\\(hen\\|o\\|ry\\)\\|try_lwt\\|finally\\|raise_lwt\\|assert_lwt\\|wh\\(en\\|ile\\)\\|match\\|match_lwt\\|with\\|lazy\\|exception\\|raise\\|failwith[f]?\\|exit\\|assert\\|fun\\(ction\\)?\\)\\>" 0 font-lock-keyword-face nil nil) ,@(if (tuareg-editing-ls3) '(("\\<\\(merge\\|when\\|emit\\|period\\)\\>" 0 font-lock-keyword-face nil nil) ("[][;,()|{}]\\|[@^!:*=<>&/%+~?#---]\\.?\\|\\.\\.\\.*\\|\\<\\(asr\\|asl\\|lsr\\|lsl\\|l?or\\|l?and\\|lxor\\|l?not\\|mod\\|of\\|ref\\|fby\\|pre\\|last\\|at\\)\\>" 0 tuareg-font-lock-operator-face nil nil) - ("\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+\\(rec\\|clock\\|node\\|static\\)\\)?\\)\\>[ \t\n]*\\(['_[:lower:]]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)" + ("\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\|lwt\\([ \t\n]+\\(rec\\|clock\\|node\\|static\\)\\)?\\)\\>[ \t\n]*\\(['_[:lower:]]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)" 9 font-lock-function-name-face keep nil)) '(("[][;,()|{}]\\|[@^!:*=<>&/%+~?#---]\\.?\\|\\.\\.\\.*\\|\\<\\(asr\\|asl\\|lsr\\|lsl\\|l?or\\|l?and\\|lxor\\|l?not\\|mod\\|of\\|ref\\)\\>" 0 tuareg-font-lock-operator-face nil nil) - ("\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(['_[:lower:]]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)" + ("\\<\\(\\(method\\([ \t\n]+\\(private\\|virtual\\)\\)?\\)\\([ \t\n]+virtual\\)?\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\|lwt\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(['_[:lower:]]\\(\\w\\|[._]\\)*\\)\\>[ \t\n]*\\(\\(\\w\\|[()_?~.'*:--->]\\)+\\|=[ \t\n]*fun\\(ction\\)?\\>\\)" 8 font-lock-function-name-face keep nil))) ("\\[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" 3 font-lock-function-name-face keep nil) ("\\<\\(fun\\(ction\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_ \t()*,]\\)+\\)" 3 font-lock-variable-name-face keep nil) ,@(if (tuareg-editing-ls3) - '(("\\<\\(reset\\|do\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" + '(("\\<\\(reset\\|do\\|val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\|lwt\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" 4 font-lock-variable-name-face keep nil) - ("\\<\\(reset\\|do\\|val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\([ \t\n]+\\(rec\\|clock\\|node\\|static\\)\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" + ("\\<\\(reset\\|do\\|val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\|lwt\\([ \t\n]+\\(rec\\|clock\\|node\\|static\\)\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" 7 font-lock-variable-name-face keep nil)) - '(("\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" + '(("\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|and\\|class\\|let\\|lwt\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)" 4 font-lock-variable-name-face keep nil) - ("\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" + ("\\<\\(val\\([ \t\n]+mutable\\)?\\|external\\|method\\|and\\|class\\|let\\|lwt\\([ \t\n]+rec\\)?\\)\\>[ \t\n]*\\(\\(\\w\\|[_,?~.]\\)*\\)\\>\\(\\(\\w\\|[->_ \t,?~.]\\|(\\(\\w\\|[--->_ \t,?~.=]\\)*)\\)*\\)" 6 font-lock-variable-name-face keep nil))) ( "\\<\\(open\\|\\(class\\([ \t\n]+type\\)?\\)\\([ \t\n]+virtual\\)?\\|inherit\\|include\\|module\\([ \t\n]+\\(type\\|rec\\)\\)?\\|type\\)\\>[ \t\n]*\\(['~?]*\\([_--->.* \t]\\|\\w\\|(['~?]*\\([_--->.,* \t]\\|\\w\\)*)\\)*\\)" 7 font-lock-type-face keep nil) @@ -1347,7 +1347,8 @@ "else" "exception" "external" "to" "then" "try" "type" "virtual" "val" "while" "when" "with" "if" "in" "inherit" "for" "fun" "functor" "function" "let" "do" "downto" - "parse" "parser" "rule" "of") + "parse" "parser" "rule" "of" + "lwt" "match_lwt" "try_lwt" "for_lwt" "while_lwt" "finally") "\\|->\\|[;,|]") "Regexp for all recognized keywords.") @@ -1405,7 +1406,7 @@ (defconst tuareg-matching-kwop-regexp (concat tuareg-matching-keyword-regexp - "\\|\\\\|[|>]?\\]\\|>?}\\|[|)]\\|;;") + "\\|\\<\\(with\\|finally\\)\\>\\|[|>]?\\]\\|>?}\\|[|)]\\|;;") "Regexp matching Caml keywords or operators which act as end block delimiters.") (defconst tuareg-matching-kwop-regexp-ls3 @@ -1419,7 +1420,7 @@ tuareg-matching-kwop-regexp)) (defconst tuareg-block-regexp - (concat (tuareg-ro "for" "while" "do" "if" "begin" "sig" "struct" "object") + (concat (tuareg-ro "for" "for_lwt" "while" "while_lwt" "do" "if" "begin" "sig" "struct" "object") "\\|[][(){}]\\|\\*)")) (defconst tuareg-find-kwop-regexp @@ -1427,7 +1428,7 @@ (defconst tuareg-find-kwop-regexp-ls3 (concat tuareg-find-kwop-regexp "\\|" - (tuareg-ro "where" "automaton" "present" "match"))) + (tuareg-ro "where" "automaton" "present" "match" "match_lwt"))) (defun tuareg-give-find-kwop-regexp () (if (tuareg-editing-ls3) @@ -1436,7 +1437,7 @@ (defconst tuareg-governing-phrase-regexp (tuareg-ro "val" "type" "method" "module" "constraint" "class" "inherit" - "initializer" "external" "exception" "open" "let" "object" + "initializer" "external" "exception" "open" "let" "lwt" "object" "include") "Regexp matching tuareg phrase delimitors.") @@ -1450,7 +1451,9 @@ ("begin" . tuareg-begin-indent) (".<" . tuareg-begin-indent) ("for" . tuareg-for-while-indent) + ("for_lwt" . tuareg-for-while-indent) ("while" . tuareg-for-while-indent) + ("while_lwt" . tuareg-for-while-indent) ("do" . tuareg-do-indent) ("val" . tuareg-val-indent) ("fun" . tuareg-fun-indent) @@ -1458,8 +1461,12 @@ ("then" . tuareg-if-then-else-indent) ("else" . tuareg-if-then-else-indent) ("let" . tuareg-let-indent) + ("lwt" . tuareg-let-indent) ("match" . tuareg-match-indent) + ("match_lwt" . tuareg-match-indent) ("try" . tuareg-try-indent) + ("try_lwt" . tuareg-try-indent) + ("finally" . tuareg-try-indent) ("rule" . tuareg-rule-indent) ;; Case match keywords @@ -1492,6 +1499,7 @@ ("in" . tuareg-find-in-match) ("where" . tuareg-find-in-match) ("with" . tuareg-find-with-match) + ("finally" . tuareg-find-with-match) ("else" . tuareg-find-else-match) ("then" . tuareg-find-then-match) ("do" . tuareg-find-do-match) @@ -1503,7 +1511,7 @@ (defun tuareg-find-leading-kwop-match (kwop) (funcall (cdr (assoc kwop tuareg-leading-kwop-alist)))) -(defconst tuareg-binding-regexp "\\(\\\\|(*\\\\)") +(defconst tuareg-binding-regexp "\\(\\\\|(*\\\\|(*\\\\)") (defun tuareg-assoc-indent (kwop &optional look-for-let-or-and) "Return relative indentation of the keyword given in argument." @@ -1577,11 +1585,12 @@ (defconst tuareg-find-and-match-regexp (concat (tuareg-ro "do" "done" "else" "end" "in" "then" "down" "downto" "for" "while" "do" "if" "begin" "sig" "struct" "class" - "rule" "exception" "let" "in" "type" "val" "module") + "rule" "exception" "let" "in" "type" "val" "module" + "lwt" "try_lwt" "for_lwt" "while_lwt" "finally") "\\|[][(){}]\\|\\*)")) (defconst tuareg-find-phrase-beginning-regexp (concat (tuareg-ro "end" "type" "module" "sig" "struct" "class" - "exception" "open" "let") + "exception" "open" "let" "lwt") "\\|^#[ \t]*[a-z][_a-z]*\\>\\|;;")) (defconst tuareg-find-phrase-beginning-and-regexp (concat "\\<\\(and\\)\\>\\|" tuareg-find-phrase-beginning-regexp)) @@ -1604,35 +1613,35 @@ (setq tuareg-find-comma-match-regexp (tuareg-make-find-kwop-regexp - (concat (tuareg-ro "and" "match" "begin" "else" "exception" "then" "try" - "with" "or" "fun" "function" "let" "do") + (concat (tuareg-ro "and" "match" "match_lwt" "begin" "else" "exception" "then" "try" "try_lwt" + "with" "or" "fun" "function" "let" "lwt" "do" "finally") "\\|->\\|[[{(]")) tuareg-find-with-match-regexp (tuareg-make-find-kwop-regexp - (concat (tuareg-ro "match" "try" "module" "begin" "with" "type") + (concat (tuareg-ro "match" "match_lwt" "try" "try_lwt" "module" "begin" "with" "type" "finally") "\\|[[{(]")) tuareg-find-in-match-regexp - (tuareg-make-find-kwop-regexp (tuareg-ro "let" "open")) + (tuareg-make-find-kwop-regexp (tuareg-ro "let" "lwt" "open")) tuareg-find-else-match-regexp (tuareg-make-find-kwop-regexp ";") tuareg-find-do-match-regexp (tuareg-make-find-kwop-regexp "->") tuareg-find-=-match-regexp (tuareg-make-find-kwop-regexp - (concat (tuareg-ro "val" "let" "method" "module" "type" "class" "when" + (concat (tuareg-ro "val" "let" "lwt" "method" "module" "type" "class" "when" "if" "in" "do") "\\|=")) tuareg-find-pipe-match-regexp (tuareg-make-find-kwop-regexp (tuareg-give-match-pipe-kwop-regexp)) tuareg-find-arrow-match-regexp (tuareg-make-find-kwop-regexp - (concat (tuareg-ro "external" "type" "val" "method" "let" "with" "fun" + (concat (tuareg-ro "external" "type" "val" "method" "let" "lwt" "with" "fun" "function" "functor" "class" "parser") "\\|[|;]")) tuareg-find-semicolon-match-regexp (tuareg-make-find-kwop-regexp (concat ";" tuareg-no-more-code-this-line-regexp "\\|->\\|" - (tuareg-ro "let" "method" "with" "try" "initializer"))) + (tuareg-ro "let" "lwt" "method" "with" "try" "try_lwt" "initializer" "finally"))) tuareg-find-phrase-indentation-regexp (tuareg-make-find-kwop-regexp (concat tuareg-governing-phrase-regexp "\\|" (tuareg-ro "and" "every"))) @@ -1651,7 +1660,7 @@ (concat tuareg-find-comma-match-regexp "\\|=") tuareg-find-monadic-match-regexp (concat tuareg-block-regexp "\\|\\([;=]\\)\\|\\(->\\)\\|" - (tuareg-ro "val" "let" "method" "module" "type" "class" "when" + (tuareg-ro "val" "let" "lwt" "method" "module" "type" "class" "when" "if" "in" "do" "done" "end")))) (defun tuareg-strip-trailing-whitespace (string) @@ -1838,7 +1847,8 @@ ((string= kwop2 "and") (tuareg-find-and-match)) ((and (string= kwop "module") - (string= kwop2 "let")) + (or (string= kwop2 "let") + (string= kwop2 "lwt"))) kwop2) (t (goto-char old-point) kwop)))) (t kwop)))) @@ -1873,7 +1883,7 @@ (looking-at tuareg-if-when-regexp))) (defconst tuareg-captive-regexp - (tuareg-ro "let" "if" "when" "module" "type" "class")) + (tuareg-ro "let" "lwt" "if" "when" "module" "type" "class")) (defun tuareg-captive-= () (save-excursion (tuareg-find-=-match) @@ -1955,7 +1965,7 @@ kwop))))))) (defconst tuareg-semicolon-match-stop-regexp - (tuareg-ro "and" "do" "end" "in" "with")) + (tuareg-ro "and" "do" "end" "in" "with" "finally")) (defconst tuareg-no-code-after-paren-regexp (tuareg-no-code-after "[[{(][|<]?")) (defun tuareg-semicolon-indent-kwop-point (&optional leading-semi-colon) @@ -2004,11 +2014,14 @@ ((string= kwop "where") (tuareg-find-in-match) (+ (tuareg-paren-or-indentation-column) tuareg-in-indent)) - ((string= kwop "let") + ((or (string= kwop "let") (string= kwop "lwt")) (+ (current-column) tuareg-let-indent)) ((string= kwop "try") (forward-char 3) (skip-syntax-forward " ") (current-column)) + ((string= kwop "try_lwt") + (forward-char 7) (skip-syntax-forward " ") + (current-column)) (t (tuareg-paren-or-indentation-indent))) kwop point))) @@ -2020,7 +2033,7 @@ (setq ,kwop (tuareg-find-and-match)))) (defconst tuareg-phrase-regexp-1 (tuareg-ro "module" "type")) -(defconst tuareg-phrase-regexp-2 (tuareg-ro "and" "let" "module" "with")) +(defconst tuareg-phrase-regexp-2 (tuareg-ro "and" "let" "lwt" "module" "with")) (defconst tuareg-phrase-regexp-3 (tuareg-ro "and" "end" "every" "in" "with")) (defun tuareg-find-phrase-indentation (&optional phrase-break) @@ -2069,7 +2082,8 @@ (setq tmpkwop (tuareg-find-in-match)) (tuareg-reset-and-kwop tmpkwop) (setq curr (point)) - (and (string= tmpkwop "let") + (and (or (string= tmpkwop "let") + (string= tmpkwop "lwt")) (not (tuareg-looking-at-internal-let)))))) (goto-char curr) (tuareg-find-phrase-indentation phrase-break)) @@ -2077,7 +2091,7 @@ (end-of-line) (tuareg-skip-blank-and-comments) (current-column)) - ((string= kwop "let") + ((or (string= kwop "let") (string= kwop "lwt")) (if (tuareg-looking-at-internal-let) (tuareg-find-phrase-indentation phrase-break) (current-column))) @@ -2122,16 +2136,18 @@ tuareg-back-to-paren-or-indentation-regexp tuareg-paren-or-indentation-stop-regexp)) (retval)) - (when (string= kwop "with") + (when (or (string= kwop "with") (string= kwop "finally")) (let ((with-point (point))) (setq kwop (tuareg-find-with-match)) - (if (or (string= kwop "match") (string= kwop "try")) + (if (or (string= kwop "match") (string= kwop "match_lwt") + (string= kwop "try") (string= kwop "try_lwt")) (tuareg-find-kwop tuareg-back-to-paren-or-indentation-regexp "\\") (setq kwop "with") (goto-char with-point)))) (setq retval (cond ((string= kwop "with") nil) + ((string= kwop "finally") nil) ((or (string= kwop "in") (string= kwop "do")) (tuareg-in-indentation-p)) ; ((looking-at "[[{(]") (tuareg-search-forward-paren) nil) @@ -2166,8 +2182,8 @@ (defconst tuareg-internal-let-regexp (concat "[[({;=]\\|" - (tuareg-ro "begin" "open" "if" "in" "do" "try" "then" "else" - "match" "while" "when"))) + (tuareg-ro "begin" "open" "if" "in" "do" "try" "try_lwt" "then" "else" + "match" "match_lwt" "while" "while_lwt" "when"))) (defun tuareg-looking-at-internal-let () (save-excursion (tuareg-find-meaningful-word) @@ -2178,7 +2194,7 @@ (or (looking-at tuareg-internal-let-regexp) (looking-at tuareg-operator-regexp))))) -(defconst tuareg-false-module-regexp (tuareg-ro "and" "let" "with")) +(defconst tuareg-false-module-regexp (tuareg-ro "and" "let" "lwt" "with")) (defun tuareg-looking-at-false-module () (save-excursion (tuareg-find-meaningful-word) @@ -2302,7 +2318,9 @@ (goto-char matching-pos) (tuareg-find-arrow-match) ; matching `val' or `let' (+ (current-column) tuareg-val-indent)) - ((or (string= matching-kwop "val") (string= matching-kwop "let")) + ((or (string= matching-kwop "val") + (string= matching-kwop "let") + (string= matching-kwop "lwt")) (+ (current-column) tuareg-val-indent)) ((string= matching-kwop "|") (goto-char matching-pos) @@ -2338,7 +2356,8 @@ (tuareg-find-arrow-match) (+ (current-column) tuareg-default-indent)) ((or (string= kwop "val") - (string= kwop "let")) + (string= kwop "let") + (string= kwop "lwt")) (goto-char pos) (+ (current-column) tuareg-val-indent)) ((string= kwop "type") @@ -2409,7 +2428,8 @@ (char-equal ?\{ (preceding-char)))) (tuareg-backward-char) (tuareg-indent-from-paren t start-pos)) - ((and (looking-at "\\") (string= mkwop "in")) + ((and (or (looking-at "\\") + (looking-at "\\")) (string= mkwop "in")) (+ (current-column) tuareg-in-indent)) (t (+ (tuareg-paren-or-indentation-column) (tuareg-assoc-indent mkwop))))) @@ -2419,7 +2439,7 @@ (tuareg-indent-from-paren leading-operator start-pos) (+ tuareg-default-indent (tuareg-indent-from-paren leading-operator start-pos)))) - ((or (string= kwop "let") (string= kwop "and")) + ((or (string= kwop "let") (string= kwop "lwt") (string= kwop "and")) (tuareg-back-to-paren-or-indentation) (+ (tuareg-paren-or-indentation-indent) (tuareg-assoc-indent kwop t))) @@ -2458,13 +2478,19 @@ (+ (current-column) -3 tuareg-default-indent) (skip-syntax-forward " ") (+ (current-column) tuareg-default-indent))) + ((string= kwop "try_lwt") + (forward-char 7) + (if (looking-at tuareg-no-more-code-this-line-regexp) + (+ (current-column) -7 tuareg-default-indent) + (skip-syntax-forward " ") + (+ (current-column) tuareg-default-indent))) (t (+ (if (tuareg-in-indentation-p) (current-column) (tuareg-paren-or-indentation-indent)) (tuareg-assoc-indent kwop t))))) (defconst tuareg-=-indent-regexp-1 - (tuareg-ro "val" "let" "method" "module" "class" "when" "for" "if" "do")) + (tuareg-ro "val" "let" "lwt" "method" "module" "class" "when" "for" "for_lwt" "if" "do")) (defun tuareg-compute-=-indent (start-pos) (let ((current-column-module-type nil) (kwop1 (tuareg-find-=-match)) @@ -2510,7 +2536,7 @@ (current-column)) (defconst tuareg-definitions-regexp - (tuareg-ro "and" "val" "type" "module" "class" "exception" "let") + (tuareg-ro "and" "val" "type" "module" "class" "exception" "let" "lwt") "Regexp matching definition phrases.") (defun tuareg-compute-normal-indent () @@ -2649,7 +2675,9 @@ (string= matching-kwop "struct")) (tuareg-paren-or-indentation-indent)) ((or (string= matching-kwop "try") - (string= matching-kwop "match")) + (string= matching-kwop "try_lwt") + (string= matching-kwop "match") + (string= matching-kwop "match_lwt")) (tuareg-compute-kwop-indent-general kwop matching-kwop)) (t (goto-char old-point) (tuareg-compute-kwop-indent-general kwop matching-kwop)))) @@ -2668,6 +2696,7 @@ (and (string= kwop "end") (tuareg-editing-ls3) (or (string= matching-kwop "match") + (string= matching-kwop "match_lwt") (string= matching-kwop "automaton") (string= matching-kwop "present")))) (if (tuareg-in-indentation-p) @@ -2675,7 +2704,8 @@ (tuareg-paren-or-indentation-column))) ((string= kwop "in") (+ (current-column) - (tuareg-add-default-indent (string= matching-kwop "let")))) + (tuareg-add-default-indent (or (string= matching-kwop "let") + (string= matching-kwop "lwt"))))) ((not (string= kwop "and")) ; pretty general case (tuareg-compute-kwop-indent-general kwop matching-kwop)) ((string= matching-kwop "with") @@ -2737,7 +2767,7 @@ (t (current-column)))) ((tuareg-in-literal-p) (current-column)) - ((or (looking-at "\\") (looking-at "\\")) + ((or (looking-at "\\") (looking-at "\\") (looking-at "\\")) (if (tuareg-looking-at-internal-let) (if (tuareg-looking-at-in-let) (progn @@ -2932,7 +2962,7 @@ (tuareg-find-kwop tuareg-find-phrase-beginning-regexp)) (while (and (> (point) (point-min)) (< (point) old-point) (or (not (looking-at tuareg-find-phrase-beginning-and-regexp)) - (and (looking-at "\\") + (and (or (looking-at "\\") (looking-at "\\")) (tuareg-looking-at-internal-let)) (and (looking-at "\\") (save-excursion