syndicate-lang
/
hop-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Switch to opam for thirdparty modules such as lwt

This commit is contained in:
Tony Garnock-Jones 2013-02-26 00:40:23 -05:00
parent 0ed7be8497
commit 3fd3c5ada1
151 changed files with 8 additions and 44487 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
server/Makefile
View File

@ -2,28 +2,11 @@ APP=hop_server
TEMPLATES=$(wildcard web/bootstrap/templates/*.xml)
HTML=$(subst web/bootstrap/templates/,web/,$(subst .xml,.html,$(TEMPLATES)))
# Augment the path ocamlfind uses to discover installed packages.
OCAMLPATH=$(CURDIR)/thirdparty/_dist
export OCAMLPATH
LWT_SRC_DIR=thirdparty/lwt-2.3.2
all: \
thirdparty/_dist \
message.ml amqp_spec.ml \
$(APP).native \
webpages
thirdparty/_dist:
mkdir -p $@
(mkdir $@/lwt && \
(cd $(LWT_SRC_DIR) && \
./configure && \
make && \
OCAMLFIND_LDCONF=ignore \
OCAMLFIND_DESTDIR="$(CURDIR)/$@" \
make install))
webpages: $(HTML) web/bootstrap/css/bootstrap.css
web/bootstrap/css/bootstrap.css: web/bootstrap/less/*.less
@ -46,22 +29,17 @@ clean: webclean
rm -f message.ml
rm -f amqp_spec.ml
thirdpartyclean:
rm -rf thirdparty/_dist
rm -rf $(LWT_SRC_DIR)/_build
rm -f $(LWT_SRC_DIR)/setup.data
rm -f $(LWT_SRC_DIR)/setup.log
rm -f $(LWT_SRC_DIR)/src/unix/lwt_config.h
rm -f $(LWT_SRC_DIR)/src/unix/lwt_config.ml
veryclean: clean thirdpartyclean
veryclean: clean
rm -f web/bootstrap/css/bootstrap.css
$(APP).native: $(wildcard *.ml)
ocamlbuild -use-ocamlfind -X thirdparty -X scratch $@
$(APP).native: $(wildcard *.ml) lwt_installed
ocamlbuild -use-ocamlfind -X scratch $@
$(APP).p.native: $(wildcard *.ml)
ocamlbuild -use-ocamlfind -X thirdparty -X scratch $@
$(APP).p.native: $(wildcard *.ml) lwt_installed
ocamlbuild -use-ocamlfind -X scratch $@
lwt_installed:
opam install lwt
run: all
./$(APP).native

198
server/thirdparty/lwt-2.3.2/CHANGES vendored
View File

@ -1,198 +0,0 @@
===== 2.3.2 (2011-11-04) =====
* Add location informations in logs:
** allow loggers to get the current location through local storage
** pass current location to logging functions
** pass the current location with the syntax extension
* Add Lwt.on_termination
* Add Lwt_unix.reinstall_signal_handler
* Add Lwt_io.flush_all
* Add assert_lwt keyword to the syntax extension
* Add Lwt.wrap
* Add Lwt_glib.iter and Lwt_glib.wakeup
* ocaml 3.13 ready
* Allow to compile without libev support
* Fix bugs in Lwt_io
* Better handling of forks
* Fix many problems on Windows
===== 2.3.1 (2011-07-13) =====
* Fix building of documentation when using the tarball
* Add Lwt_unix.fsync and Lwt_unix.fdatasync
* Fix the stubs for Lwt_unix.send_msg when fd-passing is not
available
* Add -lwt-sequence-strict option to the syntax extension
* Use a custom PRNG state for Lwt.choose and Lwt.pick
* Fix a display glitch when starting the toplevel
* Add Lwt_unix.fork which should now be used when one want to use
Lwt in the child process
* Better implementation of Lwt_unix.readlink and
Lwt_unix.gethostbyname, which fixes compilation on Hurd
* Add Lwt.wakeup_later and Lwt.wakeup_later_exn to be used when one
need to do lot of nested wakeup, which fixes a buffer overflow in
Lwt_mutex
* Fix Lwt_unix.abort and Lwt_unix.close (threads was never wakeup)
* Fix Lwt_throttle for correct timings
* Fix subtle use of cancel
===== 2.3.0 (2011-04-12) =====
* Add an extensible system of engines to:
** allow the user to replace libev by another event system, such
as select
** allow easier integration of external libraries supporting
asynchronous operations
* Lots of improvements for windows:
** use the ocaml select instead of libev by default on windows
** make asynchronous operations on non-socket file descriptors
such as pipes to work
** make glib integration to work
* Better use of engines in Lwt_unix: now events are cached to minimize
the amount of calls to epoll_ctl
* Use an eventfd when possible for notifications for faster delivery
* Add modules:
** Lwt_sys: allow to test availability of extra features
** Lwt_react: replace Lwt_event and Lwt_signal
* Allow to configure logging rules at runtime in Lwt_log
* Add match_lwt and while_lwt to the syntax extension
* Fixes:
** syntax extension: handle "lwt ... = ... in ..." at toplevel
** make the notification system fork-proof
** fix an issue with stubs not raising correctly exceptions
===== 2.2.1 (2011-01-26) =====
* Better interaction with Js_of_ocaml.
* Add functions {{{Lwt.register_pause_notifier}}} and {{{Lwt.paused_count}}}.
===== 2.2.0 (2010-12-13) =====
* Bugfixes:
** Fix a bug with cancellable threads causing {{{Canceled}}}
exceptions to be raised randomly
** Fix a fd-leak in Lwt_io.open_connection
* {{{Lwt_unix}}} now use libev instead of select
* Add thread local storage support to {{{Lwt}}}
* Add backtrace support to {{{Lwt}}}. Now {{{Lwt}}} exceptions can
be recored by using the syntax extension with the {{{-lwt-debug}}}
command line switch.
* Allow blocking system calls to be executed in parallels
* Change the type of many functions of {{{Lwt_unix}}}, which now
return a {{{Lwt}}} thread
* Add functions {{{Lwt_unix.readable}}} and {{{Lwt_unix.writable}}}
* Add function {{{Lwt_io.is_busy}}}
* Add functions {{{Lwt_event.delay}}} and {{{Lwt_signal.delay}}}
* Add function {{{Lwt_term.render_update}}}
* Add function {{{Lwt_ssl.embed_socket}}}
* Add module {{{Lwt_bytes}}} defining operations on bigarrays
instead of strings
* Use bigarrays in Lwt_io instead of strings for the internal buffer.
Lwt_io.make now takes a function that uses a bigarray.
* Add module {{{Lwt_switch}}}
===== 2.1.1 (2010-06-13) =====
* Many bugfixes, including:
** buggy behaviour of cancellable threads
** file descriptor leakage in {{{Lwt_unix.accept_n}}}
* Add {{{Lwt.nchoose}}} and {{{Lwt.npick}}}
* Use {{{set_close_on_exec}}} for fds created by {{{Lwt_log}}}
* Better implementation of lwtized react functions
===== 2.1.0 (2010-04-19) =====
* Rename {{{Lwt.select}}} to {{{Lwt.pick}}}
* Removing module {{{Lwt_monitor}}} in favour of {{{Lwt_mutex}}} and
new module {{{Lwt_condition}}}
* More react helpers:
** {{{Lwt_event.next}}}
** {{{Lwt_event.limit}}} and {{{Lwt_signal.limit}}}
** {{{Lwt_event.from}}}
* Adding function {{{Lwt_main.fast_yield}}}
* Adding unit tests
* Optimisation of {{{Lwt}}}
* Adding module {{{Lwt_log}}} for logging
* Adding a camlp4 filter for remmoving logging statement or inlining
tests
* Adding module {{{Lwt_daemon}}}
* Adding function {{{Lwt_unix.recv_msg}}} and {{{Lwt_unix.send_msg}}}
* Adding function {{{Lwt_unix.wait4}}}
* Adding function {{{Lwt_io.establish_server}}}
* Adding module {{{Lwt_list}}}
* Enhancement in {{{Lwt_process}}}, it now support redirections and
timeouts
* Allow to use {{{select}}} on arbitrary high file descriptors
* More commands and features in {{{Lwt_read_line}}}:
** Handle "undo" command
** New controlable read-lines instances
** More edition commands
** Completion as you type
** Backward search
* Enhancement in {{{Lwt_term}}}: more drawing functions and allow to
put the terminal into drawing mode
* Optimisation of {{{Lwt_stream}}}
* Optimisation of {{{Lwt_io.write_char}}} and {{{Lwt_io.read_char}}}
* Bugfix of {{{Lwt_stream}}}: two parallel {{{Lwt_stream.get}}}
returned the same value
* Bugfix in {{{Lwt_unix.connect}}}: it returned immediatly on EINPROGRESS
* Bugfixes in {{{Lwt_glib}}}: file descriptors were not monitored correctly
===== 2.0.0 (2009-10-15) =====
* Adding modules:
** {{{Lwt_stream}}}: lwt-aware version of the {{{Stream}}} module
** {{{Lwt_gc}}} for using {{{finalise}}} without
{{{Lwt_unix.run}}}
** {{{Lwt_io}}}: a new implementation of buffered channels with
more features and better handling of concurrent access
** {{{Lwt_text}}}: implementation of text channels
** {{{Lwt_process}}}: helpers to spawn processes and communicate
with them
** {{{Lwt_main}}} for abstracting the main loop and allowing
replacement by a custom main loop
** {{{Lwt_glib}}} for integration into the glib main event loop
** {{{Lwt_term}}} for interaction with the terminal
** {{{Lwt_read_line}}} for interactive user input
** {{{Lwt_monitor}}}, {{{Lwt_mvar}}}: combined locks for
synchronization with conditional variables for notification
** {{{Lwt_throttle}}} for limiting rate of execution
(e.g. for authentication procedure)
** {{{Lwt_sequence}}}: mutable sequence of elements
** {{{Lwt_event}}}, {{{Lwt_signal}}}: helpers for reactive
programming with lwt
* Adding a syntax extension {{{pa_lwt}}}:
** handles anonymous bind {{{a >> b}}}
** adds syntactic sugar for catching errors (ticket #6)
** adds syntactic sugar for parallel let-binding construction
** adds syntactic sugar for for-like loops
* Top-level integration:
** threads can runs while reading user input
** line editing support
* New enhanced OCaml toplevel with some basic completion features
* Adding C stubs to reimplement {{{Unix.read}}} and {{{Unix.write}}}
with assumption of non-blocking behaviour
* Adding more functions/helpers in {{{Lwt}}}
* Fixing memory leaks in {{{Lwt.choose}}}
* Bugfix in {{{Lwt_chan.close_*}}} (ticket #66)
* Separate the type of threads (covariant) from the type of thread
wakeners (contravariant); the type of many functions related to
{{{Lwt.wait}}} has been changed
* Add cancelable threads
* Unix-dependent part is now put in its own archive and findlib
package.
===== 1.1.0 (2008-06-25) =====
* Adding module {{{Lwt_pool}}} for creating pools (for example pools
of connections)
* Adding a few functions in {{{Lwt_chan}}}
* Fixing bugs in {{{Lwt_util.map_serial}}} and
{{{Lwt_util.iter_serial}}}
* Putting {{{Lwt_preemptive}}}, {{{Lwt_lib}}} and {{{Lwt_ssl}}} in
separate libraries and findlib subpackages so that lwt.cma depends
only on unix.cma.
===== 1.0.0 (and before) =====
* See Ocsigen changelog

2248
server/thirdparty/lwt-2.3.2/CHANGES.darcs vendored
View File

File diff suppressed because it is too large Load Diff

552
server/thirdparty/lwt-2.3.2/COPYING vendored
View File

@ -1,552 +0,0 @@
This program is released under the LGPL version 2.1 (see the text below) with
the additional exemption that compiling, linking, and/or using OpenSSL is
allowed.
As a special exception to the GNU Library General Public License, you
may also link, statically or dynamically, a "work that uses the Library"
with a publicly distributed version of the Library to produce an
executable file containing portions of the Library, and distribute
that executable file under terms of your choice, without any of the
additional requirements listed in clause 6 of the GNU Library General
Public License. By "a publicly distributed version of the Library",
we mean either the unmodified Library, or a
modified version of the Library that is distributed under the
conditions defined in clause 3 of the GNU Library General Public
License. This exception does not however invalidate any other reasons
why the executable file might be covered by the GNU Library General
Public License.
Some parts, when stated (as licenced under BSD3) are licenced under
3-clauses or Modified BSD License.
GNU LESSER GENERAL PUBLIC LICENSE
Version 2.1, February 1999
Copyright (C) 1991, 1999 Free Software Foundation, Inc.
51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
[This is the first released version of the Lesser GPL. It also counts
as the successor of the GNU Library Public License, version 2, hence
the version number 2.1.]
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.
This license, the Lesser General Public License, applies to some
specially designated software packages--typically libraries--of the
Free Software Foundation and other authors who decide to use it. You
can use it too, but we suggest you first think carefully about whether
this license or the ordinary General Public License is the better
strategy to use in any particular case, based on the explanations below.
When we speak of free software, we are referring to freedom of use,
not price. Our General Public Licenses are designed to make sure that
you have the freedom to distribute copies of free software (and charge
for this service if you wish); that you receive source code or can get
it if you want it; that you can change the software and use pieces of
it in new free programs; and that you are informed that you can do
these things.
To protect your rights, we need to make restrictions that forbid
distributors to deny you these rights or to ask you to surrender these
rights. These restrictions translate to certain responsibilities for
you if you distribute copies of the library or if you modify it.
For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you. You must make sure that they, too, receive or can get the source
code. If you link other code with the library, you must provide
complete object files to the recipients, so that they can relink them
with the library after making changes to the library and recompiling
it. And you must show them these terms so they know their rights.
We protect your rights with a two-step method: (1) we copyright the
library, and (2) we offer you this license, which gives you legal
permission to copy, distribute and/or modify the library.
To protect each distributor, we want to make it very clear that
there is no warranty for the free library. Also, if the library is
modified by someone else and passed on, the recipients should know
that what they have is not the original version, so that the original
author's reputation will not be affected by problems that might be
introduced by others.
Finally, software patents pose a constant threat to the existence of
any free program. We wish to make sure that a company cannot
effectively restrict the users of a free program by obtaining a
restrictive license from a patent holder. Therefore, we insist that
any patent license obtained for a version of the library must be
consistent with the full freedom of use specified in this license.
Most GNU software, including some libraries, is covered by the
ordinary GNU General Public License. This license, the GNU Lesser
General Public License, applies to certain designated libraries, and
is quite different from the ordinary General Public License. We use
this license for certain libraries in order to permit linking those
libraries into non-free programs.
When a program is linked with a library, whether statically or using
a shared library, the combination of the two is legally speaking a
combined work, a derivative of the original library. The ordinary
General Public License therefore permits such linking only if the
entire combination fits its criteria of freedom. The Lesser General
Public License permits more lax criteria for linking other code with
the library.
We call this license the "Lesser" General Public License because it
does Less to protect the user's freedom than the ordinary General
Public License. It also provides other free software developers Less
of an advantage over competing non-free programs. These disadvantages
are the reason we use the ordinary General Public License for many
libraries. However, the Lesser license provides advantages in certain
special circumstances.
For example, on rare occasions, there may be a special need to
encourage the widest possible use of a certain library, so that it becomes
a de-facto standard. To achieve this, non-free programs must be
allowed to use the library. A more frequent case is that a free
library does the same job as widely used non-free libraries. In this
case, there is little to gain by limiting the free library to free
software only, so we use the Lesser General Public License.
In other cases, permission to use a particular library in non-free
programs enables a greater number of people to use a large body of
free software. For example, permission to use the GNU C Library in
non-free programs enables many more people to use the whole GNU
operating system, as well as its variant, the GNU/Linux operating
system.
Although the Lesser General Public License is Less protective of the
users' freedom, it does ensure that the user of a program that is
linked with the Library has the freedom and the wherewithal to run
that program using a modified version of the Library.
The precise terms and conditions for copying, distribution and
modification follow. Pay close attention to the difference between a
"work based on the library" and a "work that uses the library". The
former contains code derived from the library, whereas the latter must
be combined with the library in order to run.
GNU LESSER GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any software library or other
program which contains a notice placed by the copyright holder or
other authorized party saying it may be distributed under the terms of
this Lesser General Public License (also called "this License").
Each licensee is addressed as "you".
A "library" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.
The "Library", below, refers to any such software library or work
which has been distributed under these terms. A "work based on the
Library" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language. (Hereinafter, translation is
included without limitation in the term "modification".)
"Source code" for a work means the preferred form of the work for
making modifications to it. For a library, complete source code means
all the source code for all modules it contains, plus any associated
interface definition files, plus the scripts used to control compilation
and installation of the library.
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it). Whether that is true depends on what the Library does
and what the program that uses the Library does.
1. You may copy and distribute verbatim copies of the Library's
complete source code as you receive it, in any medium, provided that
you conspicuously and appropriately publish on each copy an
appropriate copyright notice and disclaimer of warranty; keep intact
all the notices that refer to this License and to the absence of any
warranty; and distribute a copy of this License along with the
Library.
You may charge a fee for the physical act of transferring a copy,
and you may at your option offer warranty protection in exchange for a
fee.
2. You may modify your copy or copies of the Library or any portion
of it, thus forming a work based on the Library, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) The modified work must itself be a software library.
b) You must cause the files modified to carry prominent notices
stating that you changed the files and the date of any change.
c) You must cause the whole of the work to be licensed at no
charge to all third parties under the terms of this License.
d) If a facility in the modified Library refers to a function or a
table of data to be supplied by an application program that uses
the facility, other than as an argument passed when the facility
is invoked, then you must make a good faith effort to ensure that,
in the event an application does not supply such function or
table, the facility still operates, and performs whatever part of
its purpose remains meaningful.
(For example, a function in a library to compute square roots has
a purpose that is entirely well-defined independent of the
application. Therefore, Subsection 2d requires that any
application-supplied function or table used by this function must
be optional: if the application does not supply it, the square
root function must still compute square roots.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Library,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Library, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote
it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Library.
In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library. To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License. (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.) Do not make any other change in
these notices.
Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.
This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.
4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you accompany
it with the complete corresponding machine-readable source code, which
must be distributed under the terms of Sections 1 and 2 above on a
medium customarily used for software interchange.
If distribution of object code is made by offering access to copy
from a designated place, then offering equivalent access to copy the
source code from the same place satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.
5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a "work that uses the Library". Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.
However, linking a "work that uses the Library" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a "work that uses the
library". The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.
When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library. The
threshold for this to be true is not precisely defined by law.
If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work. (Executables containing this object code plus portions of the
Library will still fall under Section 6.)
Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.
6. As an exception to the Sections above, you may also combine or
link a "work that uses the Library" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.
You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License. You must supply a copy of this License. If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License. Also, you must do one
of these things:
a) Accompany the work with the complete corresponding
machine-readable source code for the Library including whatever
changes were used in the work (which must be distributed under
Sections 1 and 2 above); and, if the work is an executable linked
with the Library, with the complete machine-readable "work that
uses the Library", as object code and/or source code, so that the
user can modify the Library and then relink to produce a modified
executable containing the modified Library. (It is understood
that the user who changes the contents of definitions files in the
Library will not necessarily be able to recompile the application
to use the modified definitions.)
b) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (1) uses at run time a
copy of the library already present on the user's computer system,
rather than copying library functions into the executable, and (2)
will operate properly with a modified version of the library, if
the user installs one, as long as the modified version is
interface-compatible with the version that the work was made with.
c) Accompany the work with a written offer, valid for at
least three years, to give the same user the materials
specified in Subsection 6a, above, for a charge no more
than the cost of performing this distribution.
d) If distribution of the work is made by offering access to copy
from a designated place, offer equivalent access to copy the above
specified materials from the same place.
e) Verify that the user has already received a copy of these
materials or that you have already sent this user a copy.
For an executable, the required form of the "work that uses the
Library" must include any data and utility programs needed for
reproducing the executable from it. However, as a special exception,
the materials to be distributed need not include anything that is
normally distributed (in either source or binary form) with the major
components (compiler, kernel, and so on) of the operating system on
which the executable runs, unless that component itself accompanies
the executable.
It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system. Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.
7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:
a) Accompany the combined library with a copy of the same work
based on the Library, uncombined with any other library
facilities. This must be distributed under the terms of the
Sections above.
b) Give prominent notice with the combined library of the fact
that part of it is a work based on the Library, and explaining
where to find the accompanying uncombined form of the same work.
8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License. Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library is void, and will automatically terminate your
rights under this License. However, parties who have received copies,
or rights, from you under this License will not have their licenses
terminated so long as such parties remain in full compliance.
9. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Library or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.
10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
subject to these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties with
this License.
11. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Library at all. For example, if a patent
license would not permit royalty-free redistribution of the Library by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Library.
If any portion of this section is held invalid or unenforceable under any
particular circumstance, the balance of the section is intended to apply,
and the section as a whole is intended to apply in other circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library under this License may add
an explicit geographical distribution limitation excluding those countries,
so that distribution is permitted only in or among countries not thus
excluded. In such case, this License incorporates the limitation as if
written in the body of this License.
13. The Free Software Foundation may publish revised and/or new
versions of the Lesser General Public License from time to time.
Such new versions will be similar in spirit to the present version,
but may differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the Library
specifies a version number of this License which applies to it and
"any later version", you have the option of following the terms and
conditions either of that version or of any later version published by
the Free Software Foundation. If the Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.
14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
write to the author to ask for permission. For software which is
copyrighted by the Free Software Foundation, write to the Free
Software Foundation; we sometimes make exceptions for this. Our
decision will be guided by the two goals of preserving the free status
of all derivatives of our free software and of promoting the sharing
and reuse of software generally.
NO WARRANTY
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Libraries
If you develop a new library, and you want it to be of the greatest
possible use to the public, we recommend making it free software that
everyone can redistribute and change. You can do so by permitting
redistribution under these terms (or, alternatively, under the terms of the
ordinary General Public License).
To apply these terms, attach the following notices to the library. It is
safest to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.
<one line to give the library's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
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.
<signature of Ty Coon>, 1 April 1990
Ty Coon, President of Vice
That's all there is to it!
====== BSD3 or Modified BSD License ======
Copyright (c) <year>, <copyright holder>
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 <organization> 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 <COPYRIGHT HOLDER> 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.

4
server/thirdparty/lwt-2.3.2/LICENSE vendored
View File

@ -1,4 +0,0 @@
The Ocsigen application core, and other portions of the official Ocsigen
distribution not explicitly licensed otherwise, are licensed under
the GNU LESSER GENERAL PUBLIC LICENSE with openssl linking exception
-- see the 'COPYING' file in this directory for details.

38
server/thirdparty/lwt-2.3.2/Makefile vendored
View File

@ -1,38 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb)
SETUP = ocaml setup.ml
build: setup.data
$(SETUP) -build $(BUILDFLAGS)
doc: setup.data build
$(SETUP) -doc $(DOCFLAGS)
test: setup.data build
$(SETUP) -test $(TESTFLAGS)
all:
$(SETUP) -all $(ALLFLAGS)
install: setup.data
$(SETUP) -install $(INSTALLFLAGS)
uninstall: setup.data
$(SETUP) -uninstall $(UNINSTALLFLAGS)
reinstall: setup.data
$(SETUP) -reinstall $(REINSTALLFLAGS)
clean:
$(SETUP) -clean $(CLEANFLAGS)
distclean:
$(SETUP) -distclean $(DISTCLEANFLAGS)
setup.data:
$(SETUP) -configure $(CONFIGUREFLAGS)
.PHONY: build doc test all install uninstall reinstall clean distclean configure
# OASIS_STOP

74
server/thirdparty/lwt-2.3.2/README vendored
View File

@ -1,74 +0,0 @@
Lwt: lightweight thread library for Objective Caml
--------------------------------------------------------------------------
This library is part of the Ocsigen project. See:
http://ocsigen.org/lwt
--------------------------------------------------------------------------
Requirements:
* ocaml with ocamlbuild (>= 3.11.0)
* findlib
* react (from http://erratique.ch/software/react)
* [optionnal] libev (from http://software.schmorp.de/pkg/libev.html)
* [optionnal] ocaml-text (needed for the enhanced toplevel)
* [optionnal] ocamlssl (>= 0.4.0) (ocamlssl needs openssl) (>= 0.4.1 for MacOS)
* [optionnal] glib-2.0 developpement files and pkg-config
If ocaml/findlib/ocamlssl... are not installed on your computer, you
can use GODI to install them automatically. See:
http://godi.camlcity.org/godi/index.html
They might also be available through your distribution.
--------------------------------------------------------------------------
Instructions:
* run "ocaml setup.ml -configure" to configure sources
You can add '--enable-<lib>' to enable compilation of
the sub-library <lib>. The flag '--enable-all' will
enable everything.
In order to compile without libev support you must add
'--disable-libev'.
* run "ocaml setup.ml -build" to compile
* run "ocaml setup.ml -install" as root to install compiled libraries
* run "ocaml setup.ml -uninstall" as root to uninstall them
HTML documentation is generated in _build/lwt.docdir/, but is not
installed by default.
If you get the development version you need to obtain oasis
(http://oasis.forge.ocamlcore.org/).
If you want to build the toplevel you have to install compiler
libraries, under debian it is the package
ocaml-compiler-libs. Otherwise you can add a symlink like that:
$ ln -s <ocaml sources> $(ocamlc -where)/compiler-libs
Note that the utop project replaces the Lwt toplevel:
https://forge.ocamlcore.org/projects/utop/
--------------------------------------------------------------------------
Authors:
* Jérôme Vouillon
* Vincent Balat
* Nataliya Guts
* Pierre Clairambault
* Stéphane Glondu
* Jérémie Dimino
* Warren Harris (Metaweb Technologies, Inc.)
* Pierre Chambart
* Mauricio Fernandez
See each source file for copyright information, and COPYING for license.
--------------------------------------------------------------------------

383
server/thirdparty/lwt-2.3.2/_oasis vendored
View File

@ -1,383 +0,0 @@
# +-------------------------------------------------------------------+
# | Package parameters |
# +-------------------------------------------------------------------+
OASISFormat: 0.1
OCamlVersion: >= 3.12
Name: lwt
Version: 2.3.2
LicenseFile: COPYING
License: LGPL-2.1 with OCaml linking exception
Authors:
Jérôme Vouillon,
Vincent Balat,
Nataliya Guts,
Pierre Clairambault,
Stéphane Glondu,
Jérémie Dimino,
Warren Harris,
Pierre Chambart,
Mauricio Fernandez
Homepage: http://ocsigen.org/lwt/
BuildTools: ocamlbuild
Plugins: DevFiles (0.2), META (0.2)
PostConfCommand: ocaml discover.ml -ocamlc $ocamlc -ext-obj $ext_obj -exec-name $default_executable_name -use-libev $libev -os-type $os_type
PostDistCleanCommand: $rm src/unix/lwt_config.h src/unix/lwt_config.ml
Synopsis: Lightweight thread library for Objective Caml
Description:
Lwt is a library of cooperative threads implemented in monadic
style. With respect to preemptive threads, cooperative threads are
not using a scheduler to distribute processor time between
threads. Instead of this, each thread must tell the others that he
wants to let them work.
# +-------------------------------------------------------------------+
# | Flags |
# +-------------------------------------------------------------------+
Flag all
Description: build and install everything
Default: false
Flag unix
Description: Unix support
Default: true
Flag react
Description: React helpers
Default: false
Flag glib
Description: Glib integration
Default: false
Flag ssl
Description: SSL support
Default: false
Flag text
Description: Text mode utilities
Default: false
Flag preemptive
Description: Preemptive threads support
Default: true
Flag extra
Description: Asynchronous unix functions
Default: true
Flag toplevel
Description: Enhanced toplevel
Default: false
Flag libev
Description: Compile with libev support
Default$: !os_type(Win32)
# +-------------------------------------------------------------------+
# | Libraries |
# +-------------------------------------------------------------------+
Library "optcomp"
Install: false
Path: syntax
Modules: Pa_optcomp
BuildDepends: camlp4.lib, camlp4.quotations.o
Library "lwt"
Path: src/core
Modules:
Lwt_condition,
Lwt_list,
Lwt,
Lwt_mutex,
Lwt_mvar,
Lwt_pool,
Lwt_sequence,
Lwt_stream,
Lwt_switch,
Lwt_util,
Lwt_pqueue
XMETADescription: Lightweight thread library for OCaml (core library)
Library "lwt-unix"
Build$: flag(unix) || flag(all)
Install$: flag(unix) || flag(all)
FindlibName: unix
FindlibParent: lwt
Path: src/unix
Modules:
Lwt_chan,
Lwt_daemon,
Lwt_gc,
Lwt_io,
Lwt_log,
Lwt_main,
Lwt_process,
Lwt_throttle,
Lwt_timeout,
Lwt_unix,
Lwt_sys,
Lwt_engine,
Lwt_bytes
InternalModules:
Lwt_log_rules
BuildDepends: lwt, unix, bigarray
XMETADescription: Unix support for lwt
CSources:
lwt_config.h,
lwt_unix.h,
lwt_unix_stubs.c,
lwt_libev_stubs.c
if os_type(Win32)
CCLib+: ws2_32.lib
else
CCLib+: -lpthread
if flag(libev)
CCLib+: -lev
Library "lwt-simple-top"
Build$: flag(unix) || flag(all)
Install$: flag(unix) || flag(all)
FindlibName: simple-top
FindlibParent: lwt
Path: src/simple_top
InternalModules: Lwt_simple_top
BuildDepends: lwt, lwt.unix
XMETADescription: Unix support for lwt
Library "lwt-react"
Build$: flag(react) || flag(all)
Install$: flag(react) || flag(all)
FindlibName: react
FindlibParent: lwt
Path: src/react
Modules: Lwt_event, Lwt_signal, Lwt_react
BuildDepends: lwt, react
XMETADescription: Reactive programming helpers
Library "lwt-preemptive"
Build$: flag(preemptive) || flag(all)
Install$: flag(preemptive) || flag(all)
FindlibName: preemptive
FindlibParent: lwt
Path: src/preemptive
Modules: Lwt_preemptive
BuildDepends: lwt, lwt.unix, threads
XMETADescription: Preemptive threads support for Lwt
Library "lwt-extra"
Build$: flag(extra) || flag(all)
Install$: flag(extra) || flag(all)
FindlibName: extra
FindlibParent: lwt
Path: src/extra
Modules: Lwt_lib
BuildDepends: lwt, lwt.preemptive
XMETADescription: Unix functions for Lwt using Lwt_preemptive
Library "lwt-glib"
Build$: flag(glib) || flag(all)
Install$: flag(glib) || flag(all)
FindlibName: glib
FindlibParent: lwt
Path: src/glib
Modules: Lwt_glib
CSources: lwt_glib_stubs.c
BuildDepends: lwt, lwt.unix
XMETADescription: Glib integration
Library "lwt-ssl"
Build$: flag(ssl) || flag(all)
Install$: flag(ssl) || flag(all)
FindlibName: ssl
FindlibParent: lwt
Path: src/ssl
Modules: Lwt_ssl
BuildDepends: ssl, lwt.unix
XMETADescription: SSL support for Lwt
Library "lwt-text"
Build$: flag(text) || flag(all)
Install$: flag(text) || flag(all)
FindlibName: text
FindlibParent: lwt
Path: src/text
Modules: Lwt_text, Lwt_term, Lwt_read_line
BuildDepends: lwt, lwt.unix, lwt.react, text, text.bigarray
XMETADescription: Text mode utilities
CSources: lwt_text_stubs.c
Library "lwt-top"
Build$: flag(text) || flag(all)
Install$: flag(text) || flag(all)
FindlibName: top
FindlibParent: lwt
Path: src/top
Modules: Lwt_top
InternalModules: Lwt_ocaml_completion
BuildDepends: lwt, lwt.text, findlib
XMETADescription: Line-editing in the toplevel
Library "lwt-syntax"
FindlibName: syntax
FindlibParent: lwt
Path: syntax
Modules: Pa_lwt
BuildDepends: camlp4.lib, camlp4.quotations.o, camlp4.extend
XMETAType: syntax
XMETADescription: Syntactic sugars for Lwt
XMETARequires: camlp4, lwt.syntax.options
Library "lwt-syntax-options"
FindlibName: options
FindlibParent: lwt-syntax
Path: syntax
InternalModules: Pa_lwt_options
BuildDepends: camlp4.lib
XMETAType: syntax
XMETADescription: Options for syntax extensions
XMETARequires: camlp4
Library "lwt-syntax-log"
FindlibName: log
FindlibParent: lwt-syntax
Path: syntax
Modules: Pa_lwt_log
BuildDepends: camlp4.lib, camlp4.quotations.o
XMETAType: syntax
XMETADescription: Syntactic sugars for logging
XMETARequires: camlp4, lwt.syntax.options
# +-------------------------------------------------------------------+
# | Toplevel |
# +-------------------------------------------------------------------+
Executable "lwt-toplevel"
Build$: flag(toplevel) || flag(all)
Install$: flag(toplevel) || flag(all)
Path: src/top
CompiledObject: byte
MainIs: lwt_toplevel.ml
BuildDepends: lwt, lwt.top, lwt.text, lwt.react, text, findlib, unix
# +-------------------------------------------------------------------+
# | Doc |
# +-------------------------------------------------------------------+
Document "lwt-manual"
Title: Lwt user manual
Type: custom (0.2)
Install: true
XCustom: make -C manual manual.pdf
DataFiles: manual/manual.pdf
InstallDir: $pdfdir
Document "lwt-api"
Title: API reference for Lwt
Type: ocamlbuild (0.2)
Install: true
InstallDir: $htmldir/api
DataFiles: utils/style.css
BuildTools: ocamldoc
XOCamlbuildPath: ./
XOCamlbuildLibraries:
lwt,
lwt.extra,
lwt.glib,
lwt.preemptive,
lwt.react,
lwt.ssl,
lwt.text,
lwt.top,
lwt.unix,
lwt.syntax,
lwt.syntax.log
# +-------------------------------------------------------------------+
# | Examples |
# +-------------------------------------------------------------------+
Executable logging
Path: examples/unix
Build$: flag(unix)
Install: false
MainIs: logging.ml
BuildDepends: lwt.unix, lwt.syntax
CompiledObject: best
Executable relay
Path: examples/unix
Build$: flag(unix)
Install: false
MainIs: relay.ml
BuildDepends: lwt.unix, lwt.syntax
CompiledObject: best
Executable parallelize
Path: examples/unix
Build$: flag(unix)
Install: false
MainIs: parallelize.ml
BuildDepends: lwt.unix, lwt.syntax
CompiledObject: best
# +-------------------------------------------------------------------+
# | Tests |
# +-------------------------------------------------------------------+
Library test
Path: tests
Modules: Test
Install: false
Build$: flag(unix) || flag(all)
Executable test_core
Path: tests/core
Build$: flag(unix) || flag(all)
Install: false
CompiledObject: best
MainIs: main.ml
BuildDepends: test, lwt, unix, lwt.unix
Executable test_unix
Path: tests/unix
Build$: flag(unix) || flag(all)
Install: false
CompiledObject: best
MainIs: main.ml
BuildDepends: test, lwt, unix, lwt.unix
Executable test_react
Path: tests/react
Build$: (flag(unix) && flag(react)) || flag(all)
Install: false
CompiledObject: best
MainIs: main.ml
BuildDepends: test, lwt, unix, lwt.unix, react, lwt.react
Test core
Command: $test_core
TestTools: test_core
Run$: flag(unix) || flag(all)
Test unix
Command: $test_unix
TestTools: test_unix
Run$: flag(unix) || flag(all)
Test react
Command: $test_react
TestTools: test_react
Run$: (flag(unix) && flag(react)) || flag(all)
# +-------------------------------------------------------------------+
# | Misc |
# +-------------------------------------------------------------------+
SourceRepository head
Type: darcs
Location: http://ocsigen.org/darcs/lwt
Browser: http://ocsigen.org/darcsweb/?r=lwt;a=summary

223
server/thirdparty/lwt-2.3.2/_tags vendored
View File

@ -1,223 +0,0 @@
# -*- conf -*-
<**/*.ml>: syntax_camlp4o, pkg_camlp4
<**/*.ml>: pa_lwt_options, pa_lwt, pa_lwt_log, pa_optcomp
<syntax/*.ml>: -pa_lwt_options, -pa_lwt, -pa_lwt_log, -pa_optcomp
<src/top/{lwt_toplevel.*,toplevel.*,toplevel_temp.*}>: use_compiler_libs, pkg_text, pkg_text.bigarray, pkg_findlib, pkg_react, pkg_unix, pkg_bigarray
<src/{unix,glib,text}/*>: use_stubs
"src/unix/lwt_io.mli": syntax_camlp4o, pkg_camlp4, pa_optcomp
# GLib bindings:
<src/glib/lwt-glib.*>: use_C_glib
<src/glib/liblwt-glib.*>: use_C_glib
<src/glib/lwt_glib_stubs.*>: use_C_glib
# OASIS_START
# DO NOT EDIT (digest: 1e926c0b1533824658bafa01bc7a4af4)
# Library lwt
"src/core": include
"src/core/lwt.cmxs": use_lwt
# Library lwt-unix
"src/unix": include
"src/unix/lwt-unix.cmxs": use_lwt-unix
<src/unix/lwt-unix.{cma,cmxa}>: oasis_library_lwt_unix_cclib
"src/unix/liblwt-unix.lib": oasis_library_lwt_unix_cclib
"src/unix/dlllwt-unix.dll": oasis_library_lwt_unix_cclib
"src/unix/liblwt-unix.a": oasis_library_lwt_unix_cclib
"src/unix/dlllwt-unix.so": oasis_library_lwt_unix_cclib
<src/unix/lwt-unix.{cma,cmxa}>: use_liblwt-unix
<src/unix/*.ml{,i}>: use_lwt
<src/unix/*.ml{,i}>: pkg_unix
<src/unix/*.ml{,i}>: pkg_bigarray
"src/unix/lwt_unix_stubs.c": use_lwt
"src/unix/lwt_unix_stubs.c": pkg_unix
"src/unix/lwt_unix_stubs.c": pkg_bigarray
"src/unix/lwt_libev_stubs.c": use_lwt
"src/unix/lwt_libev_stubs.c": pkg_unix
"src/unix/lwt_libev_stubs.c": pkg_bigarray
# Library lwt-react
"src/react": include
"src/react/lwt-react.cmxs": use_lwt-react
<src/react/*.ml{,i}>: use_lwt
<src/react/*.ml{,i}>: pkg_react
# Library test
"tests": include
"tests/test.cmxs": use_test
# Library lwt-text
"src/text": include
"src/text/lwt-text.cmxs": use_lwt-text
<src/text/lwt-text.{cma,cmxa}>: use_liblwt-text
<src/text/*.ml{,i}>: use_lwt-react
<src/text/*.ml{,i}>: use_lwt-unix
<src/text/*.ml{,i}>: use_lwt
<src/text/*.ml{,i}>: pkg_unix
<src/text/*.ml{,i}>: pkg_text.bigarray
<src/text/*.ml{,i}>: pkg_text
<src/text/*.ml{,i}>: pkg_react
<src/text/*.ml{,i}>: pkg_bigarray
"src/text/lwt_text_stubs.c": use_lwt-react
"src/text/lwt_text_stubs.c": use_lwt-unix
"src/text/lwt_text_stubs.c": use_lwt
"src/text/lwt_text_stubs.c": pkg_unix
"src/text/lwt_text_stubs.c": pkg_text.bigarray
"src/text/lwt_text_stubs.c": pkg_text
"src/text/lwt_text_stubs.c": pkg_react
"src/text/lwt_text_stubs.c": pkg_bigarray
# Executable test_unix
<tests/unix/main.{native,byte}>: use_test
<tests/unix/main.{native,byte}>: use_lwt-unix
<tests/unix/main.{native,byte}>: use_lwt
<tests/unix/main.{native,byte}>: pkg_unix
<tests/unix/main.{native,byte}>: pkg_bigarray
<tests/unix/*.ml{,i}>: use_test
<tests/unix/*.ml{,i}>: use_lwt-unix
<tests/unix/*.ml{,i}>: use_lwt
<tests/unix/*.ml{,i}>: pkg_unix
<tests/unix/*.ml{,i}>: pkg_bigarray
# Library lwt-syntax
"syntax/lwt-syntax.cmxs": use_lwt-syntax
<syntax/*.ml{,i}>: pkg_camlp4.extend
# Executable test_react
<tests/react/main.{native,byte}>: use_test
<tests/react/main.{native,byte}>: use_lwt-react
<tests/react/main.{native,byte}>: use_lwt-unix
<tests/react/main.{native,byte}>: use_lwt
<tests/react/main.{native,byte}>: pkg_unix
<tests/react/main.{native,byte}>: pkg_react
<tests/react/main.{native,byte}>: pkg_bigarray
<tests/react/*.ml{,i}>: use_test
<tests/react/*.ml{,i}>: use_lwt-react
<tests/react/*.ml{,i}>: use_lwt-unix
<tests/react/*.ml{,i}>: use_lwt
<tests/react/*.ml{,i}>: pkg_unix
<tests/react/*.ml{,i}>: pkg_react
<tests/react/*.ml{,i}>: pkg_bigarray
# Executable test_core
<tests/core/main.{native,byte}>: use_test
<tests/core/main.{native,byte}>: use_lwt-unix
<tests/core/main.{native,byte}>: use_lwt
<tests/core/main.{native,byte}>: pkg_unix
<tests/core/main.{native,byte}>: pkg_bigarray
<tests/core/*.ml{,i}>: use_test
<tests/core/*.ml{,i}>: use_lwt-unix
<tests/core/*.ml{,i}>: use_lwt
<tests/core/*.ml{,i}>: pkg_unix
<tests/core/*.ml{,i}>: pkg_bigarray
# Library lwt-top
"src/top": include
"src/top/lwt-top.cmxs": use_lwt-top
# Library lwt-preemptive
"src/preemptive": include
"src/preemptive/lwt-preemptive.cmxs": use_lwt-preemptive
<src/preemptive/*.ml{,i}>: use_lwt-unix
<src/preemptive/*.ml{,i}>: use_lwt
<src/preemptive/*.ml{,i}>: pkg_unix
<src/preemptive/*.ml{,i}>: pkg_threads
<src/preemptive/*.ml{,i}>: pkg_bigarray
# Library lwt-simple-top
"src/simple_top": include
"src/simple_top/lwt-simple-top.cmxs": use_lwt-simple-top
<src/simple_top/*.ml{,i}>: use_lwt-unix
<src/simple_top/*.ml{,i}>: use_lwt
<src/simple_top/*.ml{,i}>: pkg_unix
<src/simple_top/*.ml{,i}>: pkg_bigarray
# Library lwt-glib
"src/glib": include
"src/glib/lwt-glib.cmxs": use_lwt-glib
<src/glib/lwt-glib.{cma,cmxa}>: use_liblwt-glib
<src/glib/*.ml{,i}>: use_lwt-unix
<src/glib/*.ml{,i}>: use_lwt
<src/glib/*.ml{,i}>: pkg_unix
<src/glib/*.ml{,i}>: pkg_bigarray
"src/glib/lwt_glib_stubs.c": use_lwt-unix
"src/glib/lwt_glib_stubs.c": use_lwt
"src/glib/lwt_glib_stubs.c": pkg_unix
"src/glib/lwt_glib_stubs.c": pkg_bigarray
# Executable relay
<examples/unix/relay.{native,byte}>: use_lwt-syntax
<examples/unix/relay.{native,byte}>: use_lwt-unix
<examples/unix/relay.{native,byte}>: use_lwt
<examples/unix/relay.{native,byte}>: pkg_unix
<examples/unix/relay.{native,byte}>: pkg_camlp4.quotations.o
<examples/unix/relay.{native,byte}>: pkg_camlp4.lib
<examples/unix/relay.{native,byte}>: pkg_camlp4.extend
<examples/unix/relay.{native,byte}>: pkg_bigarray
# Executable logging
<examples/unix/logging.{native,byte}>: use_lwt-syntax
<examples/unix/logging.{native,byte}>: use_lwt-unix
<examples/unix/logging.{native,byte}>: use_lwt
<examples/unix/logging.{native,byte}>: pkg_unix
<examples/unix/logging.{native,byte}>: pkg_camlp4.quotations.o
<examples/unix/logging.{native,byte}>: pkg_camlp4.lib
<examples/unix/logging.{native,byte}>: pkg_camlp4.extend
<examples/unix/logging.{native,byte}>: pkg_bigarray
# Library lwt-syntax-log
"syntax/lwt-syntax-log.cmxs": use_lwt-syntax-log
# Executable lwt-toplevel
"src/top/lwt_toplevel.byte": use_lwt-top
"src/top/lwt_toplevel.byte": use_lwt-text
"src/top/lwt_toplevel.byte": use_lwt-react
"src/top/lwt_toplevel.byte": use_lwt-unix
"src/top/lwt_toplevel.byte": use_lwt
"src/top/lwt_toplevel.byte": pkg_unix
"src/top/lwt_toplevel.byte": pkg_text.bigarray
"src/top/lwt_toplevel.byte": pkg_text
"src/top/lwt_toplevel.byte": pkg_react
"src/top/lwt_toplevel.byte": pkg_findlib
"src/top/lwt_toplevel.byte": pkg_bigarray
<src/top/*.ml{,i}>: use_lwt-top
<src/top/*.ml{,i}>: use_lwt-text
<src/top/*.ml{,i}>: use_lwt-react
<src/top/*.ml{,i}>: use_lwt-unix
<src/top/*.ml{,i}>: use_lwt
<src/top/*.ml{,i}>: pkg_unix
<src/top/*.ml{,i}>: pkg_text.bigarray
<src/top/*.ml{,i}>: pkg_text
<src/top/*.ml{,i}>: pkg_react
<src/top/*.ml{,i}>: pkg_findlib
<src/top/*.ml{,i}>: pkg_bigarray
# Executable parallelize
<examples/unix/parallelize.{native,byte}>: use_lwt-syntax
<examples/unix/parallelize.{native,byte}>: use_lwt-unix
<examples/unix/parallelize.{native,byte}>: use_lwt
<examples/unix/parallelize.{native,byte}>: pkg_unix
<examples/unix/parallelize.{native,byte}>: pkg_camlp4.quotations.o
<examples/unix/parallelize.{native,byte}>: pkg_camlp4.lib
<examples/unix/parallelize.{native,byte}>: pkg_camlp4.extend
<examples/unix/parallelize.{native,byte}>: pkg_bigarray
<examples/unix/*.ml{,i}>: use_lwt-syntax
<examples/unix/*.ml{,i}>: use_lwt-unix
<examples/unix/*.ml{,i}>: use_lwt
<examples/unix/*.ml{,i}>: pkg_unix
<examples/unix/*.ml{,i}>: pkg_camlp4.quotations.o
<examples/unix/*.ml{,i}>: pkg_camlp4.lib
<examples/unix/*.ml{,i}>: pkg_camlp4.extend
<examples/unix/*.ml{,i}>: pkg_bigarray
# Library lwt-extra
"src/extra": include
"src/extra/lwt-extra.cmxs": use_lwt-extra
<src/extra/*.ml{,i}>: use_lwt-preemptive
<src/extra/*.ml{,i}>: use_lwt-unix
<src/extra/*.ml{,i}>: use_lwt
<src/extra/*.ml{,i}>: pkg_unix
<src/extra/*.ml{,i}>: pkg_threads
<src/extra/*.ml{,i}>: pkg_bigarray
# Library optcomp
"syntax/optcomp.cmxs": use_optcomp
<syntax/*.ml{,i}>: pkg_camlp4.quotations.o
# Library lwt-syntax-options
"syntax": include
"syntax/lwt-syntax-options.cmxs": use_lwt-syntax-options
<syntax/*.ml{,i}>: pkg_camlp4.lib
# Library lwt-ssl
"src/ssl": include
"src/ssl/lwt-ssl.cmxs": use_lwt-ssl
<src/ssl/*.ml{,i}>: use_lwt-unix
<src/ssl/*.ml{,i}>: use_lwt
<src/ssl/*.ml{,i}>: pkg_unix
<src/ssl/*.ml{,i}>: pkg_ssl
<src/ssl/*.ml{,i}>: pkg_bigarray
# OASIS_STOP

109
server/thirdparty/lwt-2.3.2/apiref-intro vendored
View File

@ -1,109 +0,0 @@
{1 Lwt - API Reference}
{2 Core library}
The {e core} library ({e lwt} package) contains the {!Lwt} module, which defines
cooperative threads with all the primitives to manipulate them. It
also provides several general purpose modules, which do not depend on
any external package.
{!modules:
Lwt
Lwt_condition
Lwt_list
Lwt_mutex
Lwt_mvar
Lwt_pool
Lwt_sequence
Lwt_pqueue
Lwt_stream
Lwt_switch
}
{2 Unix bindings}
The {e lwt.unix} package provides:
- the {!Lwt_unix} module, which wrap system calls into cooperative ones
- the {!Lwt_io} module, which defines cooperative byte channel, in
replacement of ones of the standard library
- module helpers for logging, spawning processes, ...
{!modules:
Lwt_daemon
Lwt_gc
Lwt_io
Lwt_log
Lwt_main
Lwt_engine
Lwt_process
Lwt_throttle
Lwt_timeout
Lwt_unix
Lwt_bytes
Lwt_sys
}
This package depends on the {e core} library and the {e unix} package.
{2 Reactive programming helpers}
The {e lwt.react} package provides helpers for functionnal reactive
programming with Lwt. It is based on the {e react} package. The
{!Lwt_react} module is a replacement for the [React] module. It
contains:
- all the functions of the [React] module
- Lwt specific primitives
- cooperative versions of {e react} functions
{!modules:
Lwt_react
}
This package depends on the {e core} library and the {e react} package.
{2 Syntax extensions}
Lwt is shipped with two syntax extensions. The first one, contained in
the {e lwt.syntax} package, aims to make coding with Lwt easier, and
to make code more readable. The second, contained in the package {e
lwt.syntax.log}, is a camlp4 filter which decreases the performance
penalty when using logging by inlining level tests.
{!modules:
Pa_lwt
Pa_lwt_log
}
{2 Terminal manipulation}
The package {e lwt.text} provides:
- terminal manipulation through the module {!Lwt_term}
- text channels which behaves as byte channels but are aware of the
text encoding
- a cooperative, fully customizable read-line facility
{!modules:
Lwt_read_line
Lwt_term
Lwt_text
}
This package depends on the {e core} library, and the {e lwt.react},
{e lwt.unix}, {e text} packages.
{2 Miscellaneous}
The following modules are wrapper for integration of non-Lwt
functions/packages into Lwt.
{!modules:
Lwt_glib
Lwt_lib
Lwt_preemptive
Lwt_ssl
}
{2 Index}
{!indexlist}

8
server/thirdparty/lwt-2.3.2/configure vendored
View File

@ -1,8 +0,0 @@
#!/bin/sh
# OASIS_START
# DO NOT EDIT (digest: ed33e59fe00e48bc31edf413bbc8b8d6)
set -e
ocaml setup.ml -configure $*
# OASIS_STOP

294
server/thirdparty/lwt-2.3.2/discover.ml vendored
View File

@ -1,294 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Program discover
* Copyright (C) 2010 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(* Discover available features *)
(* Keep that in sync with the list in myocamlbuild.ml *)
let search_paths = [
"/usr";
"/usr/local";
"/opt";
"/opt/local";
"/sw";
"/mingw";
]
open Printf
(* +-----------------------------------------------------------------+
| Test codes |
+-----------------------------------------------------------------+ *)
let caml_code = "
external test : unit -> unit = \"lwt_test\"
let () = test ()
"
let pthread_code = "
#include <caml/mlvalues.h>
#include <pthread.h>
CAMLprim value lwt_test()
{
pthread_create(0, 0, 0, 0);
return Val_unit;
}
"
let libev_code = "
#include <caml/mlvalues.h>
#include <ev.h>
CAMLprim value lwt_test()
{
ev_default_loop(0);
return Val_unit;
}
"
let fd_passing_code = "
#include <caml/mlvalues.h>
#include <sys/types.h>
#include <sys/socket.h>
CAMLprim value lwt_test()
{
struct msghdr msg;
msg.msg_controllen = 0;
msg.msg_control = 0;
return Val_unit;
}
"
let getcpu_code = "
#include <caml/mlvalues.h>
#define _GNU_SOURCE
#include <sched.h>
CAMLprim value lwt_test()
{
sched_getcpu();
return Val_unit;
}
"
let affinity_code = "
#include <caml/mlvalues.h>
#define _GNU_SOURCE
#include <sched.h>
CAMLprim value lwt_test()
{
sched_getaffinity(0, 0, 0);
return Val_unit;
}
"
let eventfd_code = "
#include <caml/mlvalues.h>
#include <sys/eventfd.h>
CAMLprim value lwt_test()
{
eventfd(0, 0);
return Val_unit;
}
"
let get_credentials_code = "
#include <caml/mlvalues.h>
#include <sys/types.h>
#include <sys/socket.h>
CAMLprim value lwt_test()
{
getsockopt(0, SOL_SOCKET, SO_PEERCRED, 0, 0);
return Val_unit;
}
"
let fdatasync_code = "
#include <caml/mlvalues.h>
#include <sys/unistd.h>
CAMLprim value lwt_test()
{
fdatasync(0);
return Val_unit;
}
"
(* +-----------------------------------------------------------------+
| Compilation |
+-----------------------------------------------------------------+ *)
let ocamlc = ref "ocamlc"
let ext_obj = ref ".o"
let exec_name = ref "a.out"
let use_libev = ref true
let os_type = ref "Unix"
let log_file = ref ""
let caml_file = ref ""
(* Search for a header file in standard directories. *)
let search_header header =
let rec loop = function
| [] ->
None
| dir :: dirs ->
if Sys.file_exists (dir ^ "/include/" ^ header) then
Some dir
else
loop dirs
in
loop search_paths
let c_args =
let flags path = Printf.sprintf "-ccopt -I%s/include -cclib -L%s/lib" path path in
match search_header "ev.h", search_header "pthread.h" with
| None, None -> ""
| Some path, None | None, Some path -> flags path
| Some path1, Some path2 when path1 = path2 -> flags path1
| Some path1, Some path2 -> flags path1 ^ " " ^ flags path2
let compile args stub_file =
ksprintf
Sys.command
"%s -custom %s %s %s %s > %s 2>&1"
!ocamlc
c_args
(Filename.quote stub_file)
args
(Filename.quote !caml_file)
(Filename.quote !log_file)
= 0
let safe_remove file_name =
try
Sys.remove file_name
with exn ->
()
let test_code args stub_code =
let stub_file, oc = Filename.open_temp_file "lwt_stub" ".c" in
let cleanup () =
safe_remove stub_file;
safe_remove (Filename.chop_extension (Filename.basename stub_file) ^ !ext_obj)
in
try
output_string oc stub_code;
flush oc;
close_out oc;
let result = compile args stub_file in
cleanup ();
result
with exn ->
(try close_out oc with _ -> ());
cleanup ();
raise exn
let config = open_out "src/unix/lwt_config.h"
let config_ml = open_out "src/unix/lwt_config.ml"
let test_feature ?(do_check = true) name macro ?(args="") code =
if do_check then begin
printf "testing for %s:%!" name;
if test_code args code then begin
fprintf config "#define %s\n" macro;
fprintf config_ml "#let %s = true\n" macro;
printf " %s available\n%!" (String.make (34 - String.length name) '.');
true
end else begin
fprintf config "//#define %s\n" macro;
fprintf config_ml "#let %s = false\n" macro;
printf " %s unavailable\n%!" (String.make (34 - String.length name) '.');
false
end
end else begin
printf "not checking for %s\n%!" name;
fprintf config "//#define %s\n" macro;
fprintf config_ml "#let %s = false\n" macro;
true
end
(* +-----------------------------------------------------------------+
| Entry point |
+-----------------------------------------------------------------+ *)
let () =
let args = [
"-ocamlc", Arg.Set_string ocamlc, "<path> ocamlc";
"-ext-obj", Arg.Set_string ext_obj, "<ext> C object files extension";
"-exec-name", Arg.Set_string exec_name, "<name> name of the executable produced by ocamlc";
"-use-libev", Arg.Symbol (["true"; "false"],
function
| "true" -> use_libev := true
| "false" -> use_libev := false
| _ -> assert false), " whether to check for libev";
"-os-type", Arg.Set_string os_type, "<name> type of the target os";
] in
Arg.parse args ignore "check for external C libraries and available features\noptions are:";
(* Put the caml code into a temporary file. *)
let file, oc = Filename.open_temp_file "lwt_caml" ".ml" in
caml_file := file;
output_string oc caml_code;
close_out oc;
log_file := Filename.temp_file "lwt_output" ".log";
(* Cleanup things on exit. *)
at_exit (fun () ->
(try close_out config with _ -> ());
(try close_out config_ml with _ -> ());
safe_remove !log_file;
safe_remove !exec_name;
safe_remove !caml_file;
safe_remove (Filename.chop_extension !caml_file ^ ".cmi");
safe_remove (Filename.chop_extension !caml_file ^ ".cmo"));
let missing = [] in
let missing = if test_feature ~do_check:!use_libev "libev" "HAVE_LIBEV" ~args:"-cclib -lev" libev_code then missing else "libev" :: missing in
let missing = if test_feature ~do_check:(!os_type <> "Win32") "pthread" "HAVE_PTHREAD" ~args:"-cclib -lpthread" pthread_code then missing else "pthread" :: missing in
if missing <> [] then begin
printf "
The following recquired C libraries are missing: %s.
Please install them and retry. If they are installed in a non-standard location, set the environment variables C_INCLUDE_PATH and LIBRARY_PATH accordingly and retry.
For example, if they are installed in /opt/local, you can type:
export C_INCLUDE_PATH=/opt/local/include
export LIBRARY_PATH=/opt/local/lib
To compile without libev support, use ./configure --disable-libev ...
" (String.concat ", " missing);
exit 1
end;
ignore (test_feature "eventfd" "HAVE_EVENTFD" eventfd_code);
ignore (test_feature "fd passing" "HAVE_FD_PASSING" fd_passing_code);
ignore (test_feature "sched_getcpu" "HAVE_GETCPU" getcpu_code);
ignore (test_feature "affinity getting/setting" "HAVE_AFFINITY" affinity_code);
ignore (test_feature "credentials getting" "HAVE_GET_CREDENTIALS" get_credentials_code);
ignore (test_feature "fdatasync" "HAVE_FDATASYNC" fdatasync_code)

2
server/thirdparty/lwt-2.3.2/examples/gtk/Makefile vendored
View File

@ -1,2 +0,0 @@
all:
ocamlbuild -use-ocamlfind -classic-display -tag 'syntax(camlp4o)' -package lwt.unix,lwt.glib,lwt.syntax,lablgtk2 connect.byte

218
server/thirdparty/lwt-2.3.2/examples/gtk/connect.ml vendored
View File

@ -1,218 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Program Connect
* Copyright (C) 2011 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(* A simple graphical telnet. *)
open Lwt
(* +-----------------------------------------------------------------+
| Utils |
+-----------------------------------------------------------------+ *)
let show_error fmt =
Printf.ksprintf
(fun message ->
let dialog = GWindow.message_dialog ~message_type:`ERROR ~buttons:GWindow.Buttons.ok ~message () in
ignore (dialog#connect#response (function
| `DELETE_EVENT -> ()
| `OK -> dialog#destroy ()));
dialog#show ())
fmt
(* +-----------------------------------------------------------------+
| Connection |
+-----------------------------------------------------------------+ *)
(* Either [None] if we are not connected, either [Some (ic, oc,
thread)] if we are connected. In this last case [thread] is the
thread reading data from the connection. *)
let connection = ref None
(* Read continously data from [ic] and write them to [view]. *)
let read ic (view : GText.view) =
let rec loop () =
match_lwt Lwt_io.read_line_opt ic with
| Some line ->
view#buffer#insert ~iter:view#buffer#end_iter ~tag_names:["recv"] (line ^ "\n");
loop ()
| None ->
view#buffer#insert ~iter:view#buffer#end_iter "end of connection\n";
Lwt_io.close ic
in
try_lwt
loop ()
with Unix.Unix_error (error, _, _) ->
show_error "reading error: %s" (Unix.error_message error);
return ()
(* Function called when the user active the [connect] menu
item. [view] is the text view used to display data received from
the connection. *)
let connect (view : GText.view) =
(* Create a popup for asking the address and port to connect to. *)
let dialog = GWindow.dialog ~title:"connection" () in
dialog#add_button_stock `OK `OK;
dialog#add_button_stock `CANCEL `CANCEL;
let hbox = GPack.hbox ~packing:dialog#vbox#add () in
ignore (GMisc.label ~packing:hbox#add ~text:"host: " ());
let host = GEdit.entry ~packing:hbox#add ~text:"127.0.0.1" () in
ignore (GMisc.label ~packing:hbox#add ~text:" port: " ());
let port = GEdit.spin_button ~digits:0 ~numeric:true ~packing:hbox#add () in
port#adjustment#set_bounds ~lower:0. ~upper:(float max_int) ~step_incr:1. ();
(* Thread waiting for the popup to be closed. *)
let waiter, wakener = wait () in
(* Wakeup the thread when the popup is closed. *)
ignore (dialog#connect#response (wakeup wakener));
dialog#show ();
ignore (
match_lwt waiter with
| `DELETE_EVENT ->
return ()
| `CANCEL ->
dialog#destroy ();
return ()
| `OK ->
let host = host#text and port = int_of_float port#value in
dialog#destroy ();
try_lwt
(* Resolve the address. *)
lwt entry = Lwt_unix.gethostbyname host in
if Array.length entry.Unix.h_addr_list = 0 then begin
show_error "no address found for host %S" host;
return ()
end else begin
lwt ic, oc = Lwt_io.open_connection (Unix.ADDR_INET (entry.Unix.h_addr_list.(0), port)) in
(* Close the previous connection. *)
lwt () =
match !connection with
| None ->
return ()
| Some (ic, oc, thread) ->
cancel thread;
try_lwt
Lwt_io.close ic <&> Lwt_io.close oc
with Unix.Unix_error (error, _, _) ->
show_error "cannot close the connection: %s" (Unix.error_message error);
return ()
in
(* Clear the buffer. *)
view#buffer#delete view#buffer#start_iter view#buffer#end_iter;
connection := Some (ic, oc, read ic view);
return ()
end
with
| Unix.Unix_error (error, _, _) ->
show_error "cannot establish the connection: %s" (Unix.error_message error);
return ()
| Not_found ->
show_error "host %S not found" host;
return ()
)
(* Send some data. *)
let write (view : GText.view) (entry : GEdit.entry) =
let text = entry#text in
entry#set_text "";
match !connection with
| Some (ic, oc, thread) ->
view#buffer#insert ~iter:view#buffer#end_iter ~tag_names:["send"] (text ^ "\n");
ignore (
try_lwt
Lwt_io.write_line oc text
with Unix.Unix_error (error, _, _) ->
show_error "cannot send line: %s" (Unix.error_message error);
return ()
)
| None ->
show_error "not connected"
(* +-----------------------------------------------------------------+
| Entry point |
+-----------------------------------------------------------------+ *)
lwt () =
(* Initializes GTK. *)
ignore (GMain.init ~setlocale:false ());
(* Integrate Lwt with Glib. *)
Lwt_glib.install ();
(* Create the UI. *)
let window = GWindow.window ~title:"simple graphical telnet in OCaml with Lwt" ~allow_shrink:true ~width:640 ~height:480 () in
let vbox = GPack.vbox ~packing:window#add () in
(* Create the menu. *)
let menu = GMenu.menu_bar ~packing:(vbox#pack ~expand:false) () in
let menu_file = GMenu.menu ~packing:(GMenu.menu_item ~label:"File" ~packing:menu#add ())#set_submenu () in
let menu_connect = GMenu.image_menu_item ~label:"Connect" ~packing:menu_file#add ~stock:`CONNECT () in
ignore (GMenu.separator_item ~packing:menu_file#add ());
let menu_quit = GMenu.image_menu_item ~label:"Quit" ~packing:menu_file#add ~stock:`QUIT () in
(* The text view displaying inputs and outputs. *)
let view =
GText.view
~editable:false
~packing:(GBin.scrolled_window
~hpolicy:`AUTOMATIC
~vpolicy:`AUTOMATIC
~packing:(GBin.frame
~label:"log"
~packing:vbox#add
())#add
())#add
()
in
ignore (view#buffer#create_tag ~name:"send" [`FOREGROUND "blue"]);
ignore (view#buffer#create_tag ~name:"recv" [`FOREGROUND "#007f00"]);
let hbox = GPack.hbox ~packing:(GBin.frame ~label:"input" ~packing:(vbox#pack ~expand:false) ())#add () in
(* The entry for user input. *)
let entry = GEdit.entry ~packing:hbox#add () in
let send = GButton.button ~label:"send" ~packing:(hbox#pack ~expand:false) () in
(* Try to use a monospace font. *)
(try
view#misc#modify_font_by_name "Monospace";
entry#misc#modify_font_by_name "Monospace"
with _ ->
());
(* Thread waiting for the main window to be closed. *)
let waiter, wakener = wait () in
(* Setup callbacks. *)
ignore (window#connect#destroy (wakeup wakener));
ignore (menu_quit#connect#activate (wakeup wakener));
ignore (menu_connect#connect#activate (fun () -> connect view));
ignore (entry#connect#activate (fun () -> write view entry));
ignore (send#connect#clicked (fun () -> write view entry));
window#show ();
(* Wait for the main window to be closed. *)
waiter

62
server/thirdparty/lwt-2.3.2/examples/unix/logging.ml vendored
View File

@ -1,62 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Program Logging
* Copyright (C) 2011 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(* This example illustrate the use of the Lwt_log module from
lwt.unix. *)
(* The logging section for this module: *)
let section = Lwt_log.Section.make "test"
lwt () =
(* Enable all logging levels superior from [Info] to [Fatal]: *)
Lwt_log.Section.set_level section Lwt_log.Info;
(* A message with the default logger: *)
lwt () = Lwt_log.log ~section ~level:Lwt_log.Info "this message will appear only on stderr" in
(* Same as begore, but using [Lwt_log.info]: *)
lwt () = Lwt_log.info ~section "this one too" in
(* A message to a custom logger, logging simultaneously to [stderr]
and to the system logger daemon: *)
let logger =
Lwt_log.broadcast
[Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr ();
Lwt_log.syslog ~facility:`User ()]
in
lwt () = Lwt_log.info ~section ~logger "this message will appear on stderr and in '/var/log/user.log'" in
(* Logging of exceptions: *)
Printexc.record_backtrace true;
let f () : unit = raise Exit in
let g () = f () in
let h () = g () in
lwt () =
try
h ();
Lwt.return ()
with exn ->
Lwt_log.error ~section ~exn "h failed with"
in
let logger = Lwt_log.channel ~template:"$(name): $(section): $(loc-file): $(loc-line): $(loc-column): $(message)" ~close_mode:`Keep ~channel:Lwt_io.stderr () in
Lwt_log.info ~section ~logger "this message will appear with a location"

57
server/thirdparty/lwt-2.3.2/examples/unix/parallelize.ml vendored
View File

@ -1,57 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Program Parallelize
* Copyright (C) 2011 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(* Reads commands from standard input and launch them in parallel,
using as many processes as the number of CPUs. *)
open Lwt
(* Reads one command, launch it and waits for when it termination,
then start again: *)
let rec launch () =
match_lwt Lwt_io.read_line_opt Lwt_io.stdin with
| None ->
return ()
| Some line ->
lwt exit_status = Lwt_process.exec (Lwt_process.shell line) in
launch ()
(* Creates the initial <N> threads, where <N> is the number of
CPUs: *)
let rec create_threads = function
| 0 ->
return ()
| n ->
launch () <&> create_threads (n - 1)
(* Counts the number of CPUs using "/proc/cpuinfo": *)
let cpus_count () =
Lwt_stream.fold (fun _ n -> succ n)
(Lwt_stream.filter
(fun line ->
try
Scanf.sscanf line "processor :" true
with _ ->
false)
(Lwt_io.lines_of_file "/proc/cpuinfo")) 0
lwt () = cpus_count () >>= create_threads

156
server/thirdparty/lwt-2.3.2/examples/unix/relay.ml vendored
View File

@ -1,156 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Program Relay
* Copyright (C) 2011 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(* Relay data from an address to another. *)
open Lwt
(* +-----------------------------------------------------------------+
| Relaying |
+-----------------------------------------------------------------+ *)
(* Write exactly [len] bytes from [buf] at [ofs]. *)
let rec write_exactly fd buf ofs len =
lwt n = Lwt_bytes.write fd buf ofs len in
if n = len then
(* Everything has been written, do nothing. *)
return ()
else
(* Write remaining data. *)
write_exactly fd buf (ofs + n) (len - n)
(* Copy continously data from [in_fd] to [out_fd]. *)
let relay in_fd out_fd =
(* Queue of data received but not yet written. *)
let queue = Queue.create () in
(* Condition used to signal the writer that some data are
available. *)
let cond = Lwt_condition.create () in
(* Boolean which tells whether the input socket has been closed. *)
let end_of_input = ref false in
(* Write continously data received to [out_fd]. *)
let rec loop_write () =
if Queue.is_empty queue then
if !end_of_input then
(* End of input reached, exit. *)
return ()
else
(* There is no data pending, wait for some. *)
lwt () = Lwt_condition.wait cond in
loop_write ()
else
let (buf, len) = Queue.take queue in
lwt () = write_exactly out_fd buf 0 len in
loop_write ()
in
(* Start the writer. *)
let writer = loop_write () in
(* Read continously from [in_fd]. *)
let rec loop_read () =
let buf = Lwt_bytes.create 8192 in
match_lwt Lwt_bytes.read in_fd buf 0 8192 with
| 0 ->
(* If we read nothing, this means that the connection has
been closed. *)
(* Mark the end of input has reached. *)
end_of_input := true;
(* Singal the writer in case it is waiting for data. *)
Lwt_condition.signal cond ();
(* Wait for it to terminate. *)
writer
| n ->
(* Otherwise, send data to the writer. *)
Queue.add (buf, n) queue;
(* Singal the writer in case it is waiting for data. *)
Lwt_condition.signal cond ();
loop_read ()
in
(* Wait for either the reader to terminate or the writer to fail. *)
pick [writer; loop_read ()]
(* +-----------------------------------------------------------------+
| Entry point |
+-----------------------------------------------------------------+ *)
let usage () =
prerr_endline "usage: relay <source-address>:<source-port> <destination-address>:<destination-port>";
exit 2
(* Convert a string of the form "<host>:<port>" to an internet address
object. *)
let addr_of_string str =
(* Split the host and the port. *)
let idx = try String.index str ':' with Not_found -> usage () in
let host = String.sub str 0 idx and port = String.sub str (idx + 1) (String.length str - idx - 1) in
(* Parse the port. *)
let port = try int_of_string port with Failure _ -> usage () in
(* Request the address of the host. *)
lwt entry = Lwt_unix.gethostbyname host in
if Array.length entry.Unix.h_addr_list = 0 then begin
Printf.eprintf "no address found for host %S\n" host;
exit 1
end;
return (Unix.ADDR_INET (entry.Unix.h_addr_list.(0), port))
lwt () =
if Array.length Sys.argv <> 3 then usage ();
try_lwt
(* Resolve addresses. *)
lwt src_addr = addr_of_string Sys.argv.(1) and dst_addr = addr_of_string Sys.argv.(2) in
(* Initialize the listening address. *)
let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Lwt_unix.setsockopt sock Unix.SO_REUSEADDR true;
Lwt_unix.bind sock src_addr;
Lwt_unix.listen sock 1024;
ignore (Lwt_log.notice "waiting for connection");
(* Wait for a connection. *)
lwt fd1, _ = Lwt_unix.accept sock in
ignore (Lwt_log.notice "connection received, start relayling");
(* Closes the no-more used listening socket. *)
lwt () = Lwt_unix.close sock in
(* Connect to the destination port. *)
let fd2 = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
lwt () = Lwt_unix.connect fd2 dst_addr in
(* Start relaying. *)
lwt () = pick [relay fd1 fd2; relay fd2 fd1] in
ignore (Lwt_log.notice "done relayling");
return ()
with exn ->
ignore (Lwt_log.error ~exn "something went wrong");
exit 1

40
server/thirdparty/lwt-2.3.2/lwt-api.odocl vendored
View File

@ -1,40 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 11d6fd54a0a3f207d6602a7b1da2317e)
src/core/Lwt_condition
src/core/Lwt_list
src/core/Lwt
src/core/Lwt_mutex
src/core/Lwt_mvar
src/core/Lwt_pool
src/core/Lwt_sequence
src/core/Lwt_stream
src/core/Lwt_switch
src/core/Lwt_util
src/core/Lwt_pqueue
src/extra/Lwt_lib
src/glib/Lwt_glib
src/preemptive/Lwt_preemptive
src/react/Lwt_event
src/react/Lwt_signal
src/react/Lwt_react
src/ssl/Lwt_ssl
src/text/Lwt_text
src/text/Lwt_term
src/text/Lwt_read_line
src/top/Lwt_top
src/unix/Lwt_chan
src/unix/Lwt_daemon
src/unix/Lwt_gc
src/unix/Lwt_io
src/unix/Lwt_log
src/unix/Lwt_main
src/unix/Lwt_process
src/unix/Lwt_throttle
src/unix/Lwt_timeout
src/unix/Lwt_unix
src/unix/Lwt_sys
src/unix/Lwt_engine
src/unix/Lwt_bytes
syntax/Pa_lwt
syntax/Pa_lwt_log
# OASIS_STOP

20
server/thirdparty/lwt-2.3.2/manual/Makefile vendored
View File

@ -1,20 +0,0 @@
# Makefile
# --------
# Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org>
# Licence : BSD3
#
# This file is a part of lwt.
all: manual.pdf
manual-wiki.tex: manual.wiki
latex_of_wiki < manual.wiki > manual-wiki.tex
manual.pdf: manual.tex manual-wiki.tex
rubber --pdf manual.tex
clean-aux:
rm -f .latex_of_wiki_offsets *.log *.aux *.out *.toc
clean: clean-aux
rm -f manual.pdf manual-wiki.tex

1359
server/thirdparty/lwt-2.3.2/manual/manual-wiki.tex vendored
View File

File diff suppressed because it is too large Load Diff

BIN
server/thirdparty/lwt-2.3.2/manual/manual.pdf vendored
View File

Binary file not shown.

52
server/thirdparty/lwt-2.3.2/manual/manual.tex vendored
View File

@ -1,52 +0,0 @@
\documentclass{article}
\usepackage{fullpage}
\usepackage[utf8]{inputenc}
\usepackage{url}
\usepackage{hyperref}
\usepackage{listings}
\usepackage{xcolor}
\hypersetup{%
a4paper=true,
pdfstartview=FitH,
colorlinks=false,
pdfborder=0 0 0,
pdftitle = {Lwt user manual},
pdfauthor = {Jérémie Dimino},
pdfkeywords = {OCaml, Lwt, Cooperative threads, Coroutines}
}
\lstset{
language=[Objective]Caml,
extendedchars,
showspaces=false,
showstringspaces=false,
showtabs=false,
basicstyle=\ttfamily,
frame=l,
framerule=1.5mm,
xleftmargin=6mm,
framesep=4mm,
rulecolor=\color{lightgray},
emph={lwt,for\_lwt,try\_lwt,raise\_lwt},
emphstyle=\color[rgb]{0.627451, 0.125490, 0.941176},
moredelim=*[s][\itshape]{(*}{*)},
moredelim=[is][\textcolor{darkgray}]{§}{§},
escapechar=°,
keywordstyle=\color[rgb]{0.627451, 0.125490, 0.941176},
stringstyle=\color[rgb]{0.545098, 0.278431, 0.364706},
commentstyle=\color[rgb]{0.698039, 0.133333, 0.133333},
numberstyle=\color[rgb]{0.372549, 0.619608, 0.627451}
}
\title{Lwt user manual}
\author{Jérémie Dimino}
\begin{document}
\maketitle
\tableofcontents
\include{manual-wiki}
\end{document}

1028
server/thirdparty/lwt-2.3.2/manual/manual.wiki vendored
View File

File diff suppressed because it is too large Load Diff

2
server/thirdparty/lwt-2.3.2/manual/menu.wiki vendored
View File

@ -1,2 +0,0 @@
= Lwt
==[[manual|Overview]]

771
server/thirdparty/lwt-2.3.2/myocamlbuild.ml vendored
View File

@ -1,771 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Myocamlbuild
* Copyright (C) 2010 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(* Keep that in sync with the list in discover.ml *)
let search_paths = [
"/usr";
"/usr/local";
"/opt";
"/opt/local";
"/sw";
"/mingw";
]
(* OASIS_START *)
(* DO NOT EDIT (digest: 4c177063a31680580ca13639e7a11972) *)
module OASISGettext = struct
# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISGettext.ml"
let ns_ str =
str
let s_ str =
str
let f_ (str : ('a, 'b, 'c, 'd) format4) =
str
let fn_ fmt1 fmt2 n =
if n = 1 then
fmt1^^""
else
fmt2^^""
let init =
[]
end
module OASISExpr = struct
# 21 "/home/chambart/bordel/oasis/oasis/src/oasis/OASISExpr.ml"
open OASISGettext
type test = string
type flag = string
type t =
| EBool of bool
| ENot of t
| EAnd of t * t
| EOr of t * t
| EFlag of flag
| ETest of test * string
type 'a choices = (t * 'a) list
let eval var_get t =
let rec eval' =
function
| EBool b ->
b
| ENot e ->
not (eval' e)
| EAnd (e1, e2) ->
(eval' e1) && (eval' e2)
| EOr (e1, e2) ->
(eval' e1) || (eval' e2)
| EFlag nm ->
let v =
var_get nm
in
assert(v = "true" || v = "false");
(v = "true")
| ETest (nm, vl) ->
let v =
var_get nm
in
(v = vl)
in
eval' t
let choose ?printer ?name var_get lst =
let rec choose_aux =
function
| (cond, vl) :: tl ->
if eval var_get cond then
vl
else
choose_aux tl
| [] ->
let str_lst =
if lst = [] then
s_ "<empty>"
else
String.concat
(s_ ", ")
(List.map
(fun (cond, vl) ->
match printer with
| Some p -> p vl
| None -> s_ "<no printer>")
lst)
in
match name with
| Some nm ->
failwith
(Printf.sprintf
(f_ "No result for the choice list '%s': %s")
nm str_lst)
| None ->
failwith
(Printf.sprintf
(f_ "No result for a choice list: %s")
str_lst)
in
choose_aux (List.rev lst)
end
module BaseEnvLight = struct
# 21 "/home/chambart/bordel/oasis/oasis/src/base/BaseEnvLight.ml"
module MapString = Map.Make(String)
type t = string MapString.t
let default_filename =
Filename.concat
(Sys.getcwd ())
"setup.data"
let load ?(allow_empty=false) ?(filename=default_filename) () =
if Sys.file_exists filename then
begin
let chn =
open_in_bin filename
in
let st =
Stream.of_channel chn
in
let line =
ref 1
in
let st_line =
Stream.from
(fun _ ->
try
match Stream.next st with
| '\n' -> incr line; Some '\n'
| c -> Some c
with Stream.Failure -> None)
in
let lexer =
Genlex.make_lexer ["="] st_line
in
let rec read_file mp =
match Stream.npeek 3 lexer with
| [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
Stream.junk lexer;
Stream.junk lexer;
Stream.junk lexer;
read_file (MapString.add nm value mp)
| [] ->
mp
| _ ->
failwith
(Printf.sprintf
"Malformed data file '%s' line %d"
filename !line)
in
let mp =
read_file MapString.empty
in
close_in chn;
mp
end
else if allow_empty then
begin
MapString.empty
end
else
begin
failwith
(Printf.sprintf
"Unable to load environment, the file '%s' doesn't exist."
filename)
end
let var_get name env =
let rec var_expand str =
let buff =
Buffer.create ((String.length str) * 2)
in
Buffer.add_substitute
buff
(fun var ->
try
var_expand (MapString.find var env)
with Not_found ->
failwith
(Printf.sprintf
"No variable %s defined when trying to expand %S."
var
str))
str;
Buffer.contents buff
in
var_expand (MapString.find name env)
let var_choose lst env =
OASISExpr.choose
(fun nm -> var_get nm env)
lst
end
module MyOCamlbuildFindlib = struct
# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml"
(** OCamlbuild extension, copied from
* http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild
* by N. Pouillard and others
*
* Updated on 2009/02/28
*
* Modified by Sylvain Le Gall
*)
open Ocamlbuild_plugin
(* these functions are not really officially exported *)
let run_and_read =
Ocamlbuild_pack.My_unix.run_and_read
let blank_sep_strings =
Ocamlbuild_pack.Lexers.blank_sep_strings
let split s ch =
let x =
ref []
in
let rec go s =
let pos =
String.index s ch
in
x := (String.before s pos)::!x;
go (String.after s (pos + 1))
in
try
go s
with Not_found -> !x
let split_nl s = split s '\n'
let before_space s =
try
String.before s (String.index s ' ')
with Not_found -> s
(* this lists all supported packages *)
let find_packages () =
List.map before_space (split_nl & run_and_read "ocamlfind list")
(* this is supposed to list available syntaxes, but I don't know how to do it. *)
let find_syntaxes () = ["camlp4o"; "camlp4r"]
(* ocamlfind command *)
let ocamlfind x = S[A"ocamlfind"; x]
let dispatch =
function
| Before_options ->
(* by using Before_options one let command line options have an higher priority *)
(* on the contrary using After_options will guarantee to have the higher priority *)
(* override default commands by ocamlfind ones *)
Options.ocamlc := ocamlfind & A"ocamlc";
Options.ocamlopt := ocamlfind & A"ocamlopt";
Options.ocamldep := ocamlfind & A"ocamldep";
Options.ocamldoc := ocamlfind & A"ocamldoc";
Options.ocamlmktop := ocamlfind & A"ocamlmktop"
| After_rules ->
(* When one link an OCaml library/binary/package, one should use -linkpkg *)
flag ["ocaml"; "link"; "program"] & A"-linkpkg";
(* For each ocamlfind package one inject the -package option when
* compiling, computing dependencies, generating documentation and
* linking. *)
List.iter
begin fun pkg ->
flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg];
flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
end
(find_packages ());
(* Like -package but for extensions syntax. Morover -syntax is useless
* when linking. *)
List.iter begin fun syntax ->
flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
end (find_syntaxes ());
(* The default "thread" tag is not compatible with ocamlfind.
* Indeed, the default rules add the "threads.cma" or "threads.cmxa"
* options when using this tag. When using the "-linkpkg" option with
* ocamlfind, this module will then be added twice on the command line.
*
* To solve this, one approach is to add the "-thread" option when using
* the "threads" package using the previous plugin.
*)
flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"])
| _ ->
()
end
module MyOCamlbuildBase = struct
# 21 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml"
(** Base functions for writing myocamlbuild.ml
@author Sylvain Le Gall
*)
open Ocamlbuild_plugin
type dir = string
type file = string
type name = string
type tag = string
# 55 "/home/chambart/bordel/oasis/oasis/src/plugins/ocamlbuild/MyOCamlbuildBase.ml"
type t =
{
lib_ocaml: (name * dir list) list;
lib_c: (name * dir * file list) list;
flags: (tag list * (spec OASISExpr.choices)) list;
}
let env_filename =
Pathname.basename
BaseEnvLight.default_filename
let dispatch_combine lst =
fun e ->
List.iter
(fun dispatch -> dispatch e)
lst
let dispatch t e =
let env =
BaseEnvLight.load
~filename:env_filename
~allow_empty:true
()
in
match e with
| Before_options ->
let no_trailing_dot s =
if String.length s >= 1 && s.[0] = '.' then
String.sub s 1 ((String.length s) - 1)
else
s
in
List.iter
(fun (opt, var) ->
try
opt := no_trailing_dot (BaseEnvLight.var_get var env)
with Not_found ->
Printf.eprintf "W: Cannot get variable %s" var)
[
Options.ext_obj, "ext_obj";
Options.ext_lib, "ext_lib";
Options.ext_dll, "ext_dll";
]
| After_rules ->
(* Declare OCaml libraries *)
List.iter
(function
| lib, [] ->
ocaml_lib lib;
| lib, dir :: tl ->
ocaml_lib ~dir:dir lib;
List.iter
(fun dir ->
flag
["ocaml"; "use_"^lib; "compile"]
(S[A"-I"; P dir]))
tl)
t.lib_ocaml;
(* Declare C libraries *)
List.iter
(fun (lib, dir, headers) ->
(* Handle C part of library *)
flag ["link"; "library"; "ocaml"; "byte"; "use_lib"^lib]
(S[A"-dllib"; A("-l"^lib); A"-cclib"; A("-l"^lib)]);
flag ["link"; "library"; "ocaml"; "native"; "use_lib"^lib]
(S[A"-cclib"; A("-l"^lib)]);
flag ["link"; "program"; "ocaml"; "byte"; "use_lib"^lib]
(S[A"-dllib"; A("dll"^lib)]);
(* When ocaml link something that use the C library, then one
need that file to be up to date.
*)
dep ["link"; "ocaml"; "use_lib"^lib]
[dir/"lib"^lib^"."^(!Options.ext_lib)];
(* TODO: be more specific about what depends on headers *)
(* Depends on .h files *)
dep ["compile"; "c"]
headers;
(* Setup search path for lib *)
flag ["link"; "ocaml"; "use_"^lib]
(S[A"-I"; P(dir)]);
)
t.lib_c;
(* Add flags *)
List.iter
(fun (tags, cond_specs) ->
let spec =
BaseEnvLight.var_choose cond_specs env
in
flag tags & spec)
t.flags
| _ ->
()
let dispatch_default t =
dispatch_combine
[
dispatch t;
MyOCamlbuildFindlib.dispatch;
]
end
open Ocamlbuild_plugin;;
let package_default =
{
MyOCamlbuildBase.lib_ocaml =
[
("src/core/lwt", ["src/core"]);
("src/unix/lwt-unix", ["src/unix"]);
("src/react/lwt-react", ["src/react"]);
("tests/test", ["tests"]);
("src/text/lwt-text", ["src/text"]);
("syntax/lwt-syntax", ["syntax"]);
("src/top/lwt-top", ["src/top"]);
("src/preemptive/lwt-preemptive", ["src/preemptive"]);
("src/simple_top/lwt-simple-top", ["src/simple_top"]);
("src/glib/lwt-glib", ["src/glib"]);
("syntax/lwt-syntax-log", ["syntax"]);
("src/extra/lwt-extra", ["src/extra"]);
("syntax/optcomp", ["syntax"]);
("syntax/lwt-syntax-options", ["syntax"]);
("src/ssl/lwt-ssl", ["src/ssl"])
];
lib_c =
[
("lwt-unix",
"src/unix",
["src/unix/lwt_config.h"; "src/unix/lwt_unix.h"]);
("lwt-text", "src/text", []);
("lwt-glib", "src/glib", [])
];
flags =
[
(["oasis_library_lwt_unix_cclib"; "link"],
[
(OASISExpr.EBool true, S []);
(OASISExpr.EFlag "libev", S [A "-cclib"; A "-lev"]);
(OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")),
S [A "-cclib"; A "-lpthread"]);
(OASISExpr.EAnd
(OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")),
OASISExpr.EFlag "libev"),
S [A "-cclib"; A "-lpthread"; A "-cclib"; A "-lev"]);
(OASISExpr.ETest ("os_type", "Win32"),
S [A "-cclib"; A "ws2_32.lib"]);
(OASISExpr.EAnd
(OASISExpr.ETest ("os_type", "Win32"),
OASISExpr.EFlag "libev"),
S [A "-cclib"; A "ws2_32.lib"; A "-cclib"; A "-lev"]);
(OASISExpr.EAnd
(OASISExpr.ETest ("os_type", "Win32"),
OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))),
S [A "-cclib"; A "ws2_32.lib"; A "-cclib"; A "-lpthread"]);
(OASISExpr.EAnd
(OASISExpr.EAnd
(OASISExpr.ETest ("os_type", "Win32"),
OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))),
OASISExpr.EFlag "libev"),
S
[
A "-cclib";
A "ws2_32.lib";
A "-cclib";
A "-lpthread";
A "-cclib";
A "-lev"
])
]);
(["oasis_library_lwt_unix_cclib"; "ocamlmklib"; "c"],
[
(OASISExpr.EBool true, S []);
(OASISExpr.EFlag "libev", S [A "-lev"]);
(OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")),
S [A "-lpthread"]);
(OASISExpr.EAnd
(OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32")),
OASISExpr.EFlag "libev"),
S [A "-lpthread"; A "-lev"]);
(OASISExpr.ETest ("os_type", "Win32"), S [A "ws2_32.lib"]);
(OASISExpr.EAnd
(OASISExpr.ETest ("os_type", "Win32"),
OASISExpr.EFlag "libev"),
S [A "ws2_32.lib"; A "-lev"]);
(OASISExpr.EAnd
(OASISExpr.ETest ("os_type", "Win32"),
OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))),
S [A "ws2_32.lib"; A "-lpthread"]);
(OASISExpr.EAnd
(OASISExpr.EAnd
(OASISExpr.ETest ("os_type", "Win32"),
OASISExpr.ENot (OASISExpr.ETest ("os_type", "Win32"))),
OASISExpr.EFlag "libev"),
S [A "ws2_32.lib"; A "-lpthread"; A "-lev"])
])
];
}
;;
let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
(* OASIS_STOP *)
open Ocamlbuild_plugin
let pkg_config flags =
with_temp_file "lwt" "pkg-config"
(fun tmp ->
Command.execute ~quiet:true & Cmd(S[A "pkg-config"; S flags; Sh ">"; A tmp]);
List.map (fun arg -> A arg) (string_list_of_file tmp))
let define_c_library ?(msvc = false) ~name ~c_name () =
let tag = Printf.sprintf "use_C_%s" name in
(* Get compile flags. *)
let opt = pkg_config [A "--cflags"; A c_name] in
(* Get linking flags. *)
let lib =
if msvc then
(* With msvc we need to pass "glib-2.0.lib" instead of
"-lglib-2.0" otherwise executables will fail. *)
pkg_config [A "--libs-only-L"; A c_name] @ pkg_config [A "--libs-only-l"; A "--msvc-syntax"; A c_name]
else
pkg_config [A "--libs"; A c_name]
in
(* Add flags for linking with the C library: *)
flag ["ocamlmklib"; "c"; tag] & S lib;
(* C stubs using the C library must be compiled with the library
specifics flags: *)
flag ["c"; "compile"; tag] & S (List.map (fun arg -> S[A"-ccopt"; arg]) opt);
(* OCaml libraries must depends on the C library: *)
flag ["link"; "ocaml"; tag] & S (List.map (fun arg -> S[A"-cclib"; arg]) lib)
let () =
dispatch
(fun hook ->
dispatch_default hook;
match hook with
| Before_options ->
Options.make_links := false
| After_rules ->
dep ["file:src/unix/lwt_unix_stubs.c"] ["src/unix/lwt_unix_unix.c"; "src/unix/lwt_unix_windows.c"];
dep ["pa_optcomp"] ["src/unix/lwt_config.ml"];
(* Internal syntax extension *)
List.iter
(fun base ->
let tag = "pa_" ^ base and file = "syntax/pa_" ^ base ^ ".cmo" in
flag ["ocaml"; "compile"; tag] & S[A"-ppopt"; A file];
flag ["ocaml"; "ocamldep"; tag] & S[A"-ppopt"; A file];
flag ["ocaml"; "doc"; tag] & S[A"-ppopt"; A file];
dep ["ocaml"; "ocamldep"; tag] [file])
["lwt_options"; "lwt"; "lwt_log"; "optcomp"];
(* Optcomp for .mli *)
flag ["ocaml"; "compile"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"];
flag ["ocaml"; "ocamldep"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"];
flag ["ocaml"; "doc"; "pa_optcomp_standalone"] & S[A"-pp"; A "./syntax/optcomp.byte"];
dep ["ocaml"; "ocamldep"; "pa_optcomp_standalone"] ["syntax/optcomp.byte"];
(* Use an introduction page with categories *)
tag_file "lwt-api.docdir/index.html" ["apiref"];
dep ["apiref"] ["apiref-intro"];
flag ["apiref"] & S[A "-intro"; P "apiref-intro"; A"-colorize-code"];
(* Glib bindings: *)
let env = BaseEnvLight.load ~allow_empty:true ~filename:MyOCamlbuildBase.env_filename () in
let msvc = BaseEnvLight.var_get "ccomp_type" env = "msvc" in
if BaseEnvLight.var_get "glib" env = "true" || BaseEnvLight.var_get "all" env = "true" then
define_c_library ~msvc ~name:"glib" ~c_name:"glib-2.0" ();
let opts = S[A "-ppopt"; A "-let"; A "-ppopt"; A ("windows=" ^ if BaseEnvLight.var_get "os_type" env <> "Unix" then "true" else "false")] in
flag ["ocaml"; "compile"; "pa_optcomp"] & opts;
flag ["ocaml"; "ocamldep"; "pa_optcomp"] & opts;
(*flag ["ocaml"; "doc"; "pa_optcomp"] & opts; Does not work... *)
flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg";
let env = BaseEnvLight.load () in
let stdlib_path = BaseEnvLight.var_get "standard_library" env in
(* Try to find the path where compiler libraries are: *)
let compiler_libs =
let stdlib = String.chomp stdlib_path in
try
let path =
List.find Pathname.exists [
stdlib / "compiler-libs";
stdlib / "compiler-lib";
stdlib / ".." / "compiler-libs";
stdlib / ".." / "compiler-lib";
]
in
path :: List.filter Pathname.exists [ path / "typing"; path / "utils"; path / "parsing" ]
with Not_found ->
[]
in
(* Add directories for compiler-libraries: *)
let paths = List.map (fun path -> S[A"-I"; A path]) compiler_libs in
List.iter
(fun stage -> flag ["ocaml"; stage; "use_compiler_libs"] & S paths)
["compile"; "ocamldep"; "doc"; "link"];
dep ["file:src/top/toplevel_temp.top"] ["src/core/lwt.cma";
"src/react/lwt-react.cma";
"src/unix/lwt-unix.cma";
"src/text/lwt-text.cma";
"src/top/lwt-top.cma"];
flag ["file:src/top/toplevel_temp.top"] & S[A"-I"; A"src/unix";
A"-I"; A"src/text";
A"src/core/lwt.cma";
A"src/react/lwt-react.cma";
A"src/unix/lwt-unix.cma";
A"src/text/lwt-text.cma";
A"src/top/lwt-top.cma"];
(* Expunge compiler modules *)
rule "toplevel expunge"
~dep:"src/top/toplevel_temp.top"
~prod:"src/top/lwt_toplevel.byte"
(fun _ _ ->
let directories =
stdlib_path
:: "src/core"
:: "src/react"
:: "src/unix"
:: "src/text"
:: "src/top"
:: (List.map
(fun lib ->
String.chomp
(run_and_read
("ocamlfind query " ^ lib)))
["findlib"; "react"; "unix"; "text"])
in
let modules =
List.fold_left
(fun set directory ->
List.fold_left
(fun set fname ->
if Pathname.check_extension fname "cmi" then
StringSet.add (module_name_of_pathname fname) set
else
set)
set
(Array.to_list (Pathname.readdir directory)))
StringSet.empty directories
in
Cmd(S[A(stdlib_path / "expunge");
A"src/top/toplevel_temp.top";
A"src/top/lwt_toplevel.byte";
A"outcometree"; A"topdirs"; A"toploop";
S(List.map (fun x -> A x) (StringSet.elements modules))]));
(* Search for a header file in standard directories. *)
let search_header header =
let rec loop = function
| [] ->
None
| dir :: dirs ->
if Sys.file_exists (dir ^ "/include/" ^ header) then
Some dir
else
loop dirs
in
loop search_paths
in
(* Add directories for libev and pthreads *)
let flags dir =
flag ["ocamlmklib"; "c"; "use_stubs"] & A("-L" ^ dir ^ "/lib");
flag ["c"; "compile"; "use_stubs"] & S[A"-ccopt"; A("-I" ^ dir ^ "/include")];
flag ["link"; "ocaml"; "use_stubs"] & S[A"-cclib"; A("-L" ^ dir ^ "/lib")]
in
begin
match search_header "ev.h", search_header "pthread.h" with
| None, None -> ()
| Some path, None | None, Some path -> flags path
| Some path1, Some path2 when path1 = path2 -> flags path1
| Some path1, Some path2 -> flags path1; flags path2
end
| _ ->
())

6552
server/thirdparty/lwt-2.3.2/setup.ml vendored
View File

File diff suppressed because it is too large Load Diff

115
server/thirdparty/lwt-2.3.2/src/core/META vendored
View File

@ -1,115 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 92360f3460ecb78dca24ff748f6650bd)
version = "2.3.2"
description = "Lightweight thread library for OCaml (core library)"
archive(byte) = "lwt.cma"
archive(native) = "lwt.cmxa"
exists_if = "lwt.cma"
package "ssl" (
version = "2.3.2"
description = "SSL support for Lwt"
requires = "ssl lwt.unix"
archive(byte) = "lwt-ssl.cma"
archive(native) = "lwt-ssl.cmxa"
exists_if = "lwt-ssl.cma"
)
package "extra" (
version = "2.3.2"
description = "Unix functions for Lwt using Lwt_preemptive"
requires = "lwt lwt.preemptive"
archive(byte) = "lwt-extra.cma"
archive(native) = "lwt-extra.cmxa"
exists_if = "lwt-extra.cma"
)
package "glib" (
version = "2.3.2"
description = "Glib integration"
requires = "lwt lwt.unix"
archive(byte) = "lwt-glib.cma"
archive(native) = "lwt-glib.cmxa"
exists_if = "lwt-glib.cma"
)
package "simple-top" (
version = "2.3.2"
description = "Unix support for lwt"
requires = "lwt lwt.unix"
archive(byte) = "lwt-simple-top.cma"
archive(native) = "lwt-simple-top.cmxa"
exists_if = "lwt-simple-top.cma"
)
package "preemptive" (
version = "2.3.2"
description = "Preemptive threads support for Lwt"
requires = "lwt lwt.unix threads"
archive(byte) = "lwt-preemptive.cma"
archive(native) = "lwt-preemptive.cmxa"
exists_if = "lwt-preemptive.cma"
)
package "top" (
version = "2.3.2"
description = "Line-editing in the toplevel"
requires = "lwt lwt.text findlib"
archive(byte) = "lwt-top.cma"
archive(native) = "lwt-top.cmxa"
exists_if = "lwt-top.cma"
)
package "syntax" (
version = "2.3.2"
description = "Syntactic sugars for Lwt"
requires = "camlp4 lwt.syntax.options"
archive(syntax,preprocessor) = "lwt-syntax.cma"
archive(syntax,toploop) = "lwt-syntax.cma"
exists_if = "lwt-syntax.cma"
package "options" (
version = "2.3.2"
description = "Options for syntax extensions"
requires = "camlp4"
archive(syntax,preprocessor) = "lwt-syntax-options.cma"
archive(syntax,toploop) = "lwt-syntax-options.cma"
exists_if = "lwt-syntax-options.cma"
)
package "log" (
version = "2.3.2"
description = "Syntactic sugars for logging"
requires = "camlp4 lwt.syntax.options"
archive(syntax,preprocessor) = "lwt-syntax-log.cma"
archive(syntax,toploop) = "lwt-syntax-log.cma"
exists_if = "lwt-syntax-log.cma"
)
)
package "text" (
version = "2.3.2"
description = "Text mode utilities"
requires = "lwt lwt.unix lwt.react text text.bigarray"
archive(byte) = "lwt-text.cma"
archive(native) = "lwt-text.cmxa"
exists_if = "lwt-text.cma"
)
package "react" (
version = "2.3.2"
description = "Reactive programming helpers"
requires = "lwt react"
archive(byte) = "lwt-react.cma"
archive(native) = "lwt-react.cmxa"
exists_if = "lwt-react.cma"
)
package "unix" (
version = "2.3.2"
description = "Unix support for lwt"
requires = "lwt unix bigarray"
archive(byte) = "lwt-unix.cma"
archive(native) = "lwt-unix.cmxa"
exists_if = "lwt-unix.cma"
)
# OASIS_STOP

1060
server/thirdparty/lwt-2.3.2/src/core/lwt.ml vendored
View File

File diff suppressed because it is too large Load Diff

396
server/thirdparty/lwt-2.3.2/src/core/lwt.mli vendored
View File

@ -1,396 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt
* 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]: cooperative light-weight threads. *)
(** This module defines {e cooperative light-weight threads} with
their primitives. A {e light-weight thread} represent a
computation that may be not terminated, for example because it is
waiting for some event to happen.
Lwt threads are cooperative in the sense that switching to another
thread is awlays explicit (with {!wakeup} or {!wekup_exn}). When a
thread is running, it executes as much as possible, and then
returns (a value or an eror) or sleeps.
Note that inside a Lwt thread, exceptions must be raised with
{!fail} instead of [raise]. Also the [try ... with ...]
construction will not catch Lwt errors. You must use {!catch}
instead. You can also use {!wrap} for functions that may raise
normal exception.
Lwt also provides the syntax extension {!Pa_lwt} to make code
using Lwt more readable.
*)
(** {6 Definitions and basics} *)
type +'a t
(** The type of threads returning a result of type ['a]. *)
val return : 'a -> 'a t
(** [return e] is a thread whose return value is the value of the
expression [e]. *)
val fail : exn -> 'a t
(** [fail e] is a thread that fails with the exception [e]. *)
val bind : 'a t -> ('a -> 'b t) -> 'b t
(** [bind t f] is a thread which first waits for the thread [t] to
terminate and then, if the thread succeeds, behaves as the
application of function [f] to the return value of [t]. If the
thread [t] fails, [bind t f] also fails, with the same
exception.
The expression [bind t (fun x -> t')] can intuitively be read as
[let x = t in t'], and if you use the {e lwt.syntax} syntax
extension, you can write a bind operation like that: [lwt x = t in t'].
Note that [bind] is also often used just for synchronization
purpose: [t'] will not execute before [t] is terminated.
The result of a thread can be bound several time. *)
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
(** [t >>= f] is an alternative notation for [bind t f]. *)
val (=<<) : ('a -> 'b t) -> 'a t -> 'b t
(** [f =<< t] is [t >>= f] *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** [map f m] map the result of a thread. This is the same as [bind
m (fun x -> return (f x))] *)
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
(** [m >|= f] is [map f m] *)
val (=|<) : ('a -> 'b) -> 'a t -> 'b t
(** [f =|< m] is [map f m] *)
(** {6 Thread storage} *)
type 'a key
(** Type of a key. Keys are used to store local values into
threads *)
val new_key : unit -> 'a key
(** [new_key ()] creates a new key. *)
val get : 'a key -> 'a option
(** [get key] returns the value associated with [key] in the current
thread. *)
val with_value : 'a key -> 'a option -> (unit -> 'b) -> 'b
(** [with_value key value f] executes [f] with [value] associated to
[key]. The previous value associated to [key] is restored after
[f] terminates. *)
(** {6 Exceptions handling} *)
val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t
(** [catch t f] is a thread that behaves as the thread [t ()] if
this thread succeeds. If the thread [t ()] fails with some
exception, [catch t f] behaves as the application of [f] to this
exception. *)
val try_bind : (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t
(** [try_bind t f g] behaves as [bind (t ()) f] if [t] does not
fail. Otherwise, it behaves as the application of [g] to the
exception associated to [t ()]. *)
val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t
(** [finalize f g] returns the same result as [f ()] whether it
fails or not. In both cases, [g ()] is executed after [f]. *)
val wrap : (unit -> 'a) -> 'a t
(** [wrap f] calls [f] and transform the result into a monad. If [f]
raise an exception, it is catched by Lwt.
This is actually the same as:
{[
try
return (f ())
with exn ->
fail exn
]}
*)
val wrap1 : ('a -> 'b) -> 'a -> 'b t
(** [wrap1 f x] applies [f] on [x] and returns the result as a
thread. If the application of [f] to [x] raise an exception it
is catched and a thread is returned.
Note that you must use {!wrap} instead of {!wrap1} if the
evaluation of [x] may raise an exception.
for example the following code is not ok:
{[
wrap1 f (Hashtbl.find table key)
]}
you should write instead:
{[
wrap (fun () -> f (Hashtbl.find table key))
]}
*)
val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t
val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t
val wrap4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e t
val wrap5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f t
val wrap6 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g t
val wrap7 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h t
(** {6 Multi-threads composition} *)
val choose : 'a t list -> 'a t
(** [choose l] behaves as the first thread in [l] to terminate. If
several threads are already terminated, one is choosen at
random.
Note: {!choose} leaves the local values of the current thread
unchanged. *)
val nchoose : 'a t list -> 'a list t
(** [nchoose l] returns the value of all that have succcessfully
terminated. If all threads are sleeping, it waits for at least
one to terminates. If one the threads of [l] fails, [nchoose]
fails with the same exception.
Note: {!nchoose} leaves the local values of the current thread
unchanged. *)
val nchoose_split : 'a t list -> ('a list * 'a t list) t
(** [nchoose_split l] does the same as {!nchoose} but also retrurns
the list of threads that have not yet terminated. *)
val join : unit t list -> unit t
(** [join l] waits for all threads in [l] to terminate. If one of
the threads fails, then [join l] will fails with the same
exception as the first one to terminate.
Note: {!join} leaves the local values of the current thread
unchanged. *)
val ( <?> ) : 'a t -> 'a t -> 'a t
(** [t <?> t'] is the same as [choose [t; t']] *)
val ( <&> ) : unit t -> unit t -> unit t
(** [t <&> t'] is the same as [join [t; t']] *)
val ignore_result : 'a t -> unit
(** [ignore_result t] start the thread [t] and ignores its result
value if the thread terminates sucessfully. However, if the
thread [t] fails, the exception is raised instead of being
ignored.
You should use this function if you want to start a thread and
don't care what its return value is, nor when it terminates (for
instance, because it is looping). Note that if the thread [t]
yields and later fails, the exception will not be raised at this
point in the program. *)
(** {6 Sleeping and resuming} *)
type 'a u
(** The type of thread wakeners. *)
val wait : unit -> 'a t * 'a u
(** [wait ()] is a pair of a thread which sleeps forever (unless it
is resumed by one of the functions [wakeup], [wakeup_exn] below)
and the corresponding wakener. This thread does not block the
execution of the remainder of the program (except of course, if
another thread tries to wait for its termination). *)
val wakeup : 'a u -> 'a -> unit
(** [wakeup t e] makes the sleeping thread [t] terminate and return
the value of the expression [e]. *)
val wakeup_exn : 'a u -> exn -> unit
(** [wakeup_exn t e] makes the sleeping thread [t] fail with the
exception [e]. *)
val wakeup_later : 'a u -> 'a -> unit
(** Same as {!wakeup} but it is not guaranteed that the thread will
be wakeup immediately. *)
val wakeup_later_exn : 'a u -> exn -> unit
(** Same as {!wakeup_exn} but it is not guaranteed that the thread
will be wakeup immediately. *)
val waiter_of_wakener : 'a u -> 'a t
(** Returns the thread associated to a wakener. *)
(** {6 Threads state} *)
(** State of a thread *)
type 'a state =
| Return of 'a
(** The thread which has successfully terminated *)
| Fail of exn
(** The thread raised an exception *)
| Sleep
(** The thread is sleeping *)
val state : 'a t -> 'a state
(** [state t] returns the state of a thread *)
(** {6 Cancelable threads} *)
(** Cancelable threads are the same as regular threads except that
they can be canceled. *)
exception Canceled
(** Canceled threads fails with this exception *)
val task : unit -> 'a t * 'a u
(** [task ()] is the same as [wait ()] except that threads created
with [task] can be canceled. *)
val on_cancel : 'a t -> (unit -> unit) -> unit
(** [on_cancel t f] executes [f] when [t] is canceled. This is the
same as catching [Canceled]. *)
val cancel : 'a t -> unit
(** [cancel t] cancels the threads [t]. This means that the deepest
sleeping thread created with [task] and connected to [t] is
woken up with the exception {!Canceled}.
For example, in the following code:
{[
let waiter, wakener = task () in
cancel (waiter >> printl "plop")
]}
[waiter] will be woken up with {!Canceled}.
*)
val pick : 'a t list -> 'a t
(** [pick l] is the same as {!choose}, except that it cancels all
sleeping threads when one terminates.
Note: {!pick} leaves the local values of the current thread
unchanged. *)
val npick : 'a t list -> 'a list t
(** [npick l] is the same as {!nchoose}, except that it cancels all
sleeping threads when one terminates.
Note: {!npick} leaves the local values of the current thread
unchanged. *)
val protected : 'a t -> 'a t
(** [protected thread] creates a new cancelable thread which behave
as [thread] except that cancelling it does not cancel
[thread]. *)
(** {6 Pause} *)
val pause : unit -> unit t
(** [pause ()] is a sleeping thread which is wake up on the next
call to {!wakeup_paused}. A thread created with [pause] can be
canceled. *)
val wakeup_paused : unit -> unit
(** [wakeup_paused ()] wakes up all threads which suspended
themselves with {!pause}.
This function is called by the scheduler, before entering the
main loop. You usually do not have to call it directly, except
if you are writing a custom scheduler.
Note that if a paused thread resume and pause again, it will not
be wakeup at this point. *)
val paused_count : unit -> int
(** [paused_count ()] returns the number of thread currently
paused. *)
val register_pause_notifier : (int -> unit) -> unit
(** [register_pause_notifier f] register a function [f] that will be
called each time pause is called. The parameter passed to [f] is
the new number of threads paused. It is usefull to be able to
call {!wakeup_paused} when there is no scheduler *)
(** {6 Misc} *)
val on_success : 'a t -> ('a -> unit) -> unit
(** [on_success t f] executes [f] when [t] terminates without
failing. This is the same as:
{[
ignore_result (bind t (fun x -> f x; return ()))
]}
but a bit more efficient.
*)
val on_failure : 'a t -> (exn -> unit) -> unit
(** [on_failure t f] executes [f] when [t] terminates and
fails. This is the same as:
{[
ignore_result (catch t (fun e -> f e; return ()))
]}
but a bit more efficient.
*)
val on_termination : 'a t -> (unit -> unit) -> unit
(** [on_termination t f] executes [f] when [t] terminates. This is
the same as:
{[
ignore_result (finalize (fun () -> t) (fun () -> f (); return ()))
]}
but a bit more efficient.
*)
(**/**)
(* The functions below are probably not useful for the casual user.
They provide the basic primitives on which can be built multi-
threaded libraries such as Lwt_unix. *)
val poll : 'a t -> 'a option
(* [poll e] returns [Some v] if the thread [e] is terminated and
returned the value [v]. If the thread failed with some
exception, this exception is raised. If the thread is still
running, [poll e] returns [None] without blocking. *)
val apply : ('a -> 'b t) -> 'a -> 'b t
(* [apply f e] apply the function [f] to the expression [e]. If
an exception is raised during this application, it is caught
and the resulting thread fails with this exception. *)
(* Q: Could be called 'glue' or 'trap' or something? *)
val backtrace_bind : (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t
val backtrace_catch : (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t
val backtrace_try_bind : (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t
val backtrace_finalize : (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t

14
server/thirdparty/lwt-2.3.2/src/core/lwt.mllib vendored
View File

@ -1,14 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: ecdfab02163af2abad730a4cf20c2630)
Lwt_condition
Lwt_list
Lwt
Lwt_mutex
Lwt_mvar
Lwt_pool
Lwt_sequence
Lwt_stream
Lwt_switch
Lwt_util
Lwt_pqueue
# OASIS_STOP

63
server/thirdparty/lwt-2.3.2/src/core/lwt_condition.ml vendored
View File

@ -1,63 +0,0 @@
(******************************************************************************)
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_condition
******************************************************************************
* Copyright (c) 2009, Metaweb Technologies, Inc.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************)
open Lwt
type 'a t = 'a Lwt.u Lwt_sequence.t
let create = Lwt_sequence.create
let wait ?mutex cvar =
let waiter, wakener = Lwt.task () in
let node = Lwt_sequence.add_r wakener cvar in
on_cancel waiter (fun () -> Lwt_sequence.remove node);
let () =
match mutex with
| Some m -> Lwt_mutex.unlock m
| None -> ()
in
try_lwt
waiter
finally
match mutex with
| Some m -> Lwt_mutex.lock m
| None -> return ()
let signal cvar arg =
try
wakeup_later (Lwt_sequence.take_l cvar) arg
with Lwt_sequence.Empty ->
()
let broadcast cvar arg =
let wakeners = Lwt_sequence.fold_r (fun x l -> x :: l) cvar [] in
Lwt_sequence.iter_node_l Lwt_sequence.remove cvar;
List.iter (fun wakener -> wakeup_later wakener arg) wakeners

65
server/thirdparty/lwt-2.3.2/src/core/lwt_condition.mli vendored
View File

@ -1,65 +0,0 @@
(******************************************************************************)
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_condition
******************************************************************************
* Copyright (c) 2009, Metaweb Technologies, Inc.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************)
(** Conditions *)
(** Condition variables to synchronize between threads. *)
type 'a t
(** Condition variable type. The type parameter denotes the type of
value propagated from notifier to waiter. *)
val create : unit -> 'a t
(** [create ()] creates a new condition variable. *)
val wait : ?mutex:Lwt_mutex.t -> 'a t -> 'a Lwt.t
(** [wait mutex condvar] will cause the current thread to block,
awaiting notification for a condition variable, [condvar]. If
provided, the [mutex] must have been previously locked (within
the scope of [Lwt_mutex.with_lock], for example) and is
temporarily unlocked until the condition is notified. Upon
notification, [mutex] is re-locked before [wait] returns and
the thread's activity is resumed. When the awaited condition
is notified, the value parameter passed to [notify] is
returned. *)
val signal : 'a t -> 'a -> unit
(** [signal condvar value] notifies that a condition is ready. A
single waiting thread will be awoken and will receive the
notification value which will be returned from [wait]. Note
that condition notification is not "sticky", i.e. if there is
no waiter when [notify] is called, the notification will be
missed and the value discarded. *)
val broadcast : 'a t -> 'a -> unit
(** [broadcast condvar value] notifies all waiting threads. Each
will be awoken in turn and will receive the same notification
value. *)

189
server/thirdparty/lwt-2.3.2/src/core/lwt_list.ml vendored
View File

@ -1,189 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_list
* Copyright (C) 2010 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
open Lwt
let rec iter_s f l =
match l with
| [] ->
return ()
| x :: l ->
lwt () = f x in
iter_s f l
let rec iter_p f l =
match l with
| [] ->
return ()
| x :: l ->
let t = f x and lt = iter_p f l in
lwt () = t in
lt
let rec map_s f l =
match l with
| [] ->
return []
| x :: l ->
lwt x = f x in
lwt l = map_s f l in
return (x :: l)
let rec map_p f l =
match l with
| [] ->
return []
| x :: l ->
lwt x = f x and l = map_p f l in
return (x :: l)
let rec rev_map_append_s acc f l =
match l with
| [] ->
return acc
| x :: l ->
lwt x = f x in
rev_map_append_s (x :: acc) f l
let rev_map_s f l =
rev_map_append_s [] f l
let rec rev_map_append_p acc f l =
match l with
| [] ->
acc
| x :: l ->
rev_map_append_p (lwt x = f x and l = acc in return (x :: l)) f l
let rev_map_p f l =
rev_map_append_p (return []) f l
let rec fold_left_s f acc l =
match l with
| [] ->
return acc
| x :: l ->
lwt acc = f acc x in
fold_left_s f acc l
let rec fold_right_s f l acc =
match l with
| [] ->
return acc
| x :: l ->
lwt acc = fold_right_s f l acc in
f x acc
let rec for_all_s f l =
match l with
| [] ->
return true
| x :: l ->
f x >>= function
| true ->
for_all_s f l
| false ->
return false
let rec for_all_p f l =
match l with
| [] ->
return true
| x :: l ->
lwt bx = f x and bl = for_all_p f l in
return (bx && bl)
let rec exists_s f l =
match l with
| [] ->
return false
| x :: l ->
f x >>= function
| true ->
return true
| false ->
exists_s f l
let rec exists_p f l =
match l with
| [] ->
return false
| x :: l ->
lwt bx = f x and bl = exists_p f l in
return (bx || bl)
let rec find_s f l =
match l with
| [] ->
raise_lwt Not_found
| x :: l ->
f x >>= function
| true ->
return x
| false ->
find_s f l
let rec filter_s f l =
match l with
| [] ->
return []
| x :: l ->
f x >>= function
| true ->
lwt l = filter_s f l in
return (x :: l)
| false ->
filter_s f l
let rec filter_p f l =
match l with
| [] ->
return []
| x :: l ->
lwt bx = f x and l = filter_p f l in
if bx then
return (x :: l)
else
return l
let rec partition_s f l =
match l with
| [] ->
return ([], [])
| x :: l ->
lwt bx = f x in
lwt l_l, l_r = partition_s f l in
if bx then
return (x :: l_l, l_r)
else
return (l_l, x :: l_r)
let rec partition_p f l =
match l with
| [] ->
return ([], [])
| x :: l ->
lwt bx = f x and l_l, l_r = partition_p f l in
if bx then
return (x :: l_l, l_r)
else
return (l_l, x :: l_r)

59
server/thirdparty/lwt-2.3.2/src/core/lwt_list.mli vendored
View File

@ -1,59 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_list
* Copyright (C) 2010 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** List helpers *)
(** Note: this module use the same naming convention as
{!Lwt_stream}. *)
(** {6 List iterators} *)
val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t
val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t
(** {6 List scanning} *)
val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
(** {6 List searching} *)
val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a Lwt.t
val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t
val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t
val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t
val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t

60
server/thirdparty/lwt-2.3.2/src/core/lwt_mutex.ml vendored
View File

@ -1,60 +0,0 @@
(* Lightweight thread library for Objective Caml
* 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
type t = { mutable locked : bool; mutable waiters : unit Lwt.u Lwt_sequence.t }
let create () = { locked = false; waiters = Lwt_sequence.create () }
let rec lock m =
if m.locked then begin
let (res, w) = Lwt.task () in
let node = Lwt_sequence.add_r w m.waiters in
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
res
end else begin
m.locked <- true;
Lwt.return ()
end
let unlock m =
if m.locked then begin
if Lwt_sequence.is_empty m.waiters then
m.locked <- false
else
(* We do not use [Lwt.wakeup] here to avoid a stack overflow
when unlocking a lot of threads. *)
Lwt.wakeup_later (Lwt_sequence.take_l m.waiters) ()
end
let with_lock m f =
lwt () = lock m in
try_lwt
f ()
finally
unlock m;
return ()
let is_locked m = m.locked
let is_empty m = Lwt_sequence.is_empty m.waiters

62
server/thirdparty/lwt-2.3.2/src/core/lwt_mutex.mli vendored
View File

@ -1,62 +0,0 @@
(* Lightweight thread library for Objective Caml
* 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 immediatly
- if it is locked, then {!lock} waits for all threads waiting on
the mutex to terminate, then it resumes when the last one
unlocks the mutex
Note: threads are wake up is the same order they try to lock the
mutex *)
val unlock : t -> unit
(** [unlock mutex] unlock the mutex if no threads is waiting on
it. Otherwise it will eventually removes the first one and
resumes it. *)
val is_locked : t -> bool
(** [locked mutex] returns whether [mutex] is currently locked *)
val is_empty : t -> bool
(** [is_empty mutex] returns [true] if they are no thread waiting on
the mutex, and [false] otherwise *)
val with_lock : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t
(** [with_lock lock f] is used to lock a mutex within a block scope.
The function [f ()] is called with the mutex locked, and its
result is returned from the call to {with_lock}. If an exception
is raised from f, the mutex is also unlocked before the scope of
{with_lock} is exited. *)

87
server/thirdparty/lwt-2.3.2/src/core/lwt_mvar.ml vendored
View File

@ -1,87 +0,0 @@
(* -*- Mode: Caml; indent-tabs-mode: nil -*- *)
(******************************************************************************)
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_mon
******************************************************************************
* Copyright (c) 2009, Metaweb Technologies, Inc.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************)
let return_unit = Lwt.return ()
type 'a t = {
mutable contents : 'a option;
(* Current contents *)
mutable writers : ('a * unit Lwt.u) Lwt_sequence.t;
(* Threads waiting to put a value *)
mutable readers : 'a Lwt.u Lwt_sequence.t;
(* Threads waiting for a value *)
}
let create_empty () =
{ contents = None;
writers = Lwt_sequence.create ();
readers = Lwt_sequence.create () }
let create v =
{ contents = Some v;
writers = Lwt_sequence.create ();
readers = Lwt_sequence.create () }
let put mvar v =
match mvar.contents with
| None ->
begin match Lwt_sequence.take_opt_l mvar.readers with
| None ->
mvar.contents <- Some v
| Some w ->
Lwt.wakeup_later w v
end;
return_unit
| Some _ ->
let (res, w) = Lwt.task () in
let node = Lwt_sequence.add_r (v, w) mvar.writers in
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
res
let take mvar =
match mvar.contents with
| Some v ->
begin match Lwt_sequence.take_opt_l mvar.writers with
| Some(v', w) ->
mvar.contents <- Some v';
Lwt.wakeup_later w ()
| None ->
mvar.contents <- None
end;
Lwt.return v
| None ->
let (res, w) = Lwt.task () in
let node = Lwt_sequence.add_r w mvar.readers in
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
res

63
server/thirdparty/lwt-2.3.2/src/core/lwt_mvar.mli vendored
View File

@ -1,63 +0,0 @@
(* -*- Mode: Caml; indent-tabs-mode: nil -*- *)
(******************************************************************************)
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_mon
******************************************************************************
* Copyright (c) 2009, Metaweb Technologies, Inc.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************)
(** Mailbox variables *)
(** "Mailbox" variables implement a synchronising variable, used for
communication between concurrent threads.
This code adapted from
{{:http://eigenclass.org/hiki.rb?cmd=view&p=lightweight-threads-with-lwt}Comparing lightweight threads (eigenclass.org)} *)
type 'a t
(** The type of a mailbox variable. Mailbox variables are used to
communicate values between threads in a synchronous way. The
type parameter specifies the type of the value propagated from
[put] to [take]. *)
val create : 'a -> 'a t
(** [create v] creates a new mailbox variable containing value [v]. *)
val create_empty : unit -> 'a t
(** [create ()] creates a new empty mailbox variable. *)
val put : 'a t -> 'a -> unit Lwt.t
(** [put mvar value] puts a value into a mailbox variable. This
value will remain in the mailbox until [take] is called to
remove it. If the mailbox is not empty, the current thread will
block until it is emptied. *)
val take : 'a t -> 'a Lwt.t
(** [take mvar] will take any currently available value from the
mailbox variable. If no value is currently available, the
current thread will block, awaiting a value to be [put] by
another thread. *)

93
server/thirdparty/lwt-2.3.2/src/core/lwt_pool.ml vendored
View File

@ -1,93 +0,0 @@
(* Lwt
* http://www.ocsigen.org
* Copyright (C) 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
(*
XXX Close after some timeout
...
*)
type 'a t =
{ create : unit -> 'a Lwt.t;
check : 'a -> (bool -> unit) -> unit;
max : int;
mutable count : int;
list : 'a Queue.t;
waiters : 'a Lwt.u Lwt_sequence.t }
let create m ?(check = fun _ f -> f true) create =
{ max = m;
create = create;
check = check;
count = 0;
list = Queue.create ();
waiters = Lwt_sequence.create () }
let create_member p =
try_lwt
p.count <- p.count + 1; (* must be done before p.create *)
lwt mem = p.create () in
return mem
with exn ->
(* create failed, so don't increment count *)
p.count <- p.count - 1;
raise_lwt exn
let acquire p =
try
return (Queue.take p.list)
with Queue.Empty ->
if p.count < p.max then
create_member p
else begin
let waiter, wakener = task () in
let node = Lwt_sequence.add_r wakener p.waiters in
on_cancel waiter (fun () -> Lwt_sequence.remove node);
waiter
end
let release p c =
try
wakeup_later (Lwt_sequence.take_l p.waiters) c
with Lwt_sequence.Empty ->
Queue.push c p.list
let checked_release p c =
p.check c begin fun ok ->
if ok then
release p c
else
ignore (p.count <- p.count - 1;
lwt c = create_member p in
release p c;
return ())
end
let use p f =
lwt c = acquire p in
try_lwt
lwt r = f c in
release p c;
return r
with e ->
checked_release p c;
raise_lwt e

40
server/thirdparty/lwt-2.3.2/src/core/lwt_pool.mli vendored
View File

@ -1,40 +0,0 @@
(* Lwt
* http://www.ocsigen.org
* Copyright (C) 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.
*)
(** Creating pools (for example pools of connections to a database). *)
(** Instead of creating a new connection each time you need one,
keep a pool of opened connections and reuse opened connections
that are free.
*)
(** Type of pools *)
type 'a t
(** [create n f] creates a new pool with at most [n] members.
[f] is the function to use to create a new pool member. *)
val create :
int -> ?check:('a -> (bool -> unit) -> unit) -> (unit -> 'a Lwt.t) -> 'a t
(** [use p f] takes one free member of the pool [p] and gives it to the function
[f].
*)
val use : 'a t -> ('a -> 'b Lwt.t) -> 'b Lwt.t

108
server/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.ml vendored
View File

@ -1,108 +0,0 @@
(* Lightweight thread library for Objective Caml
* 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

44
server/thirdparty/lwt-2.3.2/src/core/lwt_pqueue.mli vendored
View File

@ -1,44 +0,0 @@
(* Lightweight thread library for Objective Caml
* 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

209
server/thirdparty/lwt-2.3.2/src/core/lwt_sequence.ml vendored
View File

@ -1,209 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_sequence
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
exception Empty
type 'a t = {
mutable prev : 'a t;
mutable next : 'a t;
}
type 'a node = {
mutable node_prev : 'a t;
mutable node_next : 'a t;
mutable node_data : 'a;
mutable node_active : bool;
}
external seq_of_node : 'a node -> 'a t = "%identity"
external node_of_seq : 'a t -> 'a node = "%identity"
(* +-----------------------------------------------------------------+
| Operations on nodes |
+-----------------------------------------------------------------+ *)
let get node =
node.node_data
let set node data =
node.node_data <- data
let remove node =
if node.node_active then begin
node.node_active <- false;
let seq = seq_of_node node in
seq.prev.next <- seq.next;
seq.next.prev <- seq.prev
end
(* +-----------------------------------------------------------------+
| Operations on sequences |
+-----------------------------------------------------------------+ *)
let create () =
let rec seq = { prev = seq; next = seq } in
seq
let is_empty seq = seq.next == seq
let length seq =
let rec loop curr len =
if curr == seq then
len
else
let node = node_of_seq curr in
if node.node_active then
loop node.node_next (len + 1)
else
loop node.node_next len
in
loop seq.next 0
let add_l data seq =
let node = { node_prev = seq; node_next = seq.next; node_data = data; node_active = true } in
seq.next.prev <- seq_of_node node;
seq.next <- seq_of_node node;
node
let add_r data seq =
let node = { node_prev = seq.prev; node_next = seq; node_data = data; node_active = true } in
seq.prev.next <- seq_of_node node;
seq.prev <- seq_of_node node;
node
let take_l seq =
if is_empty seq then
raise Empty
else begin
let node = node_of_seq seq.next in
remove node;
node.node_data
end
let take_r seq =
if is_empty seq then
raise Empty
else begin
let node = node_of_seq seq.prev in
remove node;
node.node_data
end
let take_opt_l seq =
if is_empty seq then
None
else begin
let node = node_of_seq seq.next in
remove node;
Some node.node_data
end
let take_opt_r seq =
if is_empty seq then
None
else begin
let node = node_of_seq seq.prev in
remove node;
Some node.node_data
end
let transfer_l s1 s2 =
s2.next.prev <- s1.prev;
s1.prev.next <- s2.next;
s2.next <- s1.next;
s1.next.prev <- s2;
s1.prev <- s1;
s1.next <- s1
let transfer_r s1 s2 =
s2.prev.next <- s1.next;
s1.next.prev <- s2.prev;
s2.prev <- s1.prev;
s1.prev.next <- s2;
s1.prev <- s1;
s1.next <- s1
let iter_l f seq =
let rec loop curr =
if curr != seq then begin
let node = node_of_seq curr in
if node.node_active then f node.node_data;
loop node.node_next
end
in
loop seq.next
let iter_r f seq =
let rec loop curr =
if curr != seq then begin
let node = node_of_seq curr in
if node.node_active then f node.node_data;
loop node.node_prev
end
in
loop seq.prev
let iter_node_l f seq =
let rec loop curr =
if curr != seq then begin
let node = node_of_seq curr in
if node.node_active then f node;
loop node.node_next
end
in
loop seq.next
let iter_node_r f seq =
let rec loop curr =
if curr != seq then begin
let node = node_of_seq curr in
if node.node_active then f node;
loop node.node_prev
end
in
loop seq.prev
let fold_l f seq acc =
let rec loop curr acc =
if curr == seq then
acc
else
let node = node_of_seq curr in
if node.node_active then
loop node.node_next (f node.node_data acc)
else
loop node.node_next acc
in
loop seq.next acc
let fold_r f seq acc =
let rec loop curr acc =
if curr == seq then
acc
else
let node = node_of_seq curr in
if node.node_active then
loop node.node_prev (f node.node_data acc)
else
loop node.node_next acc
in
loop seq.prev acc

137
server/thirdparty/lwt-2.3.2/src/core/lwt_sequence.mli vendored
View File

@ -1,137 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_sequence
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Mutable sequence of elements *)
(** A sequence is an object holding a list of elements which support
the following operations:
- adding an element to the left or the right in time and space O(1)
- taking an element from the left or the right in time and space O(1)
- removing a previously added element from a sequence in time and space O(1)
- removing an element while the sequence is being transversed.
*)
type 'a t
(** Type of a sequence holding values of type ['a] *)
type 'a node
(** Type of a node holding one value of type ['a] in a sequence *)
(** {6 Operation on nodes} *)
val get : 'a node -> 'a
(** Returns the contents of a node *)
val set : 'a node -> 'a -> unit
(** Change the contents of a node *)
val remove : 'a node -> unit
(** Removes a node from the sequence it is part of. It does nothing
if the node has already been removed. *)
(** {6 Operations on sequence} *)
val create : unit -> 'a t
(** [create ()] creates a new empty sequence *)
val is_empty : 'a t -> bool
(** Returns [true] iff the given sequence is empty *)
val length : 'a t -> int
(** Returns the number of elemenets in the given sequence. This is a
O(n) operation where [n] is the number of elements in the
sequence. *)
val add_l : 'a -> 'a t -> 'a node
(** [add_l x s] adds [x] to the left of the sequence [s] *)
val add_r : 'a -> 'a t -> 'a node
(** [add_l x s] adds [x] to the right of the sequence [s] *)
exception Empty
(** Exception raised by [take_l] and [tale_s] and when the sequence
is empty *)
val take_l : 'a t -> 'a
(** [take_l x s] remove and returns the leftmost element of [s]
@raise Empty if the sequence is empty *)
val take_r : 'a t -> 'a
(** [take_l x s] remove and returns the rightmost element of [s]
@raise Empty if the sequence is empty *)
val take_opt_l : 'a t -> 'a option
(** [take_opt_l x s] remove and returns [Some x] where [x] is the
leftmost element of [s] or [None] if [s] is empty *)
val take_opt_r : 'a t -> 'a option
(** [take_opt_l x s] remove and returns [Some x] where [x] is the
rightmost element of [s] or [None] if [s] is empty *)
val transfer_l : 'a t -> 'a t -> unit
(** [transfer_l s1 s2] removes all elements of [s1] and add them at
the left of [s2]. This operation runs in constant time and
space. *)
val transfer_r : 'a t -> 'a t -> unit
(** [transfer_r s1 s2] removes all elements of [s1] and add them at
the right of [s2]. This operation runs in constant time and
space. *)
(** {6 Sequence iterators} *)
(** Note: it is OK to remove a node while traversing a sequence *)
val iter_l : ('a -> unit) -> 'a t -> unit
(** [iter_l f s] applies [f] on all elements of [s] starting from
the left *)
val iter_r : ('a -> unit) -> 'a t -> unit
(** [iter_l f s] applies [f] on all elements of [s] starting from
the right *)
val iter_node_l : ('a node -> unit) -> 'a t -> unit
(** [iter_l f s] applies [f] on all nodes of [s] starting from
the left *)
val iter_node_r : ('a node -> unit) -> 'a t -> unit
(** [iter_l f s] applies [f] on all nodes of [s] starting from
the right *)
val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
(** [fold_l f s] is:
{[
fold_l f s x = f en (... (f e2 (f e1 x)))
]}
where [e1], [e2], ..., [en] are the elements of [s]
*)
val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
(** [fold_r f s] is:
{[
fold_r f s x = f e1 (f e2 (... (f en x)))
]}
where [e1], [e2], ..., [en] are the elements of [s]
*)

759
server/thirdparty/lwt-2.3.2/src/core/lwt_stream.ml vendored
View File

@ -1,759 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_stream
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
open Lwt
exception Empty
type 'a t = {
next : unit -> 'a option Lwt.t;
(* The source of the stream *)
queue : 'a option Queue.t;
(* Queue of pending elements, which are not yet consumed *)
clones : 'a option Queue.t Weak.t ref;
(* List of queues of all clones of this event (including this
event) *)
mutex : Lwt_mutex.t;
(* Mutex to prevent concurrent access to [next] *)
}
let add_clone wa q =
let len = Weak.length !wa in
(* loop search for a free cell in [wa] and fill it with [q]: *)
let rec loop i =
if i = len then begin
(* Growing *)
let clones = Weak.create (len + 1) in
Weak.blit !wa 0 clones 0 len;
wa := clones;
Weak.set clones len (Some q)
end else if Weak.check !wa i then
loop (i + 1)
else
Weak.set !wa i (Some q)
in
loop 0
let clone s =
let s' = {
next = s.next;
queue = Queue.copy s.queue;
clones = s.clones;
mutex = s.mutex;
} in
add_clone s'.clones s'.queue;
s'
let from f =
let s = {
next = f;
queue = Queue.create ();
clones = ref(Weak.create 1);
mutex = Lwt_mutex.create ();
} in
Weak.set !(s.clones) 0 (Some s.queue);
s
let of_list l =
let l = ref l in
from (fun () ->
match !l with
| [] -> return None
| x :: l' -> l := l'; return (Some x))
let of_array a =
let len = Array.length a and i = ref 0 in
from (fun () ->
if !i = len then
return None
else begin
let c = Array.unsafe_get a !i in
incr i;
return (Some c)
end)
let of_string s =
let len = String.length s and i = ref 0 in
from (fun () ->
if !i = len then
return None
else begin
let c = String.unsafe_get s !i in
incr i;
return (Some c)
end)
module EQueue :
sig
type 'a t
val create : unit -> 'a t * ('a option -> unit)
val pop : 'a t -> 'a option Lwt.t
end =
struct
type 'a state =
| No_mail
| Waiting of 'a option Lwt.u
| Full of 'a option Queue.t
type 'a t = {
mutable state : 'a state;
}
let create () =
let box = { state = No_mail } in
let weak_box = Weak.create 1 in
Weak.set weak_box 0 (Some box);
let push v =
match Weak.get weak_box 0 with
| None -> ()
| Some box ->
match box.state with
| No_mail ->
let q = Queue.create () in
Queue.push v q;
box.state <- Full q
| Waiting wakener ->
box.state <- No_mail;
wakeup_later wakener v
| Full q ->
Queue.push v q
in
(box, push)
let pop b = match b.state with
| No_mail ->
let waiter, wakener = task () in
Lwt.on_cancel waiter (fun () -> b.state <- No_mail);
b.state <- Waiting wakener;
waiter
| Waiting _ ->
(* Calls to next are serialized, so this case will never
happened *)
assert false
| Full q ->
let v = Queue.take q in
if Queue.is_empty q then b.state <- No_mail;
return v
end
let create () =
let box, push = EQueue.create () in
(from (fun () -> EQueue.pop box), push)
let push_clones wa x =
for i = 0 to Weak.length wa - 1 do
match Weak.get wa i with
| Some q ->
Queue.push x q
| None ->
()
done
let peek s =
if Queue.is_empty s.queue then
Lwt_mutex.with_lock s.mutex begin fun () ->
if Queue.is_empty s.queue then begin
lwt result = s.next () in
push_clones !(s.clones) result;
return result
end else
return (Queue.top s.queue)
end
else
return (Queue.top s.queue)
let rec force n s =
if Queue.length s.queue >= n then
return ()
else
Lwt_mutex.with_lock s.mutex begin fun () ->
if Queue.length s.queue >= n then
return false
else begin
lwt result = s.next () in
push_clones !(s.clones) result;
if result = None then
return false
else
return true
end
end >>= function
| true ->
force n s
| false ->
return ()
let npeek n s =
lwt () = force n s in
let l, _ =
Queue.fold
(fun (l, n) x ->
if n > 0 then
match x with
| Some x -> (x :: l, n - 1)
| None -> (l, n)
else
(l, n))
([], n) s.queue
in
return (List.rev l)
let rec get s =
if Queue.is_empty s.queue then
Lwt_mutex.with_lock s.mutex begin fun () ->
if Queue.is_empty s.queue then begin
lwt x = s.next () in
(* This prevent from calling s.next when the stream has
terminated: *)
if x = None then Queue.push None s.queue;
let wa = !(s.clones) in
for i = 0 to Weak.length wa - 1 do
match Weak.get wa i with
| Some q when q != s.queue ->
Queue.push x q
| _ ->
()
done;
return x
end else begin
let x = Queue.take s.queue in
if x = None then Queue.push None s.queue;
return x
end
end
else begin
let x = Queue.take s.queue in
if x = None then Queue.push None s.queue;
return x
end
let nget n s =
let rec loop n =
if n <= 0 then
return []
else
get s >>= function
| Some x ->
lwt l = loop (n - 1) in
return (x :: l)
| None ->
return []
in
loop n
let get_while f s =
let rec loop () =
peek s >>= function
| Some x ->
let test = f x in
if test then begin
ignore (Queue.take s.queue);
lwt l = loop () in
return (x :: l)
end else
return []
| None ->
return []
in
loop ()
let get_while_s f s =
let rec loop () =
peek s >>= function
| Some x ->
lwt test = f x in
if test then begin
ignore (Queue.take s.queue);
lwt l = loop () in
return (x :: l)
end else
return []
| None ->
return []
in
loop ()
let next s = get s >>= function
| Some x -> return x
| None -> raise_lwt Empty
let last_new s =
match Lwt.state (peek s) with
| Return None ->
raise_lwt Empty
| Sleep ->
next s
| Fail exn ->
raise_lwt exn
| Return(Some x) ->
let _ = Queue.take s.queue in
let rec loop last =
match Lwt.state (peek s) with
| Sleep | Return None ->
return last
| Return(Some x) ->
let _ = Queue.take s.queue in
loop x
| Fail exn ->
raise_lwt exn
in
loop x
let to_list s =
let rec loop () =
get s >>= function
| Some x ->
lwt l = loop () in
return (x :: l)
| None ->
return []
in
loop ()
let to_string s =
let buf = Buffer.create 42 in
let rec loop () =
get s >>= function
| Some x ->
Buffer.add_char buf x;
loop ()
| None ->
return (Buffer.contents buf)
in
loop ()
let junk s =
lwt _ = get s in
return ()
let njunk n s =
let rec loop n =
if n <= 0 then
return ()
else
lwt _ = get s in
loop (n - 1)
in
loop n
let junk_while f s =
let rec loop () =
peek s >>= function
| Some x ->
let test = f x in
if test then begin
ignore (Queue.take s.queue);
loop ()
end else
return ()
| None ->
return ()
in
loop ()
let junk_while_s f s =
let rec loop () =
peek s >>= function
| Some x ->
lwt test = f x in
if test then begin
ignore (Queue.take s.queue);
loop ()
end else
return ()
| None ->
return ()
in
loop ()
let junk_old s =
let rec loop () =
match Lwt.state (peek s) with
| Sleep ->
return ()
| _ ->
ignore (Queue.take s.queue);
loop ()
in
loop ()
let get_available s =
let rec loop () =
match Lwt.state (peek s) with
| Sleep | Return None ->
[]
| Return(Some x) ->
ignore (Queue.take s.queue);
x :: loop ()
| Fail exn ->
raise exn
in
loop ()
let get_available_up_to n s =
let rec loop = function
| 0 ->
[]
| n ->
match Lwt.state (peek s) with
| Sleep | Return None ->
[]
| Return(Some x) ->
ignore (Queue.take s.queue);
x :: loop (n - 1)
| Fail exn ->
raise exn
in
loop n
let is_empty s = peek s >|= fun x -> x = None
let map f s =
from (fun () -> get s >>= function
| Some x ->
let x = f x in
return (Some x)
| None ->
return None)
let map_s f s =
from (fun () -> get s >>= function
| Some x ->
lwt x = f x in
return (Some x)
| None ->
return None)
let filter f s =
let rec next () =
get s >>= function
| Some x as result ->
let test = f x in
if test then
return result
else
next ()
| None ->
return None
in
from next
let filter_s f s =
let rec next () =
get s >>= function
| Some x as result ->
lwt test = f x in
if test then
return result
else
next ()
| None ->
return None
in
from next
let filter_map f s =
let rec next () =
get s >>= function
| Some x ->
let x = f x in
(match x with
| Some _ ->
return x
| None ->
next ())
| None ->
return None
in
from next
let filter_map_s f s =
let rec next () =
get s >>= function
| Some x ->
lwt x = f x in
(match x with
| Some _ ->
return x
| None ->
next ())
| None ->
return None
in
from next
let map_list f s =
let pendings = ref [] in
let rec next () =
match !pendings with
| [] ->
get s >>= (function
| Some x ->
let l = f x in
pendings := l;
next ()
| None ->
return None)
| x :: l ->
pendings := l;
return (Some x)
in
from next
let map_list_s f s =
let pendings = ref [] in
let rec next () =
match !pendings with
| [] ->
get s >>= (function
| Some x ->
lwt l = f x in
pendings := l;
next ()
| None ->
return None)
| x :: l ->
pendings := l;
return (Some x)
in
from next
let flatten s =
map_list (fun l -> l) s
let fold f s acc =
let rec loop acc =
get s >>= function
| Some x ->
let acc = f x acc in
loop acc
| None ->
return acc
in
loop acc
let fold_s f s acc =
let rec loop acc =
get s >>= function
| Some x ->
lwt acc = f x acc in
loop acc
| None ->
return acc
in
loop acc
let iter f s =
let rec loop () =
get s >>= function
| Some x ->
let () = f x in
loop ()
| None ->
return ()
in
loop ()
let iter_s f s =
let rec loop () =
get s >>= function
| Some x ->
lwt () = f x in
loop ()
| None ->
return ()
in
loop ()
let iter_p f s =
let rec loop () =
get s >>= function
| Some x ->
f x <&> loop ()
| None ->
return ()
in
loop ()
let find f s =
let rec loop () =
get s >>= function
| Some x as result ->
let test = f x in
if test then
return result
else
loop ()
| None ->
return None
in
loop ()
let find_s f s =
let rec loop () =
get s >>= function
| Some x as result ->
lwt test = f x in
if test then
return result
else
loop ()
| None ->
return None
in
loop ()
let rec find_map f s =
let rec loop () =
get s >>= function
| Some x ->
let x = f x in
(match x with
| Some _ ->
return x
| None ->
loop ())
| None ->
return None
in
loop ()
let rec find_map_s f s =
let rec loop () =
get s >>= function
| Some x ->
lwt x = f x in
(match x with
| Some _ ->
return x
| None ->
loop ())
| None ->
return None
in
loop ()
let rec combine s1 s2 =
let next () =
lwt n1 = get s1 and n2 = get s2 in
match n1, n2 with
| Some x1, Some x2 ->
return (Some(x1, x2))
| _ ->
return None
in
from next
let append s1 s2 =
let current_s = ref s1 and s1_finished = ref false in
let rec next () =
get !current_s >>= function
| Some _ as result ->
return result
| None ->
if !s1_finished then
return None
else begin
s1_finished := true;
current_s := s2;
next ()
end
in
from next
let concat s_top =
let current_s = ref(from(fun () -> return None)) in
let rec next () =
get !current_s >>= function
| Some _ as result ->
return result
| None ->
get s_top >>= function
| Some s ->
current_s := s;
next ()
| None ->
return None
in
from next
let choose streams =
let source s = (s, peek s >|= fun x -> (s, x)) in
let streams = ref (List.rev_map source streams) in
let rec next () =
match !streams with
| [] ->
return None
| l ->
lwt s, x = Lwt.choose (List.map snd l) in
let l = List.remove_assq s l in
match x with
| Some _ ->
lwt () = junk s in
streams := source s :: l;
return x
| None ->
next ()
in
from next
let parse s f =
let s' = clone s in
try_lwt
f s
with exn ->
Queue.clear s.queue;
Queue.transfer s'.queue s.queue;
raise_lwt exn
let hexdump stream =
let buf = Buffer.create 80 and num = ref 0 in
from begin fun _ ->
nget 16 stream >>= function
| [] ->
return None
| l ->
Buffer.clear buf;
Printf.bprintf buf "%08x| " !num;
num := !num + 16;
let rec bytes pos = function
| [] ->
blanks pos
| x :: l ->
if pos = 8 then Buffer.add_char buf ' ';
Printf.bprintf buf "%02x " (Char.code x);
bytes (pos + 1) l
and blanks pos =
if pos < 16 then begin
if pos = 8 then
Buffer.add_string buf " "
else
Buffer.add_string buf " ";
blanks (pos + 1)
end
in
bytes 0 l;
Buffer.add_string buf " |";
List.iter (fun ch -> Buffer.add_char buf (if ch >= '\x20' && ch <= '\x7e' then ch else '.')) l;
Buffer.add_char buf '|';
return (Some(Buffer.contents buf))
end

242
server/thirdparty/lwt-2.3.2/src/core/lwt_stream.mli vendored
View File

@ -1,242 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_stream
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Data streams *)
type 'a t
(** Type of a stream holding values of type ['a] *)
(** Naming convention: in this module all function taking a function
which is applied to all element of the streams are suffixed by:
- [_s] when the function returns a thread and calls are serialised
- [_p] when the function returns a thread and calls are parallelised
*)
(** {6 Construction} *)
val from : (unit -> 'a option Lwt.t) -> 'a t
(** [from f] creates an stream from the given input function. [f] is
called each time more input is needed, and the stream ends when
[f] returns [None]. *)
val create : unit -> 'a t * ('a option -> unit)
(** [create ()] returns a new stream and a push function *)
val of_list : 'a list -> 'a t
(** [of_list l] creates a stream returning all elements of [l] *)
val of_array : 'a array -> 'a t
(** [of_array a] creates a stream returning all elements of [a] *)
val of_string : string -> char t
(** [of_string str] creates a stream returning all characters of
[str] *)
val clone : 'a t -> 'a t
(** [clone st] clone the given stream. Operations on each stream
will not affect the other.
For example:
{[
# let st1 = Lwt_stream.of_list [1; 2; 3];;
val st1 : int Lwt_stream.t = <abstr>
# let st2 = Lwt_stream.clone st1;;
val st2 : int Lwt_stream.t = <abstr>
# lwt x = Lwt_stream.next st1;;
val x : int = 1
# lwt y = Lwt_stream.next st2;;
val y : int = 1
]}
*)
(** {6 Destruction} *)
val to_list : 'a t -> 'a list Lwt.t
(** Returns the list of elements of the given stream *)
val to_string : char t -> string Lwt.t
(** Returns the word composed of all characters of the given
stream *)
(** {6 Data retreival} *)
exception Empty
(** Exception raised when trying to retreive data from an empty
stream. *)
val peek : 'a t -> 'a option Lwt.t
(** [peek st] returns the first element of the stream, if any,
without removing it. *)
val npeek : int -> 'a t -> 'a list Lwt.t
(** [npeek n st] returns at most the first [n] elements of [st],
without removing them. *)
val get : 'a t -> 'a option Lwt.t
(** [get st] remove and returns the first element of the stream, if
any. *)
val nget : int -> 'a t -> 'a list Lwt.t
(** [nget n st] remove and returns at most the first [n] elements of
[st]. *)
val get_while : ('a -> bool) -> 'a t -> 'a list Lwt.t
val get_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a list Lwt.t
(** [get_while f st] returns the longest prefix of [st] where all
elements satisfy [f]. *)
val next : 'a t -> 'a Lwt.t
(** [next st] remove and returns the next element of the stream, of
fail with {!Empty} if the stream is empty. *)
val last_new : 'a t -> 'a Lwt.t
(** [next_new st] if no element are available on [st] without
sleeping, then it is the same as [next st]. Otherwise it removes
all elements of [st] that are ready except the last one, and
return it.
If fails with {!Empty} if the stream has no more elements *)
val junk : 'a t -> unit Lwt.t
(** [junk st] remove the first element of [st]. *)
val njunk : int -> 'a t -> unit Lwt.t
(** [njunk n st] removes at most the first [n] elements of the
stream. *)
val junk_while : ('a -> bool) -> 'a t -> unit Lwt.t
val junk_while_s : ('a -> bool Lwt.t) -> 'a t -> unit Lwt.t
(** [junk_while f st] removes all elements at the beginning of the
streams which satisfy [f]. *)
val junk_old : 'a t -> unit Lwt.t
(** [junk_old st] removes all elements that are ready to be read
without yeilding from [st].
For example the [read_password] function of [Lwt_read_line] use
that to junk key previously typed by the user.
*)
val get_available : 'a t -> 'a list
(** [get_available l] returns all available elements of [l] without
blocking *)
val get_available_up_to : int -> 'a t -> 'a list
(** [get_available_up_to l n] returns up to [n] elements of [l]
without blocking *)
val is_empty : 'a t -> bool Lwt.t
(** [is_empty enum] returns wether the given stream is empty *)
(** {6 Stream transversal} *)
(** Note: all the following functions are destructive.
For example:
{[
# let st1 = Lwt_stream.of_list [1; 2; 3];;
val st1 : int Lwt_stream.t = <abstr>
# let st2 = Lwt_stream.map string_of_int st1;;
val st2 : string Lwt_stream.t = <abstr>
# lwt x = Lwt_stream.next st1;;
val x : int = 1
# lwt y = Lwt_stream.next st2;;
val y : string = "2"
]}
*)
val choose : 'a t list -> 'a t
(** [choose l] creates an stream from a list of streams. The
resulting stream will returns elements returned by any stream of
[l] in an unspecified order. *)
val map : ('a -> 'b) -> 'a t -> 'b t
val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t
(** [map f st] maps the value returned by [st] with [f] *)
val filter : ('a -> bool) -> 'a t -> 'a t
val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t
(** [filter f st] keeps only value [x] such that [f x] is [true] *)
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t
(** [filter_map f st] filter and map [st] at the same time *)
val map_list : ('a -> 'b list) -> 'a t -> 'b t
val map_list_s : ('a -> 'b list Lwt.t) -> 'a t -> 'b t
(** [map_list f st] applies [f] on each element of [st] and flattens
the lists returned *)
val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b Lwt.t
val fold_s : ('a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t
(** [fold f s x] fold_like function for streams. *)
val iter : ('a -> unit) -> 'a t -> unit Lwt.t
val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
(** [iter f s] iterates over all elements of the stream *)
val find : ('a -> bool) -> 'a t -> 'a option Lwt.t
val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t
(** [find f s] find an element in a stream. *)
val find_map : ('a -> 'b option) -> 'a t -> 'b option Lwt.t
val find_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b option Lwt.t
(** [find f s] find and map at the same time. *)
val combine : 'a t -> 'b t -> ('a * 'b) t
(** [combine s1 s2] combine two streams. The stream will ends when
the first stream ends. *)
val append : 'a t -> 'a t -> 'a t
(** [append s1 s2] returns a stream which returns all elements of
[s1], then all elements of [s2] *)
val concat : 'a t t -> 'a t
(** [concat st] returns the concatenation of all streams of [st]. *)
val flatten : 'a list t -> 'a t
(** [flatten st = map_list (fun l -> l) st] *)
(** {6 Parsing} *)
val parse : 'a t -> ('a t -> 'b Lwt.t) -> 'b Lwt.t
(** [parse st f] parses [st] with [f]. If [f] raise an exception,
[st] is restored to its previous state. *)
(** {6 Misc} *)
val hexdump : char t -> string t
(** [hexdump byte_stream] returns a stream which is the same as the
output of [hexdump -C].
Basically, here is a simple implementation of [hexdump -C]:
{[
open Lwt
open Lwt_io
let () = Lwt_main.run (write_lines stdout (Lwt_stream.hexdump (read_lines stdin)))
]}
*)

73
server/thirdparty/lwt-2.3.2/src/core/lwt_switch.ml vendored
View File

@ -1,73 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_switch
* Copyright (C) 2010 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
open Lwt
exception Off
type on_switch = {
mutable hooks : (unit -> unit Lwt.t) list;
}
type state =
| St_on of on_switch
| St_off
type t = { mutable state : state }
let create () = { state = St_on { hooks = [] } }
let is_on switch =
match switch.state with
| St_on _ -> true
| St_off -> false
let check = function
| Some{ state = St_off } -> raise Off
| _ -> ()
let add_hook switch hook =
match switch with
| Some{ state = St_on os } ->
os.hooks <- hook :: os.hooks
| Some{ state = St_off } ->
raise Off
| None ->
()
let add_hook_or_exec switch hook =
match switch with
| Some{ state = St_on os } ->
os.hooks <- hook :: os.hooks;
return ()
| Some{ state = St_off } ->
hook ()
| None ->
return ()
let turn_off switch =
match switch.state with
| St_on { hooks = hooks } ->
switch.state <- St_off;
Lwt_list.iter_p (fun hook -> apply hook ()) hooks
| St_off ->
return ()

111
server/thirdparty/lwt-2.3.2/src/core/lwt_switch.mli vendored
View File

@ -1,111 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_switch
* Copyright (C) 2010 Jérémiem Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Lwt switches *)
(** Switch have two goals:
- being able to free multiple resources at the same time,
- offer a better alternative than always returning an id to free
some resource.
For example, considers the following interface:
{[
type id
val free : id -> unit Lwt.t
val f : unit -> id Lwt.t
val g : unit -> id Lwt.t
val h : unit -> id Lwt.t
]}
Now you want to calls [f], [g] and [h] in parallel. You can
simply do:
{[
lwt idf = f () and idg = g () and idh = h () in
...
]}
However, one may wants to handle possible failures of [f ()], [g
()] and [h ()], and disable all allocated resources if one of
these three threads fails. This may be hard since you have to
remember which one failed and which one returned correctly.
Now we change a little bit the interface:
{[
val f : ?switch : Lwt_switch.t -> unit -> id Lwt.t
val g : ?switch : Lwt_switch.t -> unit -> id Lwt.t
val h : ?switch : Lwt_switch.t -> unit -> id Lwt.t
]}
and the code becomes:
{[
let switch = Lwt_switch.create () in
try_lwt
lwt idf = f ~switch () and idg = g ~switch () and idh = h ~switch () in
...
with exn ->
lwt () = Lwt_switch.turn_off switch in
raise_lwt exn
]}
*)
type t
(** Type of switches. *)
val create : unit -> t
(** [create ()] creates a new switch. *)
val is_on : t -> bool
(** [is_on switch] returns [true] if the switch is currently on, and
[false] otherwise. *)
val turn_off : t -> unit Lwt.t
(** [turn_off switch] turns off the switch. It calls all registered
hooks, waits for all of them to terminates, and the returns. If
one of the hook failed, then it will fail with one of the
exception raised by hooks. If the switch is already off, then it
does nothing. *)
exception Off
(** Exception raised when trying to add a hook to a switch that is
already off. *)
val check : t option -> unit
(** [check switch] does nothing if [switch] is [None] or contains an
switch that is currently on, and raise {!Off} otherwise. *)
val add_hook : t option -> (unit -> unit Lwt.t) -> unit
(** [add_hook switch f] registers [f] so it will be called when
{!turn_off} is invoked. It does nothing if [switch] is
[None]. If [switch] contains an switch that is already off then
{!Off} is raised. *)
val add_hook_or_exec : t option -> (unit -> unit Lwt.t) -> unit Lwt.t
(** [add_hook_or_exec switch f] is the same as {!add_hook} except
that if the switch is already off, then [f] is called
immediatly. *)

117
server/thirdparty/lwt-2.3.2/src/core/lwt_util.ml vendored
View File

@ -1,117 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_util
* 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
let rec iter f l =
let l = List.fold_left (fun acc a -> f a :: acc) [] l in
let l = List.rev l in
List.fold_left (fun rt t -> t >>= fun () -> rt) (Lwt.return ()) l
let rec iter_serial f l =
match l with
[] -> return ()
| a :: r -> f a >>= (fun () -> iter_serial f r)
let rec map f l =
match l with
[] ->
return []
| v :: r ->
let t = f v in
let rt = map f r in
t >>= (fun v' ->
rt >>= (fun l' ->
return (v' :: l')))
let map_with_waiting_action f wa l =
let rec loop l =
match l with
[] ->
return []
| v :: r ->
let t = f v in
let rt = loop r in
t >>= (fun v' ->
(* Perform the specified "waiting action" for the next *)
(* item in the list. *)
if r <> [] then
wa (List.hd r)
else
();
rt >>= (fun l' ->
return (v' :: l')))
in
if l <> [] then
wa (List.hd l)
else
();
loop l
let rec map_serial f l =
match l with
[] ->
return []
| v :: r ->
f v >>= (fun v' ->
map_serial f r >>= (fun l' ->
return (v' :: l')))
let rec fold_left f a = function
| [] -> return a
| b::l -> f a b >>= fun v -> fold_left f v l
let join = Lwt.join
type region =
{ mutable size : int;
mutable count : int;
waiters : (unit Lwt.u * int) Queue.t }
let make_region count = { size = count; count = 0; waiters = Queue.create () }
let resize_region reg sz = reg.size <- sz
let leave_region reg sz =
try
if reg.count - sz >= reg.size then raise Queue.Empty;
let (w, sz') = Queue.take reg.waiters in
reg.count <- reg.count - sz + sz';
Lwt.wakeup_later w ()
with Queue.Empty ->
reg.count <- reg.count - sz
let run_in_region_1 reg sz thr =
(catch
(fun () -> thr () >>= (fun v -> leave_region reg sz; return v))
(fun e -> leave_region reg sz; raise_lwt e))
let run_in_region reg sz thr =
if reg.count >= reg.size then begin
let (res, w) = wait () in
Queue.add (w, sz) reg.waiters;
res >>= (fun () -> run_in_region_1 reg sz thr)
end else begin
reg.count <- reg.count + sz;
run_in_region_1 reg sz thr
end

80
server/thirdparty/lwt-2.3.2/src/core/lwt_util.mli vendored
View File

@ -1,80 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_util
* 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.
*)
(** Note: This lodule is deprecated. Use {!Lwt_list} and {!Lwt_pool}
instead. *)
(** {2 Lists iterators} *)
val iter : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
(** [iter f l] start a thread for each element in [l]. The threads
are started according to the list order, but then can run
concurrently. It terminates when all the threads are
terminated, if all threads are successful. It fails if any of
the threads fail. *)
val iter_serial : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
(** Similar to [iter] but wait for one thread to terminate before
starting the next one. *)
val map : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
(** [map f l] apply [f] to each element in [l] and collect the
results of the threads thus created. The threads are started
according to the list order, but then can run concurrently.
[map f l] fails if any of the threads fail. *)
val map_with_waiting_action :
('a -> 'b Lwt.t) -> ('a -> unit) -> 'a list -> 'b list Lwt.t
(** [map_with_waiting_action f wa l] apply [f] to each element
in [l] and collect the results of the threads thus created.
The threads are started according to the list order, but
then can run concurrently. The difference with [map f l] is
that function wa will be called on the element that the
function is waiting for its termination. *)
val map_serial : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
(** Similar to [map] but wait for one thread to terminate before
starting the next one. *)
val fold_left : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t
(** Similar to [List.fold_left]. *)
(****)
(** {2 Regions} *)
type region
val make_region : int -> region
(** [make_region sz] create a region of size [sz]. *)
val resize_region : region -> int -> unit
(** [resize_region reg sz] resize the region [reg] to size [sz]. *)
val run_in_region : region -> int -> (unit -> 'a Lwt.t) -> 'a Lwt.t
(** [run_in_region reg size f] execute the thread produced by the
function [f] in the region [reg]. The thread is not started
before some room is available in the region. *)
(**/**)
val join : unit Lwt.t list -> unit Lwt.t
(** Same as [Lwt.join] *)

4
server/thirdparty/lwt-2.3.2/src/extra/lwt-extra.mllib vendored
View File

@ -1,4 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 73d5d5d814da6fce812bc449a2dcd20c)
Lwt_lib
# OASIS_STOP

134
server/thirdparty/lwt-2.3.2/src/extra/lwt_lib.ml vendored
View File

@ -1,134 +0,0 @@
(* Ocsigen
* http://www.ocsigen.org
* lwt_lib.ml Copyright (C) 2007 Pierre Clairambault
* Laboratoire PPS - CNRS Université Paris Diderot
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later version.
* See COPYING file for details.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Weak
open Unix
open Lwt
let switch_time = 30.
exception Not_in_table
(* We use a specific Not_in_table exception, because since we're caching
* threads, we can't for the moment behave differently whether a request
* is not found in the table or not found as a host.*)
module WeakHashtbl = Make(
struct
type t = string * (Unix.host_entry Lwt.t) * float
let equal = (fun (a,b,c) -> fun (a',b',c') -> a=a')
let hash = fun (a,b,c) -> Hashtbl.hash a
end
)
open WeakHashtbl
let keeper : (((string*(Unix.host_entry Lwt.t)*float) list) *
((string*(Unix.host_entry Lwt.t)*float) list)) ref = ref ([],[])
let cache = create 0
let dummy_addr : Unix.host_entry =
{h_name="dummy";
h_aliases=[||];
h_addrtype=Unix.PF_INET;
h_addr_list = [||]}
let cache_find d = try
match (find cache (d,return dummy_addr,0.)) with (_,h,t) -> (h,t)
with
|Not_found -> raise Not_in_table
|e -> raise e
let gethostbyname d =
Lwt.catch
(fun _ ->
let (h,t) = cache_find d
and t' = Unix.time () in
match (t'>t+.60.) with
| true ->
(remove cache) (d,h,t);
raise_lwt Not_in_table
| false -> h)
(function
| Not_in_table ->
let t = Unix.time() and
h = Lwt_preemptive.detach Unix.gethostbyname d in
let entry = (d,h,t) in
add cache entry;
(match !keeper with (a,b) -> keeper:= (entry::a,b));
h
| e -> raise_lwt e)
(* Begin getaddrinfo caching *)
module WeakAddrInfo = Make(
struct
type t = string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float
let equal = (fun (h,s,o,i,t) -> fun (h',s',o',i',t') -> (h,s,o)=(h',s',o'))
let hash = fun (h,s,o,i,t) -> Hashtbl.hash (h,s,o)
end
)
let keeper6 : (((string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float) list) *
((string*string*(Unix.getaddrinfo_option list)*((Unix.addr_info list) Lwt.t)*float) list)) ref = ref
([],[])
let switch_thread : unit Lwt.t=
let rec switch_worker () =
Lwt_unix.sleep switch_time >>= fun () ->
(match !keeper with (a,b) -> keeper:=([],a));
(match !keeper6 with (a,b) -> keeper6:=([],a));
switch_worker ()
in
switch_worker()
let cache6 = WeakAddrInfo.create 0
let cache_find6 d s o = try
match (WeakAddrInfo.find cache6 (d,s,o,return [],0.)) with (_,_,_,i,t) -> (i,t)
with
|Not_found -> raise Not_in_table
|e -> raise e
let getaddrinfo d s o =
Lwt.catch
(fun _ ->
let (i,t) = cache_find6 d s o
and t' = Unix.time() in
match (t'>t+.60.) with
| true ->
WeakAddrInfo.remove cache6 (d,s,o,i,t);
raise_lwt Not_in_table
| false -> i)
(function
| Not_in_table ->
let t = Unix.time () and
i = Lwt_preemptive.detach (Unix.getaddrinfo d s) o in
let entry = (d,s,o,i,t) in
WeakAddrInfo.add cache6 entry;
(match !keeper6 with (a,b) -> keeper6 := (entry::a,b));
i
| e -> raise_lwt e)
let getnameinfo s l =
(*VVV à implémenter !!! *)
Lwt_preemptive.detach (Unix.getnameinfo s) l

44
server/thirdparty/lwt-2.3.2/src/extra/lwt_lib.mli vendored
View File

@ -1,44 +0,0 @@
(* Ocsigen
* http://www.ocsigen.org
* lwt_lib.mli Copyright (C) 2007 Pierre Clairambault
* Laboratoire PPS - CNRS Université Paris Diderot
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later version.
* See COPYING file for details.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** Cooperative unix system calls *)
(** This module transform non-cooperative functions of the standard
library into cooperative ones by launching them into system
threads.
Indeed, lots of functions of the [Unix] modules, corresponding to
functions of the standard C library may take times to
complete. For example [gethostbyname] may use DNS resolution,
users informations may be stored in a ldap database, ...
Since these functions are implemented (in the standard C library)
using blocking IOs, if you use them directly, you program may
hang. *)
val getaddrinfo : string -> string -> Unix.getaddrinfo_option list -> Unix.addr_info list Lwt.t
(** Cooperative getaddrinfo with cache (using Lwt_preemptive.detach) *)
val gethostbyname : string -> Unix.host_entry Lwt.t
(** Cooperative gethostbyname with cache (using Lwt_preemptive.detach) *)
val getnameinfo : Unix.sockaddr -> Unix.getnameinfo_option list -> Unix.name_info Lwt.t
(** Cooperative getnameinfo with cache (using Lwt_preemptive.detach) *)

4
server/thirdparty/lwt-2.3.2/src/glib/liblwt-glib.clib vendored
View File

@ -1,4 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 905c14a6abfdc3cc49bbc233df66ff99)
lwt_glib_stubs.o
# OASIS_STOP

4
server/thirdparty/lwt-2.3.2/src/glib/lwt-glib.mllib vendored
View File

@ -1,4 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: dfe8b7bfa132aa66ad19dbdbf3bcbaaa)
Lwt_glib
# OASIS_STOP

132
server/thirdparty/lwt-2.3.2/src/glib/lwt_glib.ml vendored
View File

@ -1,132 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module glib
* Copyright (C) 2009-2011 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
type source = {
fd : Unix.file_descr;
check_readable : bool;
check_writable : bool;
}
external glib_init : unit -> unit = "lwt_glib_init"
external glib_stop : unit -> unit = "lwt_glib_stop"
type state =
| State_none
| State_glib_into_lwt of (unit -> unit) Lwt_sequence.node * (unit -> unit) Lwt_sequence.node
| State_lwt_into_glib of Lwt_engine.t
let state = ref State_none
(* +-----------------------------------------------------------------+
| Glib-based engine |
+-----------------------------------------------------------------+ *)
external glib_poll : (Unix.file_descr * bool * bool) list -> int -> int -> (Unix.file_descr * bool * bool) list = "lwt_glib_poll"
class engine = object
inherit Lwt_engine.poll_based
method private poll fds timeout = glib_poll fds (List.length fds) (truncate (timeout *. 1000.))
end
(* +-----------------------------------------------------------------+
| Glib --> Lwt based integration |
+-----------------------------------------------------------------+ *)
external glib_get_sources : unit -> source array * float = "lwt_glib_get_sources"
external glib_check : unit -> unit = "lwt_glib_check"
external glib_mark_readable : int -> unit = "lwt_glib_mark_readable" "noalloc"
external glib_mark_writable : int -> unit = "lwt_glib_mark_readable" "noalloc"
let events = ref []
let check = ref true
let enter () =
if !check then begin
check := false;
let engine = Lwt_engine.get () in
assert (!events = []);
let sources, timeout = glib_get_sources () in
for i = 0 to Array.length sources - 1 do
let src = sources.(i) in
if src.check_readable then
events := engine#on_readable src.fd (fun _ -> glib_mark_readable i) :: !events;
if src.check_writable then
events := engine#on_writable src.fd (fun _ -> glib_mark_writable i) :: !events
done;
if timeout = 0. then
ignore (Lwt_main.yield ())
else if timeout > 0. then
events := engine#on_timer timeout false ignore :: !events
end
let leave () =
if not !check then begin
check := true;
List.iter Lwt_engine.stop_event !events;
events := [];
glib_check ()
end
(* +-----------------------------------------------------------------+
| Installation/removal |
+-----------------------------------------------------------------+ *)
let install ?mode () =
match !state with
| State_lwt_into_glib _ | State_glib_into_lwt _ ->
()
| State_none ->
let mode =
match mode with
| Some mode -> mode
| None -> if Lwt_sys.windows then `lwt_into_glib else `glib_into_lwt
in
glib_init ();
match mode with
| `glib_into_lwt ->
state := State_glib_into_lwt(Lwt_sequence.add_l enter Lwt_main.enter_iter_hooks,
Lwt_sequence.add_l leave Lwt_main.leave_iter_hooks)
| `lwt_into_glib ->
let engine = Lwt_engine.get () in
Lwt_engine.set ~destroy:false (new engine);
state := State_lwt_into_glib engine
let remove () =
match !state with
| State_none ->
()
| State_glib_into_lwt(node_enter, node_leave) ->
state := State_none;
Lwt_sequence.remove node_enter;
Lwt_sequence.remove node_leave;
List.iter Lwt_engine.stop_event !events;
events := [];
glib_stop ()
| State_lwt_into_glib engine ->
Lwt_engine.set engine
(* +-----------------------------------------------------------------+
| Misc |
+-----------------------------------------------------------------+ *)
external iter : bool -> unit = "lwt_glib_iter"
external wakeup : unit -> unit = "lwt_glib_wakeup"

103
server/thirdparty/lwt-2.3.2/src/glib/lwt_glib.mli vendored
View File

@ -1,103 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_glib
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Glib integration *)
(** This module allow to use Lwt in GTK applications.
Here is what you have to do to make Lwt and GTK work together:
- call {!install} at the beginning of your program (before or
after GMain.init, it does not matter)
- do not call GMain.main, write your application as a normal Lwt
application instead.
For example:
{[
let () = Lwt_main.run (
(* Initializes GTK. *)
ignore (GMain.init ());
(* Install Lwt<->Glib integration. *)
Lwt_glib.install ();
(* Thread which is wakeup when the main window is closed. *)
let waiter, wakener = Lwt.wait () in
(* Create a window. *)
let window = GWindow.window () in
(* Display something inside the window. *)
ignore (GMisc.label ~text:"Hello, world!" ~packing:window#add ());
(* Quit when the window is closed. *)
ignore (window#connect#destroy (Lwt.wakeup wakener));
(* Show the window. *)
window#show ();
(* Wait for it to be closed. *)
waiter
)
]}
*)
val install : ?mode : [ `glib_into_lwt | `lwt_into_glib ] -> unit -> unit
(** Install the Glib<->Lwt integration.
If [mode] is [`glib_into_lwt] then glib will use the Lwt main
loop, and if [mode] is [`lwt_into_glib] then Lwt will use the
Glib main loop.
The first mode is better but for some unknown reason it does not
work under Windows, so the second is used as default on Windows
while the first one is used as default on Unix.
If the integration is already active, this function does
nothing. *)
val remove : unit -> unit
(** Remove the Glib<->Lwt integration. *)
val iter : bool -> unit
(** This function is not related to Lwt. [iter may_block] does the
same as [Glib.Main.iteration may_block] but can safely be called
in a multi-threaded program, it will not block the whole
program.
For example:
{[
let main () =
while true do
Lwt_glib.iter true
done
let thread = Thread.create main ()
]}
Note: you can call this function only from one thread at a time,
otherwise it will raise [Failure]. *)
val wakeup : unit -> unit
(** If one thread is blocking on {!iter}, then [wakeup ()] make
{!iter} to return immediatly. *)

275
server/thirdparty/lwt-2.3.2/src/glib/lwt_glib_stubs.c vendored
View File

@ -1,275 +0,0 @@
/* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_glib_stubs
* Copyright (C) 2009-2011 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*/
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/custom.h>
#include <caml/alloc.h>
#include <caml/fail.h>
#include <caml/signals.h>
#include <caml/callback.h>
#include <glib.h>
#include "../unix/lwt_unix.h"
GMainContext *gc;
GPollFD *gpollfds = NULL;
gint fds_count = 0;
gint n_fds;
gint max_priority;
/* +-----------------------------------------------------------------+
| Polling |
+-----------------------------------------------------------------+ */
CAMLprim value lwt_glib_poll(value val_fds, value val_count, value val_timeout)
{
gint timeout, lwt_timeout;
long count;
int i;
GPollFD *gpollfd;
gint events, revents;
CAMLparam3(val_fds, val_count, val_timeout);
CAMLlocal5(node, src, node_result, src_result, tmp);
count = Long_val(val_count);
g_main_context_dispatch(gc);
g_main_context_prepare(gc, &max_priority);
while (fds_count < count + (n_fds = g_main_context_query(gc, max_priority, &timeout, gpollfds, fds_count))) {
free(gpollfds);
fds_count = n_fds + count;
gpollfds = lwt_unix_malloc(fds_count * sizeof (GPollFD));
}
/* Clear all revents fields. */
for (i = 0; i < n_fds + count; i++) gpollfds[i].revents = 0;
/* Add all Lwt fds. */
for (i = n_fds, node = val_fds; i < n_fds + count; i++, node = Field(node, 1)) {
src = Field(node, 0);
gpollfd = gpollfds + i;
#if defined(LWT_ON_WINDOWS)
gpollfd->fd = Handle_val(Field(src, 0));
#else
gpollfd->fd = Int_val(Field(src, 0));
#endif
events = 0;
if (Bool_val(Field(src, 1))) events |= G_IO_IN;
if (Bool_val(Field(src, 2))) events |= G_IO_OUT;
gpollfd->events = events;
}
lwt_timeout = Int_val(val_timeout);
if (timeout < 0 || (lwt_timeout >= 0 && lwt_timeout < timeout))
timeout = lwt_timeout;
/* Do the blocking call. */
g_main_context_get_poll_func(gc)(gpollfds, n_fds + count, timeout);
g_main_context_check(gc, max_priority, gpollfds, n_fds);
/* Build the result. */
node_result = Val_int(0);
for (i = n_fds, node = val_fds; i < n_fds + count; i++, node = Field(node, 1)) {
src_result = caml_alloc_tuple(3);
src = Field(node, 0);
Field(src_result, 0) = Field(src, 0);
revents = gpollfds[i].revents;
Field(src_result, 1) = Val_bool(revents & G_IO_IN);
Field(src_result, 2) = Val_bool(revents & G_IO_OUT);
tmp = caml_alloc_tuple(2);
Field(tmp, 0) = src_result;
Field(tmp, 1) = node_result;
node_result = tmp;
}
CAMLreturn(node_result);
}
/* +-----------------------------------------------------------------+
| Get sources |
+-----------------------------------------------------------------+ */
#if defined(LWT_ON_WINDOWS)
static value alloc_fd(HANDLE handle)
{
value res = win_alloc_handle(handle);
int opt;
int optlen = sizeof(opt);
if (getsockopt((SOCKET)handle, SOL_SOCKET, SO_TYPE, (char *)&opt, &optlen) == 0)
Descr_kind_val(res) = KIND_SOCKET;
return res;
}
#endif
CAMLprim value lwt_glib_get_sources()
{
gint timeout;
int i;
GPollFD *gpollfd;
CAMLparam0();
CAMLlocal4(fd, fds, src, result);
g_main_context_dispatch(gc);
g_main_context_prepare(gc, &max_priority);
while (fds_count < (n_fds = g_main_context_query(gc, max_priority, &timeout, gpollfds, fds_count))) {
free(gpollfds);
fds_count = n_fds;
gpollfds = lwt_unix_malloc(fds_count * sizeof (GPollFD));
}
fds = caml_alloc_tuple(n_fds);
for (i = 0; i < n_fds; i++) {
gpollfd = gpollfds + i;
gpollfd->revents = 0;
#if defined(LWT_ON_WINDOWS)
/* On windows, glib file descriptors are handles */
fd = alloc_fd((HANDLE)gpollfd->fd);
#else
fd = Val_int(gpollfd->fd);
#endif
src = caml_alloc_tuple(3);
Field(src, 0) = fd;
Field(src, 1) = Val_bool(gpollfd->events & G_IO_IN);
Field(src, 2) = Val_bool(gpollfd->events & G_IO_OUT);
Field(fds, i) = src;
}
result = caml_alloc_tuple(2);
Store_field(result, 0, fds);
Store_field(result, 1, caml_copy_double(timeout * 1e-3));
CAMLreturn(result);
}
/* +-----------------------------------------------------------------+
| Marking |
+-----------------------------------------------------------------+ */
CAMLprim value lwt_glib_mark_readable(value i)
{
gpollfds[Int_val(i)].revents |= G_IO_IN;
return Val_unit;
}
CAMLprim value lwt_glib_mark_writable(value i)
{
gpollfds[Int_val(i)].revents |= G_IO_OUT;
return Val_unit;
}
/* +-----------------------------------------------------------------+
| Check |
+-----------------------------------------------------------------+ */
CAMLprim value lwt_glib_check()
{
g_main_context_check(gc, max_priority, gpollfds, n_fds);
return Val_unit;
}
/* +-----------------------------------------------------------------+
| Initialization/stopping |
+-----------------------------------------------------------------+ */
CAMLprim value lwt_glib_init()
{
gc = g_main_context_default();
g_main_context_ref(gc);
return Val_unit;
}
CAMLprim value lwt_glib_stop()
{
g_main_context_unref(gc);
return Val_unit;
}
/* +-----------------------------------------------------------------+
| Misc |
+-----------------------------------------------------------------+ */
CAMLprim value lwt_glib_iter(value may_block)
{
GMainContext *gc;
gint max_priority, timeout;
GPollFD *pollfds = NULL;
gint pollfds_size = 0;
gint nfds;
gint i;
/* Get the main context. */
gc = g_main_context_default();
/* Try to acquire it. */
if (!g_main_context_acquire(gc))
caml_failwith("Lwt_glib.iter");
/* Dispatch pending events. */
g_main_context_dispatch(gc);
/* Prepare the context for polling. */
g_main_context_prepare(gc, &max_priority);
/* Get all file descriptors to poll. */
while (pollfds_size < (nfds = g_main_context_query(gc, max_priority, &timeout, pollfds, pollfds_size))) {
free(pollfds);
pollfds_size = nfds;
pollfds = lwt_unix_malloc(pollfds_size * sizeof (GPollFD));
}
/* Clear all revents fields. */
for (i = 0; i < nfds; i++) pollfds[i].revents = 0;
/* Set the timeout to 0 if we do not want to block. */
if (!Bool_val(may_block)) timeout = 0;
/* Do the blocking call. */
caml_enter_blocking_section();
g_main_context_get_poll_func(gc)(pollfds, nfds, timeout);
caml_leave_blocking_section();
/* Let glib parse the result. */
g_main_context_check(gc, max_priority, pollfds, nfds);
/* Release the context. */
g_main_context_release(gc);
free(pollfds);
return Val_unit;
}
CAMLprim value lwt_glib_wakeup()
{
g_main_context_wakeup(g_main_context_default());
return Val_unit;
}

4
server/thirdparty/lwt-2.3.2/src/preemptive/lwt-preemptive.mllib vendored
View File

@ -1,4 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 7a98b43f4d640061bceed7638c0c7efd)
Lwt_preemptive
# OASIS_STOP

195
server/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.ml vendored
View File

@ -1,195 +0,0 @@
(* 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.
*)
let section = Lwt_log.Section.make "lwt(preemptive)"
open Lwt
open Lwt_io
(* +-----------------------------------------------------------------+
| Parameters |
+-----------------------------------------------------------------+ *)
(* Minimum number of preemptive threads: *)
let min_threads : int ref = ref 0
(* Maximum number of preemptive threads: *)
let max_threads : int ref = ref 0
(* Size of the waiting queue: *)
let max_thread_queued = ref 1000
let get_max_number_of_threads_queued _ =
!max_thread_queued
let set_max_number_of_threads_queued n =
if n < 0 then invalid_arg "Lwt_preemptive.set_max_number_of_threads_queued";
max_thread_queued := n
(* The function for logging errors: *)
let error_log = ref (fun msg -> ignore (Lwt_log.error ~section msg))
(* The total number of preemptive threads currently running: *)
let threads_count = ref 0
(* +-----------------------------------------------------------------+
| Preemptive threads management |
+-----------------------------------------------------------------+ *)
type thread = {
task_channel: (int * (unit -> unit)) Event.channel;
(* Channel used to communicate notification id and tasks to the
worker thread. *)
mutable thread : Thread.t;
(* The worker thread. *)
mutable reuse : bool;
(* Whether the thread must be readded to the pool when the work is
done. *)
}
(* Pool of worker threads: *)
let workers : thread Queue.t = Queue.create ()
(* Queue of clients waiting for a worker to be available: *)
let waiters : thread Lwt.u Lwt_sequence.t = Lwt_sequence.create ()
(* Code executed by a worker: *)
let rec worker_loop worker =
let id, task = Event.sync (Event.receive worker.task_channel) in
task ();
(* If there is too much threads, exit. This can happen if the user
decreased the maximum: *)
if !threads_count > !max_threads then worker.reuse <- false;
(* Tell the main thread that work is done: *)
Lwt_unix.send_notification id;
if worker.reuse then worker_loop worker
(* create a new worker: *)
let make_worker _ =
incr threads_count;
let worker = {
task_channel = Event.new_channel ();
thread = Thread.self ();
reuse = true;
} in
worker.thread <- Thread.create worker_loop worker;
worker
(* Add a worker to the pool: *)
let add_worker worker =
match Lwt_sequence.take_opt_l waiters with
| None ->
Queue.add worker workers
| Some w ->
wakeup w worker
(* Wait for worker to be available, then return it: *)
let rec get_worker _ =
if not (Queue.is_empty workers) then
return (Queue.take workers)
else if !threads_count < !max_threads then
return (make_worker ())
else begin
let (res, w) = Lwt.task () in
let node = Lwt_sequence.add_r w waiters in
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
res
end
(* +-----------------------------------------------------------------+
| Initialisation, and dynamic parameters reset |
+-----------------------------------------------------------------+ *)
let get_bounds _ = (!min_threads, !max_threads)
let set_bounds (min, max) =
if min < 0 || max < min then invalid_arg "Lwt_preemptive.set_bounds";
let diff = min - !threads_count in
min_threads := min;
max_threads := max;
(* Launch new workers: *)
for i = 1 to diff do
add_worker (make_worker ())
done
let initialized = ref false
let init min max errlog =
initialized := true;
error_log := errlog;
set_bounds (min, max)
let simple_init _ =
if not !initialized then begin
initialized := true;
set_bounds (0, 4)
end
let nbthreads _ = !threads_count
let nbthreadsqueued _ = Lwt_sequence.fold_l (fun _ x -> x + 1) waiters 0
let nbthreadsbusy _ = !threads_count - Queue.length workers
(* +-----------------------------------------------------------------+
| Detaching |
+-----------------------------------------------------------------+ *)
let detach f args =
simple_init ();
let result = ref `Nothing in
(* The task for the worker thread: *)
let task () =
try
result := `Success(f args)
with exn ->
result := `Failure exn
in
lwt worker = get_worker () in
let waiter, wakener = wait () in
let id =
Lwt_unix.make_notification ~once:true
(fun () ->
match !result with
| `Nothing ->
wakeup_exn wakener (Failure "Lwt_preemptive.detach")
| `Success value ->
wakeup wakener value
| `Failure exn ->
wakeup_exn wakener exn)
in
try_lwt
(* Send the id and the task to the worker: *)
Event.sync (Event.send worker.task_channel (id, task));
waiter
finally
if worker.reuse then
(* Put back the worker to the pool: *)
add_worker worker
else begin
decr threads_count;
(* Or wait for the thread to terminates, to free its associated
resources: *)
Thread.join worker.thread
end;
return ()

70
server/thirdparty/lwt-2.3.2/src/preemptive/lwt_preemptive.mli vendored
View File

@ -1,70 +0,0 @@
(* 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 with you can detach computations. *)
val detach : ('a -> 'b) -> 'a -> 'b Lwt.t
(** detaches a computation to a preemptive thread. *)
val init : int -> int -> (string -> unit) -> unit
(** [init min max log] initialises this module. i.e. it launches the
minimum number of preemptive threads and starts the {b
dispatcher}.
@param min is the minimum number of threads
@param max is the maximum number of threads
@param log is used to log error messages
If {!Lwt_preemptive} has already been initialised, this call
only modify bounds and the log function, and return the
dispatcher thread. *)
val simple_init : unit -> unit
(** [simple_init ()] does a {i simple initialization}. i.e. with
default parameters if the library is not yet initialised.
Note: this function is automatically called {!detach}. *)
val get_bounds : unit -> int * int
(** [get_bounds ()] returns the minimum and the maximum number of
preemptive threads. *)
val set_bounds : int * int -> unit
(** [set_bounds (min, max)] set the minimum and the maximum number
of preemptive threads. *)
val set_max_number_of_threads_queued : int -> unit
(** Sets the size of the waiting queue, if no more preemptive
threads are available. When the queue is full, {!detach} will
sleep until a thread is available. *)
val get_max_number_of_threads_queued : unit -> int
(** Returns the size of the waiting queue, if no more threads are
available *)
(**/**)
val nbthreads : unit -> int
val nbthreadsbusy : unit -> int
val nbthreadsqueued : unit -> int

6
server/thirdparty/lwt-2.3.2/src/react/lwt-react.mllib vendored
View File

@ -1,6 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 8916665f5b5252b5a633514708d91e4b)
Lwt_event
Lwt_signal
Lwt_react
# OASIS_STOP

54
server/thirdparty/lwt-2.3.2/src/react/lwt_event.ml vendored
View File

@ -1,54 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_event
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
include Lwt_react.E
(* +-----------------------------------------------------------------+
| Notifiers |
+-----------------------------------------------------------------+ *)
type notifier = unit React.event Lwt_sequence.node
let notifiers = Lwt_sequence.create ()
let disable n =
Lwt_sequence.remove n;
React.E.stop (Lwt_sequence.get n)
let notify f event =
Lwt_sequence.add_l (React.E.map f event) notifiers
let notify_p f event =
Lwt_sequence.add_l (React.E.map (fun x -> Lwt.ignore_result (f x)) event) notifiers
let notify_s f event =
let mutex = Lwt_mutex.create () in
Lwt_sequence.add_l (React.E.map (fun x -> Lwt.ignore_result (Lwt_mutex.with_lock mutex (fun () -> f x))) event) notifiers
let always_notify f event =
ignore (notify f event)
let always_notify_p f event =
ignore (notify_p f event)
let always_notify_s f event =
ignore (notify_s f event)

58
server/thirdparty/lwt-2.3.2/src/react/lwt_event.mli vendored
View File

@ -1,58 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_event
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Events utilities *)
(** This module is deprecated, you should use {!Lwt_react.E}
instead. *)
open React
val with_finaliser : (unit -> unit) -> 'a event -> 'a event
val next : 'a event -> 'a Lwt.t
val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event
val from : (unit -> 'a Lwt.t) -> 'a event
val to_stream : 'a event -> 'a Lwt_stream.t
val of_stream : 'a Lwt_stream.t -> 'a event
val delay : 'a event Lwt.t -> 'a event
val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event
val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event
val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event
val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event
val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event
val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event
val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event
val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event
val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event
val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event
val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event
val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event
val run_s : 'a Lwt.t event -> 'a event
val run_p : 'a Lwt.t event -> 'a event
type notifier
val disable : notifier -> unit
val notify : ('a -> unit) -> 'a event -> notifier
val notify_p : ('a -> unit Lwt.t) -> 'a event -> notifier
val notify_s : ('a -> unit Lwt.t) -> 'a event -> notifier
val always_notify : ('a -> unit) -> 'a event -> unit
val always_notify_p : ('a -> unit Lwt.t) -> 'a event -> unit
val always_notify_s : ('a -> unit Lwt.t) -> 'a event -> unit

461
server/thirdparty/lwt-2.3.2/src/react/lwt_react.ml vendored
View File

@ -1,461 +0,0 @@
(*
* lwt_react.ml
* ------------
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
* Licence : BSD3
*
* This file is a part of lwt.
*)
open Lwt
type 'a event = 'a React.event
type 'a signal = 'a React.signal
module E = struct
include React.E
(* +---------------------------------------------------------------+
| Lwt-specific utilities |
+---------------------------------------------------------------+ *)
let finalise f _ = f ()
let with_finaliser f event =
let r = ref () in
Gc.finalise (finalise f) r;
map (fun x -> ignore r; x) event
let next ev =
let waiter, wakener = Lwt.task () in
let ev = map (fun x -> Lwt.wakeup wakener x) (once ev) in
Lwt.on_cancel waiter (fun () -> stop ev);
waiter
let limit f e =
(* Thread which prevent [e] to occur while it is sleeping *)
let limiter = ref (return ()) in
(* The occurence that is delayed until the limiter returns. *)
let delayed = ref None in
(* The resulting event. *)
let event, push = create () in
let iter =
fmap
(fun x ->
if state !limiter = Sleep then begin
(* The limiter is sleeping, we queue the event for later
delivering. *)
match !delayed with
| Some cell ->
(* An occurence is alreayd queued, replace it. *)
cell := x;
None
| None ->
let cell = ref x in
delayed := Some cell;
on_success !limiter (fun () -> push !cell);
None
end else begin
(* Set the limiter for future events. *)
limiter := f ();
(* Send the occurence now. *)
push x;
None
end)
e
in
select [iter; event]
let stop_from wakener () =
wakeup wakener None
let from f =
let event, push = create () in
let abort_waiter, abort_wakener = Lwt.wait () in
let rec loop () =
pick [f () >|= (fun x -> Some x); abort_waiter] >>= function
| Some v ->
push v;
loop ()
| None ->
stop event;
return ()
in
ignore_result (pause () >>= loop);
with_finaliser (stop_from abort_wakener) event
module EQueue :
sig
type 'a t
val create : 'a React.event -> 'a t
val pop : 'a t -> 'a option Lwt.t
end =
struct
type 'a state =
| No_mail
| Waiting of 'a option Lwt.u
| Full of 'a Queue.t
type 'a t = {
mutable state : 'a state;
mutable event : unit React.event;
(* field used to prevent garbage collection *)
}
let create event =
let box = { state = No_mail; event = never } in
let push v =
match box.state with
| No_mail ->
let q = Queue.create () in
Queue.push v q;
box.state <- Full q
| Waiting wakener ->
box.state <- No_mail;
wakeup_later wakener (Some v)
| Full q ->
Queue.push v q
in
box.event <- map push event;
box
let pop b = match b.state with
| No_mail ->
let waiter, wakener = task () in
Lwt.on_cancel waiter (fun () -> b.state <- No_mail);
b.state <- Waiting wakener;
waiter
| Waiting _ ->
(* Calls to next are serialized, so this case will never
happened *)
assert false
| Full q ->
let v = Queue.take q in
if Queue.is_empty q then b.state <- No_mail;
return (Some v)
end
let to_stream event =
let box = EQueue.create event in
Lwt_stream.from (fun () -> EQueue.pop box)
let stop_stream wakener () =
wakeup wakener None
let of_stream stream =
let event, push = create () in
let abort_waiter, abort_wakener = Lwt.wait () in
let rec loop () =
pick [Lwt_stream.get stream; abort_waiter] >>= function
| Some value ->
push value;
loop ()
| None ->
stop event;
return ()
in
ignore_result (pause () >>= loop);
with_finaliser (stop_stream abort_wakener) event
let delay thread =
match poll thread with
| Some e ->
e
| None ->
let event, send = create () in
on_success thread (fun e -> send e; stop event);
switch never event
let keeped = ref []
let keep e =
keeped := map ignore e :: !keeped
(* +---------------------------------------------------------------+
| Event transofrmations |
+---------------------------------------------------------------+ *)
let run_p e =
let event, push = create () in
let iter = fmap (fun t -> on_success t push; None) e in
select [iter; event]
let run_s e =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) e in
select [iter; event]
let map_p f e =
let event, push = create () in
let iter = fmap (fun x -> on_success (f x) push; None) e in
select [iter; event]
let map_s f e =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) e in
select [iter; event]
let app_p ef e =
let event, push = create () in
let iter = fmap (fun (f, x) -> on_success (f x) push; None) (app (map (fun f x -> (f, x)) ef) e) in
select [iter; event]
let app_s ef e =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (app (map (fun f x -> (f, x)) ef) e) in
select [iter; event]
let filter_p f e =
let event, push = create () in
let iter = fmap (fun x -> on_success (f x) (function true -> push x | false -> ()); None) e in
select [iter; event]
let filter_s f e =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) e in
select [iter; event]
let fmap_p f e =
let event, push = create () in
let iter = fmap (fun x -> on_success (f x) (function Some x -> push x | None -> ()); None) e in
select [iter; event]
let fmap_s f e =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) e in
select [iter; event]
let diff_s f e =
let previous = ref None in
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter =
fmap
(fun x ->
match !previous with
| None ->
previous := Some x;
None
| Some y ->
previous := Some x;
on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push;
None)
e
in
select [iter; event]
let accum_s ef acc =
let acc = ref acc in
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun f -> on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc)) (fun x -> acc := x; push x); None) ef in
select [iter; event]
let fold_s f acc e =
let acc = ref acc in
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc x)) (fun x -> acc := x; push x); None) e in
select [iter; event]
let rec rev_fold f acc = function
| [] ->
return acc
| x :: l ->
lwt acc = rev_fold f acc l in
f acc x
let merge_s f acc el =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (merge (fun acc x -> x :: acc) [] el) in
select [iter; event]
end
module S = struct
include React.S
(* +---------------------------------------------------------------+
| Lwt-specific utilities |
+---------------------------------------------------------------+ *)
let finalise f _ = f ()
let with_finaliser f signal =
let r = ref () in
Gc.finalise (finalise f) r;
map (fun x -> ignore r; x) signal
let limit ?eq f s =
(* Thread which prevent [s] to changes while it is sleeping *)
let limiter = ref (f ()) in
(* The occurence that is delayed until the limiter returns. *)
let delayed = ref None in
(* The resulting event. *)
let event, push = E.create () in
let iter =
E.fmap
(fun x ->
if state !limiter = Sleep then begin
(* The limiter is sleeping, we queue the event for later
delivering. *)
match !delayed with
| Some cell ->
(* An occurence is alreayd queued, replace it. *)
cell := x;
None
| None ->
let cell = ref x in
delayed := Some cell;
on_success !limiter (fun () -> push !cell);
None
end else begin
(* Set the limiter for future events. *)
limiter := f ();
(* Send the occurence now. *)
push x;
None
end)
(changes s)
in
hold ?eq (value s) (E.select [iter; event])
let keeped = ref []
let keep s =
keeped := map ignore s :: !keeped
(* +---------------------------------------------------------------+
| Signal transofrmations |
+---------------------------------------------------------------+ *)
let run_s ?eq s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in
lwt x = Lwt_mutex.with_lock mutex (fun () -> value s) in
return (hold ?eq x (E.select [iter; event]))
let map_s ?eq f s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in
lwt x = Lwt_mutex.with_lock mutex (fun () -> f (value s)) in
return (hold ?eq x (E.select [iter; event]))
let app_s ?eq sf s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in
lwt x = Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s)) in
return (hold ?eq x (E.select [iter; event]))
let filter_s ?eq f i s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in
let x = value s in
Lwt_mutex.with_lock mutex (fun () -> f x) >>= function
| true ->
return (hold ?eq x (E.select [iter; event]))
| false ->
return (hold ?eq i (E.select [iter; event]))
let fmap_s ?eq f i s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in
Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= function
| Some x ->
return (hold ?eq x (E.select [iter; event]))
| None ->
return (hold ?eq i (E.select [iter; event]))
let diff_s f s =
let previous = ref (value s) in
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter =
E.fmap
(fun x ->
let y = !previous in
previous := x;
on_success (Lwt_mutex.with_lock mutex (fun () -> f x y)) push;
None)
(changes s)
in
E.select [iter; event]
let sample_s f e s =
E.map_s (fun x -> f x (value s)) e
let accum_s ?eq ef i =
hold ?eq i (E.accum_s ef i)
let fold_s ?eq f i e =
hold ?eq i (E.fold_s f i e)
let rec rev_fold f acc = function
| [] ->
return acc
| x :: l ->
lwt acc = rev_fold f acc l in
f acc x
let merge_s ?eq f acc sl =
let s = merge (fun acc x -> x :: acc) [] sl in
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in
lwt x = Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s)) in
return (hold ?eq x (E.select [iter; event]))
let l1_s ?eq f s1 =
map_s ?eq f s1
let l2_s ?eq f s1 s2 =
map_s ?eq (fun (x1, x2) -> f x1 x2) (l2 (fun x1 x2 -> (x1, x2)) s1 s2)
let l3_s ?eq f s1 s2 s3 =
map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) (l3 (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3)
let l4_s ?eq f s1 s2 s3 s4 =
map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) (l4 (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4)
let l5_s ?eq f s1 s2 s3 s4 s5 =
map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) (l5 (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5)
let l6_s ?eq f s1 s2 s3 s4 s5 s6 =
map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) (l6 (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6)
(* +---------------------------------------------------------------+
| Monadic interface |
+---------------------------------------------------------------+ *)
let return =
const
let bind ?eq s f =
switch ?eq (f (value s)) (E.map f (changes s))
let bind_s ?eq s f =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in
lwt x = Lwt_mutex.with_lock mutex (fun () -> f (value s)) in
Lwt.return (switch ?eq x (E.select [iter; event]))
end

166
server/thirdparty/lwt-2.3.2/src/react/lwt_react.mli vendored
View File

@ -1,166 +0,0 @@
(*
* lwt_react.mli
* -------------
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
* Licence : BSD3
*
* This file is a part of lwt.
*)
(** React utilities *)
(** This module is a replacement for the React module. You can open it
instead of the React module in order to get all react's functions
plus Lwt ones. *)
type 'a event = 'a React.event
(** Type of events. *)
type 'a signal = 'a React.signal
(** Type of signals. *)
module E : sig
include module type of React.E
(** {6 Lwt-specific utilities} *)
val with_finaliser : (unit -> unit) -> 'a event -> 'a event
(** [with_finaliser f e] returns an event [e'] which behave as
[e], except that [f] is called when [e'] is garbage
collected. *)
val next : 'a event -> 'a Lwt.t
(** [next e] returns the next occurrence of [e] *)
val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event
(** [limit f e] limits the rate of [e] with [f].
For example, to limit the rate of an event to 1 per second you
can use: [limit (fun () -> Lwt_unix.sleep 1.0) event]. *)
val from : (unit -> 'a Lwt.t) -> 'a event
(** [from f] creates an event which occurs each [f ()] returns a
value. If [f] raises an exception, the event is just
stopped. *)
val to_stream : 'a event -> 'a Lwt_stream.t
(** Creates a stream holding all values occurring on the given
event *)
val of_stream : 'a Lwt_stream.t -> 'a event
(** [of_stream stream] creates an event which occurs each time a
value is available on the stream. *)
val delay : 'a event Lwt.t -> 'a event
(** [delay thread] is an event which does not occurs until
[thread] returns. Then it behaves as the event returned by
[thread]. *)
val keep : 'a event -> unit
(** [keep e] keeps a reference to [e] so it will never be garbage
collected. *)
(** {6 Threaded versions of React transformation functions} *)
(** The following functions behave as their [React] counterpart,
except that they takes functions that may yield.
As usual the [_s] suffix is used when calls are serialized, and
the [_p] suffix is used when they are not.
Note that [*_p] functions may not preserve event order. *)
val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event
val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event
val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event
val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event
val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event
val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event
val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event
val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event
val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event
val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event
val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event
val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event
val run_s : 'a Lwt.t event -> 'a event
val run_p : 'a Lwt.t event -> 'a event
end
module S : sig
include module type of React.S
(** {6 Monadic interface} *)
val return : 'a -> 'a signal
(** Same as [const]. *)
val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal
(** [bind ?eq s f] is initially [f x] where [x] is the current
value of [s]. Each time [s] changes to a new value [y], [bind
signal f] is set to [f y], until the next change of
[signal]. *)
val bind_s : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal Lwt.t) -> 'b signal Lwt.t
(** Same as {!bind} except that [f] returns a thread. Calls to [f]
are serialized. *)
(** {6 Lwt-specific utilities} *)
val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal
(** [with_finaliser f s] returns a signal [s'] which behave as
[s], except that [f] is called when [s'] is garbage
collected. *)
val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal
(** [limit f s] limits the rate of [s] update with [f].
For example, to limit it to 1 per second, you can use: [limit
(fun () -> Lwt_unix.sleep 1.0) s]. *)
val keep : 'a signal -> unit
(** [keep s] keeps a reference to [s] so it will never be garbage
collected. *)
(** {6 Threaded versions of React transformation functions} *)
(** The following functions behave as their [React] counterpart,
except that they takes functions that may yield.
The [_s] suffix means that calls are serialized.
*)
val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'a signal -> 'b signal Lwt.t
val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t
val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal Lwt.t
val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal Lwt.t
val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event
val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event
val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal
val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal
val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal Lwt.t
val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t
val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'a signal -> 'b signal -> 'c signal Lwt.t
val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal Lwt.t
val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal Lwt.t
val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal Lwt.t
val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal Lwt.t
val run_s : ?eq : ('a -> 'a -> bool) -> 'a Lwt.t signal -> 'a signal Lwt.t
end

175
server/thirdparty/lwt-2.3.2/src/react/lwt_signal.ml vendored
View File

@ -1,175 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_signal
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
include Lwt_react.S
open Lwt_react
open Lwt
(* +-----------------------------------------------------------------+
| Notifiers |
+-----------------------------------------------------------------+ *)
type notifier = unit React.signal Lwt_sequence.node
let notifiers = Lwt_sequence.create ()
let disable n =
Lwt_sequence.remove n;
stop (Lwt_sequence.get n)
let notify f signal =
Lwt_sequence.add_l (S.map f signal) notifiers
let notify_p f signal =
Lwt_sequence.add_l (S.map (fun x -> Lwt.ignore_result (f x)) signal) notifiers
let notify_s f signal =
let mutex = Lwt_mutex.create () in
Lwt_sequence.add_l (S.map (fun x -> Lwt.ignore_result (Lwt_mutex.with_lock mutex (fun () -> f x))) signal) notifiers
let always_notify f signal =
ignore (notify f signal)
let always_notify_p f signal =
ignore (notify_p f signal)
let always_notify_s f signal =
ignore (notify_s f signal)
(* +-----------------------------------------------------------------+
| Lwt-specific utilities |
+-----------------------------------------------------------------+ *)
let delay thread =
match poll thread with
| Some signal ->
let event1, send1 = React.E.create () in
let event2, send2 = React.E.create () in
ignore (
(* If the thread has already terminated, we make a pause to
prevent the first occurence to be lost *)
lwt () = pause () in
send1 (value signal);
send2 (changes signal);
React.E.stop event1;
React.E.stop event2;
return ()
);
React.E.switch event1 event2
| None ->
let event1, send1 = React.E.create () in
let event2, send2 = React.E.create () in
ignore (
lwt signal = thread in
send1 (value signal);
send2 (changes signal);
React.E.stop event1;
React.E.stop event2;
return ()
);
React.E.switch event1 event2
(* +-----------------------------------------------------------------+
| Signal transofrmations |
+-----------------------------------------------------------------+ *)
let run_s ?eq i s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun t -> on_success (Lwt_mutex.with_lock mutex (fun () -> t)) push; None) (changes s) in
on_success (Lwt_mutex.with_lock mutex (fun () -> value s)) push;
hold ?eq i (E.select [iter; event])
let map_s ?eq f i s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (changes s) in
on_success (Lwt_mutex.with_lock mutex (fun () -> f (value s))) push;
hold ?eq i (E.select [iter; event])
let app_s ?eq sf i s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun (f, x) -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) push; None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in
on_success (Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s))) push;
hold ?eq i (E.select [iter; event])
let filter_s ?eq f i s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in
let x = value s in
on_success
(Lwt_mutex.with_lock mutex (fun () -> f x))
(function
| true ->
push x
| false ->
());
hold ?eq i (E.select [iter; event])
let fmap_s ?eq f i s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun x -> on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in
on_success
(Lwt_mutex.with_lock mutex (fun () -> f (value s)))
(function
| Some x ->
push x
| None ->
());
hold ?eq i (E.select [iter; event])
let rec rev_fold f acc = function
| [] ->
return acc
| x :: l ->
lwt acc = rev_fold f acc l in
f acc x
let merge_s ?eq f acc sl =
let s = merge (fun acc x -> x :: acc) [] sl in
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun l -> on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) push; None) (changes s) in
on_success (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s))) push;
hold ?eq acc (E.select [iter; event])
let l1_s ?eq f i s1 =
map_s ?eq f i s1
let l2_s ?eq f i s1 s2 =
map_s ?eq (fun (x1, x2) -> f x1 x2) i (l2 (fun x1 x2 -> (x1, x2)) s1 s2)
let l3_s ?eq f i s1 s2 s3 =
map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) i (l3 (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3)
let l4_s ?eq f i s1 s2 s3 s4 =
map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) i (l4 (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4)
let l5_s ?eq f i s1 s2 s3 s4 s5 =
map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) i (l5 (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5)
let l6_s ?eq f i s1 s2 s3 s4 s5 s6 =
map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) i (l6 (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6)

57
server/thirdparty/lwt-2.3.2/src/react/lwt_signal.mli vendored
View File

@ -1,57 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_event
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Signals utilities *)
(** This module is deprecated, you should use {!Lwt_react.S}
instead. *)
open React
val return : 'a -> 'a signal
val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal
val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal
val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal
val delay : 'a signal Lwt.t -> 'a event
val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'b -> 'a signal -> 'b signal
val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'b -> 'a signal -> 'b signal
val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal
val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal
val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event
val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event
val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal
val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal
val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal
val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'b -> ('a signal -> 'b signal)
val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'c -> ('a signal -> 'b signal -> 'c signal)
val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'd -> ('a signal -> 'b signal -> 'c signal -> 'd signal)
val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'e -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal)
val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'f -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal)
val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'g -> ('a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal)
val run_s : ?eq : ('a -> 'a -> bool) -> 'a -> 'a Lwt.t signal -> 'a signal
type notifier
val disable : notifier -> unit
val notify : ('a -> unit) -> 'a signal -> notifier
val notify_p : ('a -> unit Lwt.t) -> 'a signal -> notifier
val notify_s : ('a -> unit Lwt.t) -> 'a signal -> notifier
val always_notify : ('a -> unit) -> 'a signal -> unit
val always_notify_p : ('a -> unit Lwt.t) -> 'a signal -> unit
val always_notify_s : ('a -> unit Lwt.t) -> 'a signal -> unit

4
server/thirdparty/lwt-2.3.2/src/simple_top/lwt-simple-top.mllib vendored
View File

@ -1,4 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: de6ce24e129acca71e8908d2344cd786)
Lwt_simple_top
# OASIS_STOP

47
server/thirdparty/lwt-2.3.2/src/simple_top/lwt_simple_top.ml vendored
View File

@ -1,47 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_simple_top
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(* Integration with the toplevel for people who do not have the
enhanced toplevel (package lwt.top, which require ocaml-text). *)
open Lwt
open Lwt_io
let read_input_non_interactive prompt buffer len =
let rec loop i =
if i = len then
return (i, false)
else
read_char_opt stdin >>= function
| Some c ->
buffer.[i] <- c;
if c = '\n' then
return (i + 1, false)
else
loop (i + 1)
| None ->
return (i, true)
in
Lwt_main.run (write stdout prompt >> loop 0)
let _ =
Toploop.read_interactive_input := read_input_non_interactive

4
server/thirdparty/lwt-2.3.2/src/ssl/lwt-ssl.mllib vendored
View File

@ -1,4 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: ab07ef30d9c1dd9dd2a1f2eef22e9d68)
Lwt_ssl
# OASIS_STOP

175
server/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.ml vendored
View File

@ -1,175 +0,0 @@
(* Lightweight thread library for Objective Caml
* 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.
*)
type t =
Plain
| SSL of Ssl.socket
type socket = Lwt_unix.file_descr * t
let is_ssl s =
match snd s with
Plain -> false
| _ -> true
let wrap_call f () =
try
f ()
with
(Ssl.Connection_error err | Ssl.Accept_error err |
Ssl.Read_error err | Ssl.Write_error err) as e ->
match err with
Ssl.Error_want_read ->
raise Lwt_unix.Retry_read
| Ssl.Error_want_write ->
raise Lwt_unix.Retry_write
| _ ->
raise e
let repeat_call fd f =
try
Lwt_unix.check_descriptor fd;
Lwt.return (wrap_call f ())
with
Lwt_unix.Retry_read ->
Lwt_unix.register_action Lwt_unix.Read fd (wrap_call f)
| Lwt_unix.Retry_write ->
Lwt_unix.register_action Lwt_unix.Write fd (wrap_call f)
| e ->
raise_lwt e
(****)
let plain fd = (fd, Plain)
let embed_socket fd context = (fd, SSL(Ssl.embed_socket (Lwt_unix.unix_file_descr fd) context))
let ssl_accept fd ctx =
let socket = Ssl.embed_socket (Lwt_unix.unix_file_descr fd) ctx in
Lwt.bind
(repeat_call fd (fun () -> Ssl.accept socket)) (fun () ->
Lwt.return (fd, SSL socket))
let ssl_connect fd ctx =
let socket = Ssl.embed_socket (Lwt_unix.unix_file_descr fd) ctx in
Lwt.bind
(repeat_call fd (fun () -> Ssl.connect socket)) (fun () ->
Lwt.return (fd, SSL socket))
let read (fd, s) buf pos len =
match s with
| Plain ->
Lwt_unix.read fd buf pos len
| SSL s ->
if len = 0 then
Lwt.return 0
else
repeat_call fd
(fun () ->
try
Ssl.read s buf pos len
with Ssl.Read_error Ssl.Error_zero_return ->
0)
let read_bytes (fd, s) buf pos len =
match s with
| Plain ->
Lwt_bytes.read fd buf pos len
| SSL s ->
if len = 0 then
Lwt.return 0
else
repeat_call fd
(fun () ->
try
let str = String.create len in
let n = Ssl.read s str 0 len in
Lwt_bytes.blit_string_bytes str 0 buf pos len;
n
with Ssl.Read_error Ssl.Error_zero_return ->
0)
let write (fd, s) buf pos len =
match s with
| Plain ->
Lwt_unix.write fd buf pos len
| SSL s ->
if len = 0 then
Lwt.return 0
else
repeat_call fd
(fun () ->
Ssl.write s buf pos len)
let write_bytes (fd, s) buf pos len =
match s with
| Plain ->
Lwt_bytes.write fd buf pos len
| SSL s ->
if len = 0 then
Lwt.return 0
else
repeat_call fd
(fun () ->
let str = String.create len in
Lwt_bytes.blit_bytes_string buf pos str 0 len;
Ssl.write s str 0 len)
let wait_read (fd, s) =
match s with
Plain -> Lwt_unix.wait_read fd
| SSL _ -> Lwt_unix.yield ()
let wait_write (fd, s) =
match s with
Plain -> Lwt_unix.wait_write fd
| SSL _ -> Lwt_unix.yield ()
let out_channel_of_descr s =
Lwt_io.make ~mode:Lwt_io.output (fun buf pos len -> write_bytes s buf pos len)
let in_channel_of_descr s =
Lwt_io.make ~mode:Lwt_io.input (fun buf pos len -> read_bytes s buf pos len)
let ssl_shutdown (fd, s) =
match s with
Plain -> Lwt.return ()
| SSL s -> repeat_call fd (fun () -> Ssl.shutdown s)
let shutdown (fd, _) cmd = Lwt_unix.shutdown fd cmd
let close (fd, _) = Lwt_unix.close fd
let abort (fd, _) = Lwt_unix.abort fd
let get_fd (fd,socket) =
match socket with
| Plain -> Lwt_unix.unix_file_descr fd
| SSL socket -> (Ssl.file_descr_of_socket socket)
let getsockname s =
Unix.getsockname (get_fd s)
let getpeername s =
Unix.getpeername (get_fd s)

58
server/thirdparty/lwt-2.3.2/src/ssl/lwt_ssl.mli vendored
View File

@ -1,58 +0,0 @@
(* Lightweight thread library for Objective Caml
* 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
val ssl_accept : Lwt_unix.file_descr -> Ssl.context -> socket Lwt.t
val ssl_connect : Lwt_unix.file_descr -> Ssl.context -> socket Lwt.t
val plain : Lwt_unix.file_descr -> socket
val embed_socket : Lwt_unix.file_descr -> Ssl.context -> socket
val read : socket -> string -> int -> int -> int Lwt.t
val write : socket -> string -> int -> int -> int Lwt.t
val read_bytes : socket -> Lwt_bytes.t -> int -> int -> int Lwt.t
val write_bytes : socket -> Lwt_bytes.t -> int -> int -> int Lwt.t
(* Really wait on a plain socket, just yield over SSL *)
val wait_read : socket -> unit Lwt.t
val wait_write : socket -> unit Lwt.t
val shutdown : socket -> Unix.shutdown_command -> unit
val close : socket -> unit Lwt.t
val out_channel_of_descr : socket -> Lwt_chan.out_channel
val in_channel_of_descr : socket -> Lwt_chan.in_channel
val ssl_shutdown : socket -> unit Lwt.t
val abort : socket -> exn -> unit
(** Are we using an SSL socket? *)
val is_ssl : socket -> bool
val getsockname : socket -> Unix.sockaddr
val getpeername : socket -> Unix.sockaddr

4
server/thirdparty/lwt-2.3.2/src/text/liblwt-text.clib vendored
View File

@ -1,4 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 49d58712acb378a903b0dfd06803031a)
lwt_text_stubs.o
# OASIS_STOP

6
server/thirdparty/lwt-2.3.2/src/text/lwt-text.mllib vendored
View File

@ -1,6 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 445f786e72bdc58b36891d69973effc4)
Lwt_text
Lwt_term
Lwt_read_line
# OASIS_STOP

1639
server/thirdparty/lwt-2.3.2/src/text/lwt_read_line.ml vendored
View File

File diff suppressed because it is too large Load Diff

453
server/thirdparty/lwt-2.3.2/src/text/lwt_read_line.mli vendored
View File

@ -1,453 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_read_line
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Interactive line input *)
(** {6 Definitions} *)
exception Interrupt
(** Exception raised when the user press [Ctrl^D] *)
type edition_state = Text.t * Text.t
(** An edition state, it is a pair of two UTF-8 encoded strings:
- the input before the cursor
- the input after the cursor *)
type prompt = Lwt_term.styled_text
(** A prompt. It may contains colors. *)
type text_set = Set.Make(Text).t
(** {8 Completion} *)
(** Result of a completion function: *)
type completion_result = {
comp_state : edition_state;
(** The new edition state *)
comp_words : text_set;
(** A list of possibilities *)
}
type completion = edition_state -> completion_result Lwt.t
(** Type of a completion function. It takes as argument the
current edition state.
Note: the thread launched by the completion function is
cancelled using {!Lwt.cancel} if the user continue typing
text. *)
val lookup : Text.t -> text_set -> (Text.t * text_set)
(** [lookup word words] lookup for completion of [word] into
[words]. It returns [(prefix, possibilities)] where
[possibilities] are all words starting with [word] and [prefix]
is the longest common prefix of [possibilities]. *)
val complete : ?suffix : Text.t -> Text.t -> Text.t -> Text.t -> text_set -> completion_result
(** [complete ?suffix before word after words] basic completion
functions. [words] is a list of possible completions for
[word].
If completion succeed [suffix] is append to the resulting
text. It defaults to [" "]. *)
val print_words : Lwt_text.output_channel -> int -> string list -> unit Lwt.t
(** [print_words oc columns strs] pretty-prints a list of words. *)
(** {8 History} *)
type history = Text.t list
(** Type of an history *)
val add_entry : Text.t -> history -> history
(** [add_entry line history] returns the history [history] plus
[line] at the beginning. If [line] already appears at the
beginning or contains only spaces, it is discarded. *)
val save_history : string -> history -> unit Lwt.t
(** [save_history filename history] saves [history] to
[filename]. History is saved by separating lines with a null
character. *)
val load_history : string -> history Lwt.t
(** [load_history filename] loads history from [filename]. Returns
the empty history if the the file does not exit. *)
(** {8 Clipboards} *)
(** Type of a clipboard. *)
class clipboard : object
method set : Text.t -> unit
method contents : Text.t React.signal
end
val clipboard : clipboard
(** The global clipboard. All read-line instances which do not use a
specific clipboard use this one. *)
(** {6 High-level functions} *)
type completion_mode = [ `classic | `real_time | `none ]
(** The completion mode.
- [`classic] means that when the user hit [Tab] a list of
possible completions is proposed,
- [`real_time] means that possible completions are shown to
the user as he types, and he can navigate in them with
[Meta+left], [Meta+right]
- [`none] means no completion at all *)
val read_line :
?history : history ->
?complete : completion ->
?clipboard : clipboard ->
?mode : completion_mode ->
?prompt : prompt -> unit -> Text.t Lwt.t
(** [readline ?history ?complete ?mode ?prompt ()] inputs some text
from the user. If input is not a terminal, it defaults to
[Lwt_text.read_line Lwt_text.stdin].
If @param mode contains the current completion mode. It defaults
to [`real_time].
@param prompt defaults to [Lwt_term.Text "# "] *)
type password_style = [ `empty | `clear | `text of Text.t ]
(** Style which indicate how the password is echoed to the user:
- with [`empty] nothing is printed
- with [`clear] the password is displayed has it
- with [`text ch] all characters are replaced by [ch] *)
val read_password :
?clipboard : clipboard ->
?style : password_style ->
?prompt : prompt -> unit -> Text.t Lwt.t
(** [read_password ?clipboard ?clear ~prompt ()] inputs a password
from the user. This function fails if input is not a terminal.
@param style defaults to [`text "*"].
*)
val read_keyword :
?history : history ->
?case_sensitive : bool ->
?mode : completion_mode ->
?prompt : prompt ->
values : (Text.t * 'value) list -> unit -> 'value Lwt.t
(** [read_keyword ?history ?case_sensitive ?mode ~prompt ~keywords
()] reads one word which is a member of [words]. And returns
which keyword the user choosed.
[case_sensitive] default to [false]. *)
val read_yes_no : ?history : history -> ?mode : completion_mode -> ?prompt : prompt -> unit -> bool Lwt.t
(** [read_yes_no ?history ?dynamic prompt ()] is the same as:
{[
read_keyword ?history ?dynamic prompt [("yes", true); ("no", false)] ()
]}
*)
(** {6 Low-level interaction} *)
(** This part allow you to implements your own read-line function, or
just to use the readline engine in another context (message box,
...). *)
(** Readline commands *)
module Command : sig
(** Type of all read-line function: *)
type t =
| Nop
(** Command which do nothing. Unknown keys maps to this commands. *)
| Char of Text.t
(** Any printable character. *)
| Backward_delete_char
| Forward_delete_char
| Beginning_of_line
| End_of_line
| Complete
| Meta_complete
| Kill_line
| Backward_kill_line
| Accept_line
| Backward_delete_word
| Forward_delete_word
| History_next
| History_previous
| Break
| Clear_screen
| Insert
| Refresh
| Backward_char
| Forward_char
| Set_mark
| Paste
| Copy
| Cut
| Uppercase
| Lowercase
| Capitalize
| Backward_word
| Forward_word
| Backward_search
| Complete_left
| Complete_right
| Complete_up
| Complete_down
| Complete_first
| Complete_last
| Undo
| Delete_char_or_list
val to_string : t -> string
(** [to_string cmd] returns a string representation of a command *)
val of_string : string -> t
(** [of_string cld] tries to convert a command name to a
command. @raise Failure if it fails. *)
val names : (t * string) list
(** [names] is the list of all commands (except [Char ch]) with
their name. *)
val of_key : Lwt_term.key -> t
(** [of_key key] returns the command to which a key is mapped. *)
end
(** Engine *)
module Engine : sig
(** Note: this part know nothing about rendering or completion. *)
(** State when the user is doing selection: *)
type selection_state = {
sel_text : Text.t;
(** The whole input text on which the selection is working *)
sel_mark : Text.pointer;
(** Pointer to the mark *)
sel_cursor : Text.pointer;
(** Pointer to the cursor *)
}
(** State when searching in the history *)
type search_state = {
search_word : Text.t;
(** The word we are looking for *)
search_history : history;
(** Position in history. The first element is a sentence
containing the searched word *)
search_init_history : history;
(** The initial history, before searching for a word *)
}
(** The engine mode: *)
type mode =
| Edition of edition_state
(** The user is typing some text *)
| Selection of selection_state
(** The user is selecting some text *)
| Search of search_state
(** The user is searching the given word in the history *)
(** An engine state: *)
type state = {
mode : mode;
history : history * history;
(** Cursor to the history position. *)
}
val init : history -> state
(** [init history] return a initial state using the given
history *)
val reset : state -> state
(** [reset state] reset the given state, if the user was doing a
selection, it is canceled *)
val update : engine_state : state -> ?clipboard : clipboard -> command : Command.t -> unit -> state
(** [update ~state ?clipboard ~command ()] update an engine state by
processing the given command. It returns the new state, and
may have the side effect of changing the clipboard contents.
[clipboard] defaults to the global clipboard.
*)
val edition_state : state -> edition_state
(** Returns the edition state of a state, whatever its mode is. *)
val all_input : state -> Text.t
(** Returns the current complete user input. *)
end
(** Rendering to the terminal *)
module Terminal : sig
type state
(** State of rendering *)
val init : state
(** Initial state *)
(** The following functions are the one used by read-line functions
of this module. *)
(** Box for the completion: *)
type box =
| Box_none
(** No box at all *)
| Box_empty
(** An empty box *)
| Box_words of text_set * int
(** [BM_words(words, position)] is a box with the given list
of words. [position] is the position of the selected word
in the list.. *)
| Box_message of string
(** A box containing only the given message *)
val draw :
columns : int ->
?map_text : (Text.t -> Text.t) ->
?box : box ->
render_state : state ->
engine_state : Engine.state ->
prompt : prompt -> unit -> Lwt_term.styled_text * state
(** [draw ~column ?map_text ?bar ~render_state ~engine_state
prompt ()] returns [(text, state)] where [state] is the new
rendering state, and [text] is a text containing escape
sequences. When printed, it will update the displayed state.
@param map_text is a function used to map user input before
printing it, for example to hide passwords.
@param message is a message to display if completion is not
yet available.
@param box defaults to {!Box_none}. *)
val last_draw :
columns : int ->
?map_text : (Text.t -> Text.t) ->
render_state : state ->
engine_state : Engine.state ->
prompt : prompt -> unit -> Lwt_term.styled_text
(** Draw for the last time, i.e. the cursor is left after the text
and not at current position. *)
val erase : columns : int -> render_state : state -> unit -> Lwt_term.styled_text
(** [erase ~columns ~render_state ()] returns a text which will
erase everything (the prompt, user input, completion, ...).
After an erase, the rendering state is [init]. *)
end
(** {6 Advanced use} *)
(** Controlling a running read-line instance *)
module Control : sig
type 'a t
(** Type of a running read-line instance, returning a value of
type ['a] *)
(** {6 Control} *)
val result : 'a t -> 'a Lwt.t
(** Threads waiting for the read-line instance to terminates *)
val send_command : 'a t -> Command.t -> unit
(** [send_command instance command] sends the given command to the
read-line instance *)
val accept : 'a t -> unit
(** [accept instance = send_command instance Command.Accept_line] *)
val interrupt : 'a t -> unit
(** [accept instance = send_command instance Command.Break] *)
val hide : 'a t -> unit Lwt.t
(** Hides everything (prompt, user input, completion box) until
{!show} is called. *)
val show : 'a t -> unit Lwt.t
(** Un-hide everything *)
(** Note: in case the input is not a terminal, read-line instances
are not controllable. i.e. {!accept}, {!refresh}, ... have no
effect. *)
(** {6 Creation of read-line instances} *)
type prompt = Engine.state React.signal -> Lwt_term.styled_text React.signal
(** The prompt a signal which may depends on the engine state *)
type state
(** State of an instance *)
val engine_state : state -> Engine.state
(** Return the engine state of the given state *)
val render_state : state -> Terminal.state
(** Return the rendering state of the given state *)
val make :
?history : history ->
?complete : completion ->
?clipboard : clipboard ->
?mode : [ completion_mode | `none ] ->
?map_text : (Text.t -> Text.t) ->
?filter : (state -> Command.t -> Command.t Lwt.t) ->
map_result : (Text.t -> 'a Lwt.t) ->
?prompt : prompt -> unit -> 'a t
(** Creates a new read-line instance with the given
parameters. [filter] is called to handle commands. You can
return {!Command.Nop} to drop a command. *)
(** {6 Predefined instances} *)
val read_line :
?history : history ->
?complete : completion ->
?clipboard : clipboard ->
?mode : completion_mode ->
?prompt : prompt -> unit -> Text.t t Lwt.t
val read_password :
?clipboard : clipboard ->
?style : password_style ->
?prompt : prompt -> unit -> Text.t t Lwt.t
val read_keyword :
?history : history ->
?case_sensitive : bool ->
?mode : completion_mode ->
?prompt : prompt ->
values : (Text.t * 'value) list -> unit -> 'value t Lwt.t
val read_yes_no :
?history : history ->
?mode : completion_mode ->
?prompt : prompt -> unit -> bool t Lwt.t
end

847
server/thirdparty/lwt-2.3.2/src/text/lwt_term.ml vendored
View File

@ -1,847 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_term
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
open Lwt
open Lwt_text
(* +-----------------------------------------------------------------+
| Terminal mode |
+-----------------------------------------------------------------+ *)
type state =
| Normal
| Raw of Unix.terminal_io
let state = ref Normal
(* Number of function currently using the raw mode: *)
let raw_count = ref 0
let get_attr () =
try_lwt
lwt attr = Lwt_unix.tcgetattr Lwt_unix.stdin in
return (Some attr)
with _ ->
return None
let set_attr mode =
try_lwt
Lwt_unix.tcsetattr Lwt_unix.stdin Unix.TCSAFLUSH mode
with _ ->
return ()
let drawing_mode = ref false
let enter_drawing_mode () =
drawing_mode := true;
write stdout "\027[?1049h\027[?1h\027=\r"
let leave_drawing_mode () =
drawing_mode := false;
write stdout "\r\027[K\027[?1l\027>\027[r\027[?1049l"
let cursor_visible = ref true
let show_cursor _ =
cursor_visible := true;
write stdout "\x1B[?25h"
let hide_cursor _ =
cursor_visible := false;
write stdout "\x1B[?25l"
let clear_screen _ =
write stdout "\027[2J\027[H"
let clear_line _ =
write stdout "\027[2K"
(* Go-up by [n] lines then to the beginning of the line. Normally
"\027[nF" does exactly this but for some terminal 1 need to be
added... By the way we can relly on the fact that all terminal
react the same way to "\027[F" which is to go to the beginning of
the previous line: *)
let rec goto_beginning_of_line = function
| 0 ->
write_char stdout "\r"
| 1 ->
write stdout "\027[F"
| n ->
lwt () = write stdout "\027[F" in
goto_beginning_of_line (n - 1)
(* Restore terminal mode on exit: *)
let cleanup () =
lwt () =
if not !cursor_visible then
show_cursor ()
else
return ()
in
lwt () =
if !drawing_mode then
leave_drawing_mode ()
else
return ()
in
match !state with
| Normal ->
return ()
| Raw saved_attr ->
set_attr saved_attr
let () = Lwt_main.at_exit cleanup
let raw_mode () = match !state with
| Normal -> false
| Raw _ -> true
let leave_raw_mode () =
decr raw_count;
if !raw_count = 0 then
match !state with
| Normal ->
assert false
| Raw attr ->
state := Normal;
set_attr attr
else
return ()
let with_raw_mode f =
match !state with
| Raw attr ->
incr raw_count;
finalize f leave_raw_mode
| Normal ->
get_attr () >>= function
| Some attr ->
incr raw_count;
state := Raw attr;
lwt () = set_attr {
attr with
(* Inspired from Python-3.0/Lib/tty.py: *)
Unix.c_brkint = false;
Unix.c_inpck = false;
Unix.c_istrip = false;
Unix.c_ixon = false;
Unix.c_csize = 8;
Unix.c_parenb = false;
Unix.c_echo = false;
Unix.c_icanon = false;
Unix.c_isig = false;
Unix.c_vmin = 1;
Unix.c_vtime = 0
} in
try_lwt f () finally leave_raw_mode ()
| None ->
raise_lwt (Failure "Lwt_term.with_raw_mode: input is not a tty")
(* +-----------------------------------------------------------------+
| Terminal informations |
+-----------------------------------------------------------------+ *)
type size = {
lines : int;
columns : int;
}
external get_size : Unix.file_descr -> size = "lwt_text_term_size"
#if windows
let size =
React.S.const
(try
get_size Unix.stdout
with Unix.Unix_error _ ->
{ columns = 80; lines = 25 })
#else
external sigwinch : unit -> int = "lwt_text_sigwinch"
let sigwinch = sigwinch ()
let sigwinch_event =
if sigwinch = 0 then
React.E.never
else
try
let event, push = React.E.create () in
let _ = Lwt_unix.on_signal sigwinch push in
event
with Unix.Unix_error _ | Invalid_argument _ | Sys_error _ ->
React.E.never
let size =
React.S.hold
(try
get_size Unix.stdin
with Unix.Unix_error _ ->
{ columns = 80; lines = 25 })
(React.E.map (fun _ -> get_size Unix.stdin) sigwinch_event)
#endif
let columns = React.S.map (fun { columns = c } -> c) size
let lines = React.S.map (fun { lines = l } -> l) size
(* +-----------------------------------------------------------------+
| Keys input |
+-----------------------------------------------------------------+ *)
exception Exit_sequence
let parse_escape st =
let buf = Buffer.create 10 in
Buffer.add_char buf '\027';
(* Read one character and add it to [buf]: *)
let get () =
match Lwt.state (Lwt_stream.get st) with
| Sleep ->
(* If the rest is not immediatly available, conclude that
this is not an escape sequence but just the escape key: *)
raise_lwt Exit_sequence
| Fail exn ->
raise_lwt exn
| Return None ->
raise_lwt Exit_sequence
| Return(Some ch) ->
(* Is it an ascii character ? *)
if String.length ch = 1 then begin
Buffer.add_string buf ch;
return ch.[0]
end else
(* If it is not, then this is not an escape sequence: *)
raise_lwt Exit_sequence
in
(* Sometimes sequences starts with several escape characters: *)
let rec first count =
get () >>= function
| '\027' when count < 3 ->
first (count + 1)
| ch ->
return ch
in
first 0 >>= function
| '[' | 'O' ->
let rec loop () =
get () >>= function
| '0' .. '9' | ';' ->
loop ()
| ch ->
return (Buffer.contents buf)
in
loop ()
| ch ->
return (Buffer.contents buf)
let parse_key_raw st =
Lwt_stream.next st >>= function
| "\027" ->
begin
try_lwt
Lwt_stream.parse st parse_escape
with
Exit_sequence -> return "\027"
end
| ch ->
return ch
type key =
| Key of string
| Key_up
| Key_down
| Key_left
| Key_right
| Key_f of int
| Key_next_page
| Key_previous_page
| Key_home
| Key_end
| Key_insert
| Key_delete
| Key_control of char
let key_enter = Key_control 'j'
let key_escape = Key_control '['
let key_tab = Key_control 'i'
let key_backspace = Key_control '?'
let string_of_key = function
| Key ch ->
Printf.sprintf "Key %S" ch
| Key_f n ->
Printf.sprintf "Key_f %d" n
| Key_control c ->
Printf.sprintf "Key_control %C" c
| Key_up ->
"Key_up"
| Key_down ->
"Key_down"
| Key_left ->
"Key_left"
| Key_right ->
"Key_right"
| Key_next_page ->
"Key_next_page"
| Key_previous_page ->
"Key_previous_page"
| Key_home ->
"Key_home"
| Key_end ->
"Key_end"
| Key_insert ->
"Key_insert"
| Key_delete ->
"Key_delete"
let sequence_mapping = [
"\027[A", Key_up;
"\027[B", Key_down;
"\027[C", Key_right;
"\027[D", Key_left;
"\027A", Key_up;
"\027B", Key_down;
"\027C", Key_right;
"\027D", Key_left;
"\027OA", Key_up;
"\027OB", Key_down;
"\027OC", Key_right;
"\027OD", Key_left;
"\027[2~", Key_insert;
"\027[3~", Key_delete;
"\027[5~", Key_previous_page;
"\027[6~", Key_next_page;
"\027[7~", Key_home;
"\027[8~", Key_end;
"\027[11~", Key_f 1;
"\027[12~", Key_f 2;
"\027[13~", Key_f 3;
"\027[14~", Key_f 4;
"\027[15~", Key_f 5;
"\027[17~", Key_f 6;
"\027[18~", Key_f 7;
"\027[19~", Key_f 8;
"\027[20~", Key_f 9;
"\027[21~", Key_f 10;
"\027[23~", Key_f 11;
"\027[24~", Key_f 12;
"\027OP", Key_f 1;
"\027OQ", Key_f 2;
"\027OR", Key_f 3;
"\027OS", Key_f 4;
"\027[H", Key_home;
"\027[F", Key_end;
"\027OH", Key_home;
"\027OF", Key_end;
"\027H", Key_home;
"\027F", Key_end;
]
let control_mapping = [
0x00, '@';
0x01, 'a';
0x02, 'b';
0x03, 'c';
0x04, 'd';
0x05, 'e';
0x06, 'f';
0x07, 'g';
0x08, 'h';
0x09, 'i';
0x0A, 'j';
0x0B, 'k';
0x0C, 'l';
0x0D, 'm';
0x0E, 'n';
0x0F, 'o';
0x10, 'p';
0x11, 'q';
0x12, 'r';
0x13, 's';
0x14, 't';
0x15, 'u';
0x16, 'v';
0x17, 'w';
0x18, 'x';
0x19, 'y';
0x1A, 'z';
0x1B, '[';
0x1C, '\\';
0x1D, ']';
0x1E, '^';
0x1F, '_';
0x7F, '?';
]
let decode_key ch =
if ch = "" then invalid_arg "Lwt_term.decode_key";
match ch with
| ch when String.length ch = 1 ->
begin try
Key_control(List.assoc (Char.code ch.[0]) control_mapping)
with
Not_found -> Key ch
end
| ch ->
begin try
List.assoc ch sequence_mapping
with
Not_found -> Key ch
end
let standard_input = Lwt_text.read_chars Lwt_text.stdin
let read_key () =
with_raw_mode (fun _ -> parse_key_raw standard_input >|= decode_key)
(* +-----------------------------------------------------------------+
| Styles |
+-----------------------------------------------------------------+ *)
type color = int
let default = -1
let black = 0
let red = 1
let green = 2
let yellow = 3
let blue = 4
let magenta = 5
let cyan = 6
let white = 7
let lblack = black + 8
let lred = red + 8
let lgreen = green + 8
let lyellow = yellow + 8
let lblue = blue + 8
let lmagenta = magenta + 8
let lcyan = cyan + 8
let lwhite = white + 8
type style = {
bold : bool;
underlined : bool;
blink : bool;
inverse : bool;
hidden : bool;
foreground : color;
background : color;
}
module Codes = struct
let reset = 0
let bold = 1
let underlined = 4
let blink = 5
let inverse = 7
let hidden = 8
let foreground col = 30 + col
let background col = 40 + col
end
let set_color num (r, g, b) =
write stdout (Printf.sprintf "\027]4;%d;rgb:%02x/%02x/%02x;\027\\" num r g b)
(* +-----------------------------------------------------------------+
| Rendering |
+-----------------------------------------------------------------+ *)
type point = {
char : string;
style : style;
}
let blank = {
char = " ";
style = {
bold = false;
underlined = false;
blink = false;
inverse = false;
hidden = false;
foreground = default;
background = default;
};
}
let rec add_int buf = function
| 0 ->
()
| n ->
add_int buf (n / 10);
Buffer.add_char buf (Char.unsafe_chr (48 + (n mod 10)))
let render_char buf oc pt last_style =
lwt () =
if pt.style <> last_style then begin
Buffer.clear buf;
Buffer.add_string buf "\027[0";
let mode n = function
| true ->
Buffer.add_char buf ';';
add_int buf n
| false ->
()
and color f col =
if col = default then
()
else if col < 8 then begin
Buffer.add_char buf ';';
add_int buf (f col)
end else begin
Buffer.add_char buf ';';
add_int buf (f 8);
Buffer.add_string buf ";5;";
add_int buf col;
end
in
mode Codes.bold pt.style.bold;
mode Codes.underlined pt.style.underlined;
mode Codes.blink pt.style.blink;
mode Codes.inverse pt.style.inverse;
mode Codes.hidden pt.style.hidden;
color Codes.foreground pt.style.foreground;
color Codes.background pt.style.background;
Buffer.add_char buf 'm';
write oc (Buffer.contents buf)
end else
return ()
in
write_char oc pt.char
let render_update old m =
let buf = Buffer.create 16 in
Lwt_text.atomic begin fun oc ->
let rec loop_y y last_style =
if y < Array.length m then
let rec loop_x x last_style =
if x < Array.length m.(y) then
let pt = m.(y).(x) in
lwt () = render_char buf oc pt last_style in
loop_x (x + 1) pt.style
else
loop_y (y + 1) last_style
in
if y < Array.length old && old.(y) = m.(y) then begin
if y + 1 < Array.length m then
lwt last_style =
if Array.length m.(y) > 0 then
let pt = m.(y).(0) in
lwt () = render_char buf oc pt last_style in
return pt.style
else
return last_style
in
lwt () = write oc "\r\n" in
loop_y (y + 1) last_style
else
return ()
end else
loop_x 0 last_style
else
return ()
in
(* Go to the top-left corner and reset attributes: *)
lwt () = write oc "\027[H\027[0m" in
lwt () = loop_y 0 blank.style in
write oc "\027[0m"
end stdout
let render m = render_update [||] m
(* +-----------------------------------------------------------------+
| Styled text |
+-----------------------------------------------------------------+ *)
open Printf
type styled_text_instruction =
| Text of Text.t
| Reset
| Bold
| Underlined
| Blink
| Inverse
| Hidden
| Foreground of color
| Background of color
type styled_text = styled_text_instruction list
let textf fmt = Printf.ksprintf (fun txt -> Text txt) fmt
let text txt = Text txt
let reset = Reset
let bold = Bold
let underlined = Underlined
let blink = Blink
let inverse = Inverse
let hidden = Hidden
let fg col = Foreground col
let bg col = Background col
let strip_styles st =
let buf = Buffer.create 42 in
List.iter (function
| Text t -> Buffer.add_string buf t
| _ -> ()) st;
Buffer.contents buf
let write_styled oc st =
let buf = Buffer.create 16
(* Pendings style codes: *)
and codes = Queue.create () in
(* Output pending codes using only one escape sequence: *)
let output_pendings () =
Buffer.clear buf;
Buffer.add_string buf "\027[";
add_int buf (Queue.take codes);
Queue.iter (fun code ->
Buffer.add_char buf ';';
add_int buf code) codes;
Queue.clear codes;
Buffer.add_char buf 'm';
write oc (Buffer.contents buf)
in
let rec loop = function
| [] ->
if not (Queue.is_empty codes) then
output_pendings ()
else
return ()
| instr :: rest ->
match instr with
| Text t ->
if not (Queue.is_empty codes) then
lwt () = output_pendings () in
lwt () = write oc t in
loop rest
else
lwt () = write oc t in
loop rest
| Reset ->
Queue.add 0 codes;
loop rest
| Bold ->
Queue.add Codes.bold codes;
loop rest
| Underlined ->
Queue.add Codes.underlined codes;
loop rest
| Blink ->
Queue.add Codes.blink codes;
loop rest
| Inverse ->
Queue.add Codes.inverse codes;
loop rest
| Hidden ->
Queue.add Codes.hidden codes;
loop rest
| Foreground col ->
if col = default then
Queue.add (Codes.foreground 9) codes
else if col < 8 then
Queue.add (Codes.foreground col) codes
else begin
Queue.add (Codes.foreground 8) codes;
Queue.add 5 codes;
Queue.add col codes
end;
loop rest
| Background col ->
if col = default then
Queue.add (Codes.background 9) codes
else if col < 8 then
Queue.add (Codes.background col) codes
else begin
Queue.add (Codes.background 8) codes;
Queue.add 5 codes;
Queue.add col codes
end;
loop rest
in
loop st
let styled_length st =
let rec loop len = function
| [] -> len
| Text t :: l -> loop (len + Text.length t) l
| _ :: l -> loop len l
in
loop 0 st
let printc st =
Lwt_unix.isatty Lwt_unix.stdout >>= function
| true ->
atomic (fun oc -> write_styled oc st) stdout
| false ->
write stdout (strip_styles st)
let eprintc st =
Lwt_unix.isatty Lwt_unix.stderr >>= function
| true ->
atomic (fun oc -> write_styled oc st) stderr
| false ->
write stderr (strip_styles st)
let fprintlc oc fd st =
Lwt_unix.isatty fd >>= function
| true ->
atomic (fun oc ->
lwt () = write_styled oc st in
lwt () = write oc "\027[m" in
write_char oc "\n") oc
| false ->
write_line oc (strip_styles st)
let printlc st = fprintlc stdout Lwt_unix.stdout st
let eprintlc st = fprintlc stderr Lwt_unix.stderr st
(* +-----------------------------------------------------------------+
| Drawing |
+-----------------------------------------------------------------+ *)
module Zone =
struct
type t = {
points : point array array;
x : int;
y : int;
width : int;
height : int;
}
let points zone = zone.points
let x zone = zone.x
let y zone = zone.y
let width zone = zone.width
let height zone = zone.height
let make ~width ~height =
if width < 0 || height < 0 then invalid_arg "Lwt_term.Zone.make";
{
points = Array.make_matrix height width blank;
x = 0;
y = 0;
width = width;
height = height;
}
let sub ~zone ~x ~y ~width ~height =
if (x < 0 || y < 0 ||
width < 0 || height < 0 ||
x + width > zone.width ||
y + height > zone.height) then
invalid_arg "Lwt_term.Zone.sub";
{
points = zone.points;
x = zone.x + x;
y = zone.y + y;
width = width;
height = height;
}
let inner zone = {
points = zone.points;
x = if zone.width >= 2 then zone.x + 1 else zone.x;
y = if zone.height >= 2 then zone.y + 1 else zone.y;
width = if zone.width >= 2 then zone.width - 2 else zone.width;
height = if zone.height >= 2 then zone.height - 2 else zone.height;
}
end
module Draw =
struct
open Zone
let get ~zone ~x ~y =
if x < 0 || y < 0 || x >= zone.width || y >= zone.height then
invalid_arg "Lwt_term.Draw.get";
zone.points.(zone.y + y).(zone.x + x)
let set ~zone ~x ~y ~point =
if x < 0 || y < 0 || x >= zone.width || y >= zone.height then
()
else
zone.points.(zone.y + y).(zone.x + x) <- point
let map ~zone ~x ~y f =
if x < 0 || y < 0 || x >= zone.width || y >= zone.height then
()
else
let x = zone.x + x and y = zone.y + y in
zone.points.(y).(x) <- f zone.points.(y).(x)
let text ~zone ~x ~y ~text =
let rec loop x ptr = match Text.next ptr with
| Some(ch, ptr) ->
set zone x y { blank with char = ch };
loop (x + 1) ptr
| None ->
()
in
loop x (Text.pointer_l text)
let textf zone x y fmt =
Printf.ksprintf (fun txt -> text zone x y txt) fmt
let textc ~zone ~x ~y ~text =
let rec loop style x = function
| [] ->
()
| instr :: rest ->
match instr with
| Text text ->
loop_text style x (Text.pointer_l text) rest
| Reset ->
loop blank.style x rest
| Bold ->
loop { style with bold = true } x rest
| Underlined ->
loop { style with underlined = true } x rest
| Blink ->
loop { style with blink = true } x rest
| Inverse ->
loop { style with inverse = true } x rest
| Hidden ->
loop { style with hidden = true } x rest
| Foreground color ->
loop { style with foreground = color } x rest
| Background color ->
loop { style with background = color } x rest
and loop_text style x ptr rest =
match Text.next ptr with
| Some(ch, ptr) ->
set zone x y { char = ch; style = style };
loop_text style (x + 1) ptr rest
| None ->
loop style x rest
in
loop blank.style x text
end

393
server/thirdparty/lwt-2.3.2/src/text/lwt_term.mli vendored
View File

@ -1,393 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_term
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Terminal control *)
(** This modules allow you to write interactive programs using the
terminal. *)
val with_raw_mode : (unit -> 'a Lwt.t) -> 'a Lwt.t
(** [with_raw_mode f] executes [f] while the terminal is in ``raw
mode''. Raw mode means that character are returned as the user
type them (otherwise only complete line are returned to the
program).
If the terminal is already in raw mode, it just calls [f]. *)
val raw_mode : unit -> bool
(** Returns wether the terminal is currently in raw mode *)
val enter_drawing_mode : unit -> unit Lwt.t
(** Put the terminal into drawing mode *)
val leave_drawing_mode : unit -> unit Lwt.t
(** Restore the state of the terminal *)
val show_cursor : unit -> unit Lwt.t
(** [show_cursor ()] makes the cursor visible *)
val hide_cursor : unit -> unit Lwt.t
(** [hide_cursor ()] makes the cursor invisible *)
val clear_screen : unit -> unit Lwt.t
(** [clear_screen ()] clears the entire screen *)
val clear_line : unit -> unit Lwt.t
(** [clear_line ()] clears the current line *)
val goto_beginning_of_line : int -> unit Lwt.t
(** [goto_beginning_of_line n] put the cursor at the beginning of
the [n]th previous line.
- [goto_beginning_of_line 0] goes to the beginning of the current line
- [goto_beginning_of_line 1] goes to the beginning of the previous line
- ...
*)
(** {6 Terminal informations} *)
(** Terminal sizes: *)
type size = {
lines : int;
columns : int;
}
val size : size React.signal
(** Size of the terminal. *)
val columns : int React.signal
(** Number of columns of the terminal *)
val lines : int React.signal
(** Number of lines of the terminal *)
(** {6 Keys} *)
val parse_key_raw : Text.t Lwt_stream.t -> Text.t Lwt.t
(** [parse_key_raw st] recognize escape sequence in a stream of
unicode character.
It returns either:
- either single characters, like ["a"], ["é"], ...
- either escape sequences
*)
(** Type of ``decoded'' keys.
This list is not exhaustive, but at least it should works on all
terminals: *)
type key =
| Key of Text.t
(** A unicode character or an uninterpreted sequence *)
| Key_up
| Key_down
| Key_left
| Key_right
| Key_f of int
| Key_next_page
| Key_previous_page
| Key_home
| Key_end
| Key_insert
| Key_delete
| Key_control of char
(** A control key *)
val string_of_key : key -> string
(** [string_of_key key] string representation of a key *)
val control_mapping : (int * char) list
(** Mapping from control key codes to character codes.
Here is the list of control keys:
{[
+------+-------+------+------+------+-------+------------------------------------------------+
| Char | Oct | Dec | Name | Hex | Key | Comment |
+------+-------+------+------+------+-------+------------------------------------------------+
| '@' | 0o00 | 0 | NUL | 0x00 | ^@ \0 | Null byte |
| 'a' | 0o01 | 1 | SOH | 0x01 | ^A | Start of heading |
| 'b' | 0o02 | 2 | STX | 0x02 | ^B | Start of text |
| 'c' | 0o03 | 3 | ETX | 0x03 | ^C | End of text |
| 'd' | 0o04 | 4 | EOT | 0x04 | ^D | End of transmission |
| 'e' | 0o05 | 5 | ENQ | 0x05 | ^E | Enquiry |
| 'f' | 0o06 | 6 | ACK | 0x06 | ^F | Acknowledge |
| 'g' | 0o07 | 7 | BEL | 0x07 | ^G | Ring terminal bell |
| 'h' | 0o10 | 8 | BS | 0x08 | ^H \b | Backspace |
| 'i' | 0o11 | 9 | HT | 0x09 | ^I \t | Horizontal tab |
| 'j' | 0o12 | 10 | LF | 0x0a | ^J \n | Line feed |
| 'k' | 0o13 | 11 | VT | 0x0b | ^K | Vertical tab |
| 'l' | 0o14 | 12 | FF | 0x0c | ^L \f | Form feed |
| 'm' | 0o15 | 13 | CR | 0x0d | ^M \r | Carriage return |
| 'n' | 0o16 | 14 | SO | 0x0e | ^N | Shift out |
| 'o' | 0o17 | 15 | SI | 0x0f | ^O | Shift in |
| 'p' | 0o20 | 16 | DLE | 0x10 | ^P | Data link escape |
| 'q' | 0o21 | 17 | DC1 | 0x11 | ^Q | Device control 1 (XON) |
| 'r' | 0o22 | 18 | DC2 | 0x12 | ^R | Device control 2 |
| 's' | 0o23 | 19 | DC3 | 0x13 | ^S | Device control 3 (XOFF) |
| 't' | 0o24 | 20 | DC4 | 0x14 | ^T | Device control 4 |
| 'u' | 0o25 | 21 | NAK | 0x15 | ^U | Negative acknowledge |
| 'v' | 0o26 | 22 | SYN | 0x16 | ^V | Synchronous idle |
| 'w' | 0o27 | 23 | ETB | 0x17 | ^W | End of transmission block |
| 'x' | 0o30 | 24 | CAN | 0x18 | ^X | Cancel |
| 'y' | 0o31 | 25 | EM | 0x19 | ^Y | End of medium |
| 'z' | 0o32 | 26 | SUB | 0x1a | ^Z | Substitute character |
| '[' | 0o33 | 27 | ESC | 0x1b | ^[ | Escape |
| '\' | 0o34 | 28 | FS | 0x1c | ^\ | File separator, Information separator four |
| ']' | 0o35 | 29 | GS | 0x1d | ^] | Group separator, Information separator three |
| '^' | 0o36 | 30 | RS | 0x1e | ^^ | Record separator, Information separator two |
| '_' | 0o37 | 31 | US | 0x1f | ^_ | Unit separator, Information separator one |
| '?' | 0o177 | 127 | DEL | 0x7f | ^? | Delete |
+------+-------+------+------+------+-------+------------------------------------------------+
]}
*)
val key_enter : key
(** [key_enter = Key_control 'j'] *)
val key_escape : key
(** [key_escape = Key_control '\['] *)
val key_tab : key
(** [key_escape = Key_control 'i'] *)
val key_backspace : key
(** [key_backspace = Key_control '?'] *)
val sequence_mapping : (Text.t * key) list
(** Mapping from sequence to keys *)
val decode_key : Text.t -> key
(** Decode a key. *)
val standard_input : Text.t Lwt_stream.t
(** The input stream used by {!read_key} *)
val read_key : unit -> key Lwt.t
(** Get and decode a key from {!standard_input} *)
(** {6 Styles} *)
type color = int
(** Type of a color. Most modern terminals support either 88 or
256 colors. *)
val set_color : color -> int * int * int -> unit Lwt.t
(** [set_color num (red, green, blue)] sets the three components of
the color number [num] *)
(** {8 Standard colors} *)
val default : color
val black : color
val red : color
val green : color
val yellow : color
val blue : color
val magenta : color
val cyan : color
val white : color
(** {8 Light colors} *)
(** Note: these colors are not supposed to works on all terminals, but
in practice it works with all modern ones. By the way, using
standard colors + bold mode will give the same result as using a
light color. *)
val lblack : color
val lred : color
val lgreen : color
val lyellow : color
val lblue : color
val lmagenta : color
val lcyan : color
val lwhite : color
(** {8 Text with styles} *)
(** Elmement of a styled-text *)
type styled_text_instruction =
| Text of Text.t
(** Some text *)
| Reset
(** Resets all styles to default *)
| Bold
| Underlined
| Blink
| Inverse
| Hidden
| Foreground of color
| Background of color
type styled_text = styled_text_instruction list
(** A styled text is a list of instructions *)
val textf : ('a, unit, string, styled_text_instruction) format4 -> 'a
(** [textf fmt] formats a texts with [fmt] and returns [Text txt] *)
val text : Text.t -> styled_text_instruction
val reset : styled_text_instruction
val bold : styled_text_instruction
val underlined : styled_text_instruction
val blink : styled_text_instruction
val inverse : styled_text_instruction
val hidden : styled_text_instruction
val fg : color -> styled_text_instruction
(** [fg col = Foreground col] *)
val bg : color -> styled_text_instruction
(** [bg col = Background col] *)
val strip_styles : styled_text -> Text.t
(** Drop all styles *)
val styled_length : styled_text -> int
(** Returns the length (in unicode character) of the given styled
text. The following equality holds for all styled-texts:
[styled_length st = Text.length (strip_styles st)]
*)
val write_styled : Lwt_text.output_channel -> styled_text -> unit Lwt.t
(** [write_styled oc st] writes [st] on [oc] using escape
sequences. *)
val printc : styled_text -> unit Lwt.t
(** [printc st] prints the given styled text on standard output. If
stdout is not a tty, then styles are stripped.
The text is encoded to the system encoding before being
output. *)
val eprintc : styled_text -> unit Lwt.t
(** Same as [printc] but prints on stderr. *)
val printlc : styled_text -> unit Lwt.t
(** [printlc st] prints [st], then reset styles and prints a
newline *)
val eprintlc : styled_text -> unit Lwt.t
(** Same as [printlc] but prints on stderr *)
(** {6 Rendering} *)
(** Character styles *)
type style = {
bold : bool;
underlined : bool;
blink : bool;
inverse : bool;
hidden : bool;
foreground : color;
background : color;
}
(** A character on the screen: *)
type point = {
char : Text.t;
(** The character. *)
style : style;
(** The character style *)
}
val blank : point
(** A space with default color and styles *)
val render : point array array -> unit Lwt.t
(** Render an offscreen array to the terminal. *)
val render_update : point array array -> point array array -> unit Lwt.t
(** [render_update displayed to_display] does the same as [render
to_display] but assumes that [displayed] contains the current
displayed text. This reduces the amount of text sent to the
terminal. *)
(** {6 Drawing} *)
(** Off-screen zones *)
module Zone : sig
type t = {
points : point array array;
(** The off-screen matrix *)
x : int;
y : int;
(** Absolute coordinates of the top-left corner of the zone *)
width : int;
height : int;
(** Dimmensions of the zone *)
}
val points : t -> point array array
val x : t -> int
val y : t -> int
val width : t -> int
val height : t -> int
val make : width : int -> height : int -> t
(** Make a new zone where all points are initialized to
{!blank} *)
val sub : zone : t -> x : int -> y : int -> width : int -> height : int -> t
(** [sub ~zone ~x ~y ~width ~height] creates a sub-zone of
[zone]. [x] and [y] are relatives to the zone top left corner.
@raise Invalid_argument if the sub zone is not included in
[zone]*)
val inner : t -> t
(** [inner zone] returns the inner part of [zone] *)
end
(** Drawing helpers *)
module Draw : sig
(** Note: except for {!get}, all function ignore points that are
outside the zone *)
val get : zone : Zone.t -> x : int -> y : int -> point
(** [get ~zone ~x ~y] returns the point at relative position [x]
and [y].
@raise Invalid_argument if the coordinates are outside the
zone *)
val set : zone : Zone.t -> x : int -> y : int -> point : point -> unit
(** [set ~zone ~x ~y ~popint] sets point at relative position [x]
and [y]. *)
val map : zone : Zone.t -> x : int -> y : int -> (point -> point) -> unit
(** [map ~zone ~x ~y f] replace the point at coordinates [(x, y)]
by the result of [f] applied on it. *)
val text : zone : Zone.t -> x : int -> y : int -> text : Text.t -> unit
(** Draw the given text at the given positon *)
val textf : Zone.t -> int -> int -> ('a, unit, string, unit) format4 -> 'a
(** Same as {!text} but uses a format string *)
val textc : zone : Zone.t -> x : int -> y : int -> text : styled_text -> unit
(** Same as {!text} but takes a text with styles *)
end

337
server/thirdparty/lwt-2.3.2/src/text/lwt_text.ml vendored
View File

@ -1,337 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_text
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
open Lwt
open Lwt_io
(* +-----------------------------------------------------------------+
| Types and creation |
+-----------------------------------------------------------------+ *)
type coder =
| Encoder of Encoding.encoder
| Decoder of Encoding.decoder
type 'a channel = {
channel : 'a Lwt_io.channel;
encoding : Text.t;
coder : coder;
strict : bool;
}
type input_channel = Lwt_io.input channel
type output_channel = Lwt_io.output channel
let encoder = function
| Encoder e -> e
| Decoder _ -> assert false
let decoder = function
| Encoder _ -> assert false
| Decoder d -> d
#if ocaml_version >= (3, 13)
let make : type m. ?strict : bool -> ?encoding : string -> m Lwt_io.channel -> m channel = fun ?(strict=false) ?(encoding=Encoding.system) ch ->
#else
let make ?(strict=false) ?(encoding=Encoding.system) ch =
#endif
{ channel = ch;
encoding = encoding;
strict = strict;
coder = match Lwt_io.mode ch with
| Input ->
Decoder(Encoding.decoder encoding)
| Output ->
Encoder(Encoding.encoder(if strict then encoding else encoding ^ "//TRANSLIT")) }
let byte_channel ch = ch.channel
let encoding ch = ch.encoding
let close ch = Lwt_io.close ch.channel
let flush ch = Lwt_io.flush ch.channel
let atomic f ch = Lwt_io.atomic (fun ch' -> f { ch with channel = ch' }) ch.channel
let open_file ?buffer_size ?strict ?encoding ?flags ?perm ~mode name =
lwt ch = Lwt_io.open_file ?flags ?perm ~mode name in
return (make ?strict ?encoding ch)
let with_file ?buffer_size ?strict ?encoding ?flags ?perm ~mode name f =
Lwt_io.with_file ?flags ?perm ~mode name (fun ch -> f (make ?strict ?encoding ch))
module Primitives =
struct
(* +---------------------------------------------------------------+
| Primitives for reading |
+---------------------------------------------------------------+ *)
let rec read_char da strict decoder =
let ptr = da.da_ptr and max = da.da_max in
if ptr = max then
da.da_perform () >>= function
| 0 -> raise_lwt End_of_file
| _ -> read_char da strict decoder
else
match Encoding_bigarray.decode decoder da.da_buffer ptr (max - ptr) with
| Encoding.Dec_ok(code, count) ->
da.da_ptr <- ptr + count;
return (Text.char code)
| Encoding.Dec_need_more ->
da.da_perform () >>= begin function
| 0 ->
if strict then
raise_lwt (Failure "Lwt_text.read_char: unterminated multibyte sequence")
else begin
da.da_ptr <- ptr + 1;
return (Text.char (Char.code da.da_buffer.{ptr}))
end
| _ ->
read_char da strict decoder
end
| Encoding.Dec_error ->
if strict then
raise_lwt (Failure "Lwt_text.read_char: unterminated multibyte sequence")
else begin
da.da_ptr <- ptr + 1;
return (Text.char (Char.code da.da_buffer.{ptr}))
end
let read_char_opt da strict decoder =
try_lwt
read_char da strict decoder >|= fun ch -> Some ch
with
| End_of_file ->
return None
| exn ->
raise_lwt exn
let rec read_all da strict decoder buf =
lwt ch = read_char da strict decoder in
Buffer.add_string buf ch;
read_all da strict decoder buf
let rec read_count da strict decoder buf = function
| 0 ->
return (Buffer.contents buf)
| n ->
lwt ch = read_char da strict decoder in
Buffer.add_string buf ch;
read_count da strict decoder buf (n - 1)
let read count da strict decoder = match count with
| None ->
let buf = Buffer.create 512 in
begin
try_lwt
read_all da strict decoder buf
with
| End_of_file ->
return (Buffer.contents buf)
end
| Some 0 ->
return ""
| Some 1 ->
begin
try_lwt
read_char da strict decoder
with
| End_of_file ->
return ""
end
| Some len ->
let buf = Buffer.create len in
begin
try_lwt
read_count da strict decoder buf len
with
| End_of_file ->
return (Buffer.contents buf)
end
let read_line da strict decoder =
let buf = Buffer.create 128 in
let rec loop cr_read =
try_bind (fun _ -> read_char da strict decoder)
(function
| "\n" ->
return(Buffer.contents buf)
| "\r" ->
if cr_read then Buffer.add_char buf '\r';
loop true
| ch ->
if cr_read then Buffer.add_char buf '\r';
Buffer.add_string buf ch;
loop false)
(function
| End_of_file ->
if cr_read then Buffer.add_char buf '\r';
return(Buffer.contents buf)
| exn ->
raise_lwt exn)
in
read_char da strict decoder >>= function
| "\r" -> loop true
| "\n" -> return ""
| ch -> Buffer.add_string buf ch; loop false
let read_line_opt da strict decoder =
try_lwt
read_line da strict decoder >|= fun ch -> Some ch
with
| End_of_file ->
return None
| exn ->
raise_lwt exn
(* +---------------------------------------------------------------+
| Primitives for writing |
+---------------------------------------------------------------+ *)
let rec write_code da encoder code =
match Encoding_bigarray.encode encoder da.da_buffer da.da_ptr (da.da_max - da.da_ptr) code with
| Encoding.Enc_ok count ->
da.da_ptr <- da.da_ptr + count;
return ()
| Encoding.Enc_need_more ->
lwt _ = da.da_perform () in
write_code da encoder code
| Encoding.Enc_error ->
raise_lwt (Failure "Lwt_text: cannot encode character")
let byte str pos = Char.code (String.unsafe_get str pos)
let next_code str i len =
let n = byte str i in
let rec trail j acc = function
| 0 ->
(j, acc)
| count ->
if j = len then
(i + 1, n)
else
let m = byte str j in
if m land 0xc0 = 0x80 then
trail (j + 1) ((acc lsl 6) lor (m land 0x3f)) (count - 1)
else
(i + 1, n)
in
if n land 0x80 = 0 then
(i + 1, n)
else if n land 0xe0 = 0xc0 then
trail (i + 1) (n land 0x1f) 1
else if n land 0xf0 = 0xe0 then
trail (i + 1) (n land 0x0f) 2
else if n land 0xf8 = 0xf0 then
trail (i + 1) (n land 0x07) 3
else
(i + 1, n)
let write_char da strict encoder = function
| "" ->
raise_lwt (Invalid_argument "Lwt_text.write_char: empty text")
| ch ->
let _, code = next_code ch 0 (String.length ch) in
write_code da encoder code
let rec write_all da strict encoder str i len =
if i = len then
return ()
else
let i, code = next_code str i len in
lwt () = write_code da encoder code in
write_all da strict encoder str i len
let write da strict encoder txt =
write_all da strict encoder txt 0 (String.length txt)
let write_line da strict encoder txt =
lwt () = write_all da strict encoder txt 0 (String.length txt) in
write_code da encoder 10
end
let read_char ic = direct_access ic.channel (fun da -> Primitives.read_char da ic.strict (decoder ic.coder))
let read_char_opt ic = direct_access ic.channel (fun da -> Primitives.read_char_opt da ic.strict (decoder ic.coder))
let read ?count ic = direct_access ic.channel (fun da -> Primitives.read count da ic.strict (decoder ic.coder))
let read_line ic = direct_access ic.channel (fun da -> Primitives.read_line da ic.strict (decoder ic.coder))
let read_line_opt ic = direct_access ic.channel (fun da -> Primitives.read_line_opt da ic.strict (decoder ic.coder))
let read_chars ic = Lwt_stream.from (fun _ -> read_char_opt ic)
let read_lines ic = Lwt_stream.from (fun _ -> read_line_opt ic)
let write_char oc x = direct_access oc.channel (fun da -> Primitives.write_char da oc.strict (encoder oc.coder) x)
let write_line oc x = direct_access oc.channel (fun da -> Primitives.write_line da oc.strict (encoder oc.coder) x)
let write oc x = direct_access oc.channel (fun da -> Primitives.write da oc.strict (encoder oc.coder) x)
let write_chars oc st = Lwt_stream.iter_s (write_char oc) st
let write_lines oc st = Lwt_stream.iter_s (write_line oc) st
let stdin = make Lwt_io.stdin
let stdout = make Lwt_io.stdout
let stderr = make Lwt_io.stderr
let null = make Lwt_io.null
let zero = make Lwt_io.zero
let fprint oc txt = write oc txt
let fprintl oc txt = write_line oc txt
let fprintf oc fmt = Printf.ksprintf (fun txt -> write oc txt) fmt
let fprintlf oc fmt = Printf.ksprintf (fun txt -> write_line oc txt) fmt
let print txt = write stdout txt
let printl txt = write_line stdout txt
let printf fmt = Printf.ksprintf print fmt
let printlf fmt = Printf.ksprintf printl fmt
let eprint txt = write stderr txt
let eprintl txt = write_line stderr txt
let eprintf fmt = Printf.ksprintf eprint fmt
let eprintlf fmt = Printf.ksprintf eprintl fmt
let ignore_close ch =
ignore (close ch)
let make_stream f lazy_ic =
let lazy_ic =
lazy(lwt ic = Lazy.force lazy_ic in
Gc.finalise ignore_close ic;
return ic)
in
Lwt_stream.from (fun _ ->
lwt ic = Lazy.force lazy_ic in
try_lwt
f ic >|= fun x -> Some x
with
| End_of_file ->
lwt () = close ic in
return None)
let lines_of_file filename =
make_stream read_line (lazy(open_file ~mode:input filename))
let lines_to_file filename lines =
with_file ~mode:output filename (fun oc -> write_lines oc lines)
let chars_of_file filename =
make_stream read_char (lazy(open_file ~mode:input filename))
let chars_to_file filename chars =
with_file ~mode:output filename (fun oc -> write_chars oc chars)
let hexdump_stream oc stream = write_lines oc (Lwt_stream.hexdump stream)
let hexdump oc buf = hexdump_stream oc (Lwt_stream.of_string buf)

128
server/thirdparty/lwt-2.3.2/src/text/lwt_text.mli vendored
View File

@ -1,128 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_text
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Text channels *)
(** This modules implements {b text channel}s. A {b text channel} is
basically a {b byte channel} (as in {!Lwt_io}) plus a {b character
encoding}.
It has almost the same interface as {!Lwt_io} except that it
uses [Text.t] in place of [string] and [char]
*)
open Lwt_io
(** {6 Types} *)
type 'mode channel
(** Type of a text channel *)
type input_channel = input channel
(** Type of a text input channel *)
type output_channel = output channel
(** Type of a text output channel *)
(** {6 Creation/manipulation} *)
val make : ?strict : bool -> ?encoding : Encoding.t -> 'a Lwt_io.channel -> 'a channel
(** [make ?strict ?encoding ch] creates a text channel from a byte
channel.
@param strict tell whether encoding/decoding must be ``strict'',
which whether the encoder/decoder should fail on invalid
sequence. In non-strict mode, it transparently fallback to
ISO-8859-15. By the way it is ensured that [read*] functions
always returns valid UTF-8 encoded text. [strict] defaults to
[false].
@param encoding is the character encoding used for the
channel. It defaults to [Encoding.system]. *)
val byte_channel : 'a channel -> 'a Lwt_io.channel
(** [byte_channel ch] returns the underlying byte channel of a text
channel *)
val encoding : 'a channel -> Encoding.t
(** [encoding ch] returns the character encoding of a channel. *)
val flush : output_channel -> unit Lwt.t
(** Flush the underlying byte channel *)
val close : 'a channel -> unit Lwt.t
(** Close the underlying byte channel *)
(** {6 Lwt_io like values} *)
val atomic : ('a channel -> 'b Lwt.t) -> ('a channel -> 'b Lwt.t)
val stdin : input_channel
val stdout : output_channel
val stderr : output_channel
val zero : input_channel
val null : output_channel
val read_char : input_channel -> Text.t Lwt.t
val read_char_opt : input_channel -> Text.t option Lwt.t
val read_chars : input_channel -> Text.t Lwt_stream.t
val read_line : input_channel -> Text.t Lwt.t
val read_line_opt : input_channel -> Text.t option Lwt.t
val read_lines : input_channel -> Text.t Lwt_stream.t
val read : ?count : int -> input_channel -> Text.t Lwt.t
val write_char : output_channel -> Text.t -> unit Lwt.t
val write_chars : output_channel -> Text.t Lwt_stream.t -> unit Lwt.t
val write : output_channel -> Text.t -> unit Lwt.t
val write_line : output_channel -> Text.t -> unit Lwt.t
val write_lines : output_channel -> Text.t Lwt_stream.t -> unit Lwt.t
val open_file :
?buffer_size : int ->
?strict : bool ->
?encoding : Encoding.t ->
?flags : Unix.open_flag list ->
?perm : Unix.file_perm ->
mode : 'a mode ->
file_name -> 'a channel Lwt.t
val with_file :
?buffer_size : int ->
?strict : bool ->
?encoding : Encoding.t ->
?flags : Unix.open_flag list ->
?perm : Unix.file_perm ->
mode : 'a mode ->
file_name -> ('a channel -> 'b Lwt.t) -> 'b Lwt.t
val lines_of_file : file_name -> Text.t Lwt_stream.t
val lines_to_file : file_name -> Text.t Lwt_stream.t -> unit Lwt.t
val chars_of_file : file_name -> Text.t Lwt_stream.t
val chars_to_file : file_name -> Text.t Lwt_stream.t -> unit Lwt.t
val fprint : output_channel -> Text.t -> unit Lwt.t
val fprintl : output_channel -> Text.t -> unit Lwt.t
val fprintf : output_channel -> ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
val fprintlf : output_channel -> ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
val print : Text.t -> unit Lwt.t
val printl : Text.t -> unit Lwt.t
val printf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
val printlf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
val eprint : Text.t -> unit Lwt.t
val eprintl : Text.t -> unit Lwt.t
val eprintf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
val eprintlf : ('a, unit, Text.t, unit Lwt.t) format4 -> 'a
val hexdump_stream : output_channel -> char Lwt_stream.t -> unit Lwt.t
val hexdump : output_channel -> string -> unit Lwt.t

84
server/thirdparty/lwt-2.3.2/src/text/lwt_text_stubs.c vendored
View File

@ -1,84 +0,0 @@
/* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_text_stubs
* Copyright (C) 2011 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*/
#if defined(_WIN32) || defined(_WIN64)
# include <windows.h>
# include <wincon.h>
#else
# include <sys/ioctl.h>
# include <termios.h>
# include <errno.h>
# include <signal.h>
#endif
#include "../unix/lwt_unix.h"
#include <caml/alloc.h>
#include <caml/fail.h>
/* +-----------------------------------------------------------------+
| Terminal sizes |
+-----------------------------------------------------------------+ */
#if defined(LWT_ON_WINDOWS)
CAMLprim value lwt_text_term_size(value fd)
{
HANDLE handle;
CONSOLE_SCREEN_BUFFER_INFO info;
if (!GetConsoleScreenBufferInfo(Handle_val(fd), &info)) {
win32_maperr(GetLastError());
uerror("GetConsoleScreenBufferInfo", Nothing);
}
value result = caml_alloc_tuple(2);
Field(result, 0) = Val_int(info.dwSize.X);
Field(result, 1) = Val_int(info.dwSize.Y);
return result;
}
#else
CAMLprim value lwt_text_term_size(value fd)
{
struct winsize size;
if (ioctl(Int_val(fd), TIOCGWINSZ, &size) < 0)
uerror("ioctl", Nothing);
value result = caml_alloc_tuple(2);
Field(result, 0) = Val_int(size.ws_row);
Field(result, 1) = Val_int(size.ws_col);
return result;
}
CAMLprim value lwt_text_sigwinch()
{
#ifdef SIGWINCH
return Val_int(SIGWINCH);
#else
return Val_int(0);
#endif
}
#endif

5
server/thirdparty/lwt-2.3.2/src/top/lwt-top.mllib vendored
View File

@ -1,5 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 6aba40695d6f4091d2063c4b620ae589)
Lwt_top
Lwt_ocaml_completion
# OASIS_STOP

194
server/thirdparty/lwt-2.3.2/src/top/lwt_ocaml_completion.mll vendored
View File

@ -1,194 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_ocaml_completion
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
{
open Toploop
open Lwt
open Lwt_read_line
module TextSet = Set.Make(Text)
let set_of_list = List.fold_left (fun set x -> TextSet.add x set) TextSet.empty
let keywords = set_of_list [
"and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
"done"; "downto"; "else"; "end"; "exception"; "external"; "false";
"for"; "fun"; "function"; "functor"; "if"; "in"; "include";
"inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module";
"mutable"; "new"; "object"; "of"; "open"; "private"; "rec"; "sig";
"struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual";
"when"; "while"; "with"; "try_lwt"; "finally"; "for_lwt"; "lwt";
]
let get_directives () =
Hashtbl.fold (fun k v set -> TextSet.add k set) Toploop.directive_table TextSet.empty
let complete_ident = ref (fun before ident after -> complete ~suffix:"" before ident after keywords)
let restart = ref (fun () -> ())
let list_files filter fname =
let dir = Filename.dirname fname in
Array.fold_left (fun set name ->
let absolute_name = Filename.concat dir name in
if try Sys.is_directory absolute_name with _ -> false then
TextSet.add (Filename.concat name "") set
else if filter name then
TextSet.add name set
else
set)
TextSet.empty
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir))
let list_directories fname =
let dir = Filename.dirname fname in
Array.fold_left (fun set name ->
let name = Filename.concat dir name in
if try Sys.is_directory name with _ -> false then
TextSet.add name set
else
set)
TextSet.empty
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir))
}
let lower = ['a'-'z']
let upper = ['A'-'Z']
let alpha = lower | upper
let digit = ['0'-'9']
let alnum = alpha | digit
let punct = ['!' '"' '#' '$' '%' '&' '\'' '(' ')' '*' '+' ',' '-' '.' '/' ':' ';' '<' '=' '>' '?' '@' '[' '\\' ']' '^' '_' '`' '{' '|' '}' '~']
let graph = alnum | punct
let print = graph | ' '
let blank = ' ' | '\t'
let cntrl = ['\x00'-'\x1F' '\x7F']
let xdigit = digit | ['a'-'f' 'A'-'F']
let space = blank | ['\n' '\x0b' '\x0c' '\r']
let uchar = ['\x00' - '\x7f'] | _ [ '\x80' - '\xbf' ]*
let identstart = [ 'A'-'Z' 'a'-'z' '_' ]
let identbody = [ 'A'-'Z' 'a'-'z' '_' '\'' '0' - '9' ]
let ident = identstart identbody*
let maybe_ident = "" | ident
(* Parse a line of input. [before] correspond to the input before the
cursor and [after] to the input after the cursor. The lexing buffer
is created from [before]. *)
rule complete_input before after = parse
(* Completion over directives *)
| (blank* '#' blank* as before') (maybe_ident as dir) (blank* as bl) eof {
if Hashtbl.mem Toploop.directive_table dir then
return (match Hashtbl.find Toploop.directive_table dir with
| Directive_none _ ->
{ comp_state = (before ^ ";;", after);
comp_words = TextSet.empty }
| Directive_string _ ->
{ comp_state = (before ^ (if bl = "" then " \"" else "\""), after);
comp_words = TextSet.empty }
| Directive_bool _ ->
{ comp_state = ((if bl = "" then before ^ " " else ""), after);
comp_words = set_of_list ["false"; "true"] }
| Directive_int _ | Directive_ident _ ->
{ comp_state = ((if bl = "" then before ^ " " else ""), after);
comp_words = TextSet.empty })
else
return (match lookup dir (get_directives ()) with
| (_, words) when TextSet.is_empty words ->
{ comp_state = (before, after);
comp_words = TextSet.empty }
| (prefix, words) ->
if bl = "" then
{ comp_state = (before' ^ prefix, after);
comp_words = words }
else
{ comp_state = (before, after);
comp_words = TextSet.empty })
}
(* Completion on directive argument *)
| (blank* '#' blank* (ident as dir) blank* as before') (ident as arg) eof {
return (match try Some(Hashtbl.find directive_table dir) with Not_found -> None with
| Some (Directive_bool _) ->
complete ~suffix:";;" before' arg after (set_of_list ["false"; "true"])
| _ ->
{ comp_state = (before, after);
comp_words = TextSet.empty })
}
(* Completion on packages *)
| (blank* '#' blank* "require" blank* '"' as before) ([^'"']* as package) eof {
return (complete ~suffix:"\";;" before package after (set_of_list (Fl_package_base.list_packages ())))
}
(* Completion on files *)
| (blank* '#' blank* "load" blank* '"' as before) ([^'"']* as fname) eof {
let list = list_files (fun name ->
Filename.check_suffix name ".cma" || Filename.check_suffix name ".cmo") fname in
return (complete ~suffix:"" before fname after list)
}
| (blank* '#' blank* "use" blank* '"' as before) ([^'"']* as fname) eof {
let list = list_files (fun _ -> true) fname in
return (complete ~suffix:"" before fname after list)
}
(* Completion on directories *)
| (blank* '#' blank* "directory" blank* '"' as before) ([^'"']* as fname) eof {
let list = list_directories fname in
return (complete ~suffix:"" before fname after list)
}
(* Completion on packages *)
| blank* '#' blank* ident blank* '"' [^'"']* '"' blank* eof {
return { comp_state = (before ^ ";;", after);
comp_words = TextSet.empty }
}
(* A line that do not need to be completed: *)
| blank* '#' blank* ident blank* '"' [^'"']* '"' blank* ";;" eof {
return { comp_state = (before, after);
comp_words = TextSet.empty }
}
| "" {
complete_end (Buffer.create (String.length before)) after lexbuf
}
and complete_end before after = parse
(* Completion on keywords *)
| ((ident '.')* maybe_ident as id) eof {
let before = Buffer.contents before in
return (!complete_ident before id after)
}
| uchar as ch {
Buffer.add_string before ch;
complete_end before after lexbuf
}
| "" {
return { comp_state = (Buffer.contents before, after);
comp_words = TextSet.empty }
}

141
server/thirdparty/lwt-2.3.2/src/top/lwt_top.ml vendored
View File

@ -1,141 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_top
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(* Integration with the toplevel:
readline + let threads runs while reading user input. *)
open Lwt_unix
open Lwt
open Lwt_text
open Lwt_term
(* +-----------------------------------------------------------------+
| Completion |
+-----------------------------------------------------------------+ *)
module TextSet = Set.Make(Text)
let complete (before, after) =
Lwt_ocaml_completion.complete_input before after (Lexing.from_string before)
(* +-----------------------------------------------------------------+
| Read-line wrapper |
+-----------------------------------------------------------------+ *)
let mode = ref `real_time
let completion_mode () = !mode
let set_completion_mode m = mode := m
let history = ref []
let _ =
let hist_name = Filename.concat (try Unix.getenv "HOME" with _ -> "") ".lwt-top-history" in
Lwt_main.at_exit (fun () -> Lwt_read_line.save_history hist_name !history);
history := Lwt_main.run (Lwt_read_line.load_history hist_name)
let input = ref ""
let pos = ref 0
let rec read_input prompt buffer len =
try
if !pos = String.length !input then begin
let prompt' = if prompt = " " then [fg blue; text "> "] else [fg yellow; text prompt] in
!Lwt_ocaml_completion.restart ();
let txt = Lwt_main.run begin
lwt l = Lwt_read_line.Control.result
(Lwt_read_line.Control.make
~complete
~mode:!mode
~history:(!history)
~prompt:(fun _ -> React.S.const prompt')
~filter:(fun state command ->
match command with
| Lwt_read_line.Command.Accept_line ->
(* Do not accept the line if it does not terminates with ";;" *)
let text = Lwt_read_line.Engine.all_input (Lwt_read_line.Control.engine_state state) in
if Text.ends_with (Text.rstrip text) ";;" then
return Lwt_read_line.Command.Accept_line
else
return (Lwt_read_line.Command.Char "\n")
| command ->
return command)
~map_result:return
())
in
lwt () = Lwt_text.flush Lwt_text.stdout in
return l
end in
history := Lwt_read_line.add_entry txt !history;
input := txt ^ "\n";
pos := 0;
read_input prompt buffer len
end else begin
let i = ref 0 in
while !i < len && !pos < String.length !input do
buffer.[!i] <- (!input).[!pos];
incr i;
incr pos
done;
(!i, false)
end
with
| Lwt_read_line.Interrupt ->
(0, true)
let read_input_non_interactive prompt buffer len =
let rec loop i =
if i = len then
return (i, false)
else
Lwt_io.read_char_opt Lwt_io.stdin >>= function
| Some c ->
buffer.[i] <- c;
if c = '\n' then
return (i + 1, false)
else
loop (i + 1)
| None ->
return (i, true)
in
Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >> loop 0)
let _ =
(* If input is a tty, use interactive read-line and display and
welcome message: *)
if Unix.isatty Unix.stdin then begin
Toploop.read_interactive_input := read_input;
let txt = "Welcome to the Lwt powered OCaml toplevel!" in
let col_border = cyan and col_txt = yellow in
let len = Text.length txt in
let col = React.S.value Lwt_term.columns in
let space = (col - 4 - len) / 2 in
let rep n txt = text (Text.repeat n txt) in
Lwt_main.run
(lwt () = printlc [fg col_border; rep space "─"; text "┬─"; rep len "─"; text "─┬"; rep (col - 4 - len - space) "─"] in
lwt () = printlc [rep space " "; fg col_border; text "│ "; fg col_txt; text txt; fg col_border; text " │"] in
lwt () = printlc [rep space " "; fg col_border; text "└─"; rep len "─"; text "─┘"] in
Lwt_io.flush Lwt_io.stdout)
end else
(* Otherwise fallback to classic non-interactive mode: *)
Toploop.read_interactive_input := read_input_non_interactive;

29
server/thirdparty/lwt-2.3.2/src/top/lwt_top.mli vendored
View File

@ -1,29 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_top
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Toplevel configuration *)
val completion_mode : unit -> [ `classic | `real_time | `none ]
(** Return the current completion mode. *)
val set_completion_mode : [ `classic | `real_time | `none ] -> unit
(** Change the completion mode *)

131
server/thirdparty/lwt-2.3.2/src/top/toplevel.ml vendored
View File

@ -1,131 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Toplevel
* Copyright (C) 2009 Jérémie Dimino
* Pierre Chambart
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
open Types
open Lwt_read_line
module TextSet = Set.Make(Text)
type path =
| Path of Path.t
| Longident of Longident.t
module PathMap = Map.Make(struct type t = path let compare = compare end)
let keywords = Lwt_ocaml_completion.keywords
let global_env = ref(lazy(raise Exit))
let local_envs = ref(PathMap.empty)
(* Returns [acc] plus all modules of [dir] *)
let add_modules_from_directory acc dir =
let dir = if dir = "" then "./" else dir in
let acc = ref acc in
Array.iter (fun fname ->
if Filename.check_suffix fname ".cmi" then
acc := TextSet.add (Text.capitalize (Filename.chop_suffix fname ".cmi")) !acc)
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir));
!acc
(* List all names of the module with path [path] *)
let get_names_of_module path =
try
match
match path with
| Path path ->
Env.find_module path !Toploop.toplevel_env
| Longident ident ->
snd (Env.lookup_module ident !Toploop.toplevel_env)
with
| Tmty_signature decls ->
List.fold_left
(fun acc decl -> match decl with
| Tsig_value(id, _)
| Tsig_type(id, _, _)
| Tsig_exception(id, _)
| Tsig_module(id, _, _)
| Tsig_modtype(id, _)
| Tsig_class(id, _, _)
| Tsig_cltype(id, _, _) ->
TextSet.add (Ident.name id) acc)
TextSet.empty decls
| _ ->
TextSet.empty
with Not_found ->
TextSet.empty
let names_of_module path =
try
PathMap.find path !local_envs
with Not_found ->
let names = get_names_of_module path in
local_envs := PathMap.add path names !local_envs;
names
(* List all names accessible without a path *)
let env_names () =
let rec loop acc = function
| Env.Env_empty -> acc
| Env.Env_value(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary
| Env.Env_type(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary
| Env.Env_exception(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary
| Env.Env_module(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary
| Env.Env_modtype(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary
| Env.Env_class(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary
| Env.Env_cltype(summary, id, _) -> loop (TextSet.add (Ident.name id) acc) summary
| Env.Env_open(summary, path) -> loop (TextSet.union acc (names_of_module (Path path))) summary
in
(* Add names of the environment: *)
let acc = loop TextSet.empty (Env.summary !Toploop.toplevel_env) in
(* Add accessible modules: *)
List.fold_left add_modules_from_directory acc !Config.load_path
let path_of_string text =
match Text.split ~sep:"." text with
| [] ->
invalid_arg "Toplevel.make_path"
| ident :: rest ->
let rec loop path = function
| [] -> Longident path
| component :: rest -> loop (Longident.Ldot(path, component)) rest
in
loop (Longident.Lident ident) rest
let complete_ident before ident after =
match Text.rev_split ~sep:"." ~max:2 ident with
| [ident]->
complete ~suffix:"" before ident after (TextSet.union keywords (Lazy.force !global_env))
| [path; ident] ->
let before = before ^ path ^ "." in
complete ~suffix:"" before ident after (names_of_module (path_of_string path))
| _ ->
assert false
let restart () =
global_env := lazy(env_names ());
local_envs := PathMap.empty
let () =
Topfind.don't_load_deeply ["lwt"; "lwt.react"; "lwt.unix"; "lwt.text"; "lwt.top"];
Lwt_ocaml_completion.complete_ident := complete_ident;
Lwt_ocaml_completion.restart := restart

3
server/thirdparty/lwt-2.3.2/src/top/toplevel_temp.mltop vendored
View File

@ -1,3 +0,0 @@
# This file is used to generate "toplevel_temp.top", which is then
# expunged into "lwt-toplevel"
Toplevel

5
server/thirdparty/lwt-2.3.2/src/unix/liblwt-unix.clib vendored
View File

@ -1,5 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 0d2c17c0648a3a3dd282ce99960c7277)
lwt_unix_stubs.o
lwt_libev_stubs.o
# OASIS_STOP

17
server/thirdparty/lwt-2.3.2/src/unix/lwt-unix.mllib vendored
View File

@ -1,17 +0,0 @@
# OASIS_START
# DO NOT EDIT (digest: 2e742a984520810653596dcf9f7563fa)
Lwt_chan
Lwt_daemon
Lwt_gc
Lwt_io
Lwt_log
Lwt_main
Lwt_process
Lwt_throttle
Lwt_timeout
Lwt_unix
Lwt_sys
Lwt_engine
Lwt_bytes
Lwt_log_rules
# OASIS_STOP

344
server/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.ml vendored
View File

@ -1,344 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_unix
* Copyright (C) 2010 Jérémie Dimino
* 2010 Pierre Chambart
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
#include "src/unix/lwt_config.ml"
open Bigarray
open Lwt
type t = (char, int8_unsigned_elt, c_layout) Array1.t
let create size = Array1.create char c_layout size
let length bytes = Array1.dim bytes
external get : t -> int -> char = "%caml_ba_ref_1"
external set : t -> int -> char -> unit = "%caml_ba_set_1"
external unsafe_get : t -> int -> char = "%caml_ba_unsafe_ref_1"
external unsafe_set : t -> int -> char -> unit = "%caml_ba_unsafe_set_1"
external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc"
let fill bytes ofs len ch =
if ofs < 0 || len < 0 || ofs > length bytes - len then
invalid_arg "Lwt_bytes.fill"
else
unsafe_fill bytes ofs len ch
(* +-----------------------------------------------------------------+
| Blitting |
+-----------------------------------------------------------------+ *)
external unsafe_blit_string_bytes : string -> int -> t -> int -> int -> unit = "lwt_unix_blit_string_bytes" "noalloc"
external unsafe_blit_bytes_string : t -> int -> string -> int -> int -> unit = "lwt_unix_blit_bytes_string" "noalloc"
external unsafe_blit : t -> int -> t -> int -> int -> unit = "lwt_unix_blit_bytes_bytes" "noalloc"
let blit_string_bytes src_buf src_ofs dst_buf dst_ofs len =
if (len < 0
|| src_ofs < 0 || src_ofs > String.length src_buf - len
|| dst_ofs < 0 || dst_ofs > length dst_buf - len) then
invalid_arg "String.blit"
else
unsafe_blit_string_bytes src_buf src_ofs dst_buf dst_ofs len
let blit_bytes_string src_buf src_ofs dst_buf dst_ofs len =
if (len < 0
|| src_ofs < 0 || src_ofs > length src_buf - len
|| dst_ofs < 0 || dst_ofs > String.length dst_buf - len) then
invalid_arg "String.blit"
else
unsafe_blit_bytes_string src_buf src_ofs dst_buf dst_ofs len
let blit src_buf src_ofs dst_buf dst_ofs len =
if (len < 0
|| src_ofs < 0 || src_ofs > length src_buf - len
|| dst_ofs < 0 || dst_ofs > length dst_buf - len) then
invalid_arg "String.blit"
else
unsafe_blit src_buf src_ofs dst_buf dst_ofs len
let of_string str =
let len = String.length str in
let bytes = create len in
unsafe_blit_string_bytes str 0 bytes 0 len;
bytes
let to_string bytes =
let len = length bytes in
let str = String.create len in
unsafe_blit_bytes_string bytes 0 str 0 len;
str
let proxy = Array1.sub
let extract buf ofs len =
if ofs < 0 || len < 0 || ofs > length buf - len then
invalid_arg "Lwt_bytes.extract"
else begin
let buf' = create len in
blit buf ofs buf' 0 len;
buf'
end
let copy buf =
let len = length buf in
let buf' = create len in
blit buf 0 buf' 0 len;
buf'
(* +-----------------------------------------------------------------+
| IOs |
+-----------------------------------------------------------------+ *)
open Lwt_unix
external stub_read : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_read"
external read_job : Unix.file_descr -> t -> int -> int -> [ `unix_bytes_read ] job = "lwt_unix_bytes_read_job"
external read_result : [ `unix_bytes_read ] job -> int = "lwt_unix_bytes_read_result"
external read_free : [ `unix_bytes_read ] job -> unit = "lwt_unix_bytes_read_free" "noalloc"
let read fd buf pos len =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "Lwt_bytes.read"
else
blocking fd >>= function
| true ->
lwt () = wait_read fd in
execute_job (read_job (unix_file_descr fd) buf pos len) read_result read_free
| false ->
wrap_syscall Read fd (fun () -> stub_read (unix_file_descr fd) buf pos len)
external stub_write : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_write"
external write_job : Unix.file_descr -> t -> int -> int -> [ `unix_bytes_write ] job = "lwt_unix_bytes_write_job"
external write_result : [ `unix_bytes_write ] job -> int = "lwt_unix_bytes_write_result"
external write_free : [ `unix_bytes_write ] job -> unit = "lwt_unix_bytes_write_free" "noalloc"
let write fd buf pos len =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "Lwt_bytes.write"
else
blocking fd >>= function
| true ->
lwt () = wait_write fd in
execute_job (write_job (unix_file_descr fd) buf pos len) write_result write_free
| false ->
wrap_syscall Write fd (fun () -> stub_write (unix_file_descr fd) buf pos len)
#if windows
let recv fd buf pos len flags =
raise (Lwt_sys.Not_available "Lwt_bytes.recv")
#else
external stub_recv : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_recv"
let recv fd buf pos len flags =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "recv"
else
wrap_syscall Read fd (fun () -> stub_recv (unix_file_descr fd) buf pos len flags)
#endif
#if windows
let send fd buf pos len flags =
raise (Lwt_sys.Not_available "Lwt_bytes.send")
#else
external stub_send : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_send"
let send fd buf pos len flags =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "send"
else
wrap_syscall Write fd (fun () -> stub_send (unix_file_descr fd) buf pos len flags)
#endif
type io_vector = {
iov_buffer : t;
iov_offset : int;
iov_length : int;
}
let io_vector ~buffer ~offset ~length = {
iov_buffer = buffer;
iov_offset = offset;
iov_length = length;
}
let check_io_vectors func_name iovs =
List.iter
(fun iov ->
if iov.iov_offset < 0
|| iov.iov_length < 0
|| iov.iov_offset > length iov.iov_buffer - iov.iov_length then
invalid_arg func_name)
iovs
#if windows
let recv_msg ~socket ~io_vectors =
raise (Lwt_sys.Not_available "recv_msg")
#else
external stub_recv_msg : Unix.file_descr -> int -> io_vector list -> int * Unix.file_descr list = "lwt_unix_bytes_recv_msg"
let recv_msg ~socket ~io_vectors =
check_io_vectors "recv_msg" io_vectors;
let n_iovs = List.length io_vectors in
wrap_syscall Read socket
(fun () ->
stub_recv_msg (unix_file_descr socket) n_iovs io_vectors)
#endif
#if windows
let send_msg ~socket ~io_vectors ~fds =
raise (Lwt_sys.Not_available "send_msg")
#else
external stub_send_msg : Unix.file_descr -> int -> io_vector list -> int -> Unix.file_descr list -> int = "lwt_unix_bytes_send_msg"
let send_msg ~socket ~io_vectors ~fds =
check_io_vectors "send_msg" io_vectors;
let n_iovs = List.length io_vectors and n_fds = List.length fds in
wrap_syscall Write socket
(fun () ->
stub_send_msg (unix_file_descr socket) n_iovs io_vectors n_fds fds)
#endif
#if windows
let recvfrom fd buf pos len flags =
raise (Lwt_sys.Not_available "Lwt_bytes.recvfrom")
#else
external stub_recvfrom : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr = "lwt_unix_bytes_recvfrom"
let recvfrom fd buf pos len flags =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "Lwt_bytes.recvfrom"
else
wrap_syscall Read fd (fun () -> stub_recvfrom (unix_file_descr fd) buf pos len flags)
#endif
#if windows
let sendto fd buf pos len flags addr =
raise (Lwt_sys.Not_available "Lwt_bytes.sendto")
#else
external stub_sendto : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int = "lwt_unix_bytes_sendto_byte" "lwt_unix_bytes_sendto"
let sendto fd buf pos len flags addr =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "Lwt_bytes.sendto"
else
wrap_syscall Write fd (fun () -> stub_sendto (unix_file_descr fd) buf pos len flags addr)
#endif
(* +-----------------------------------------------------------------+
| Memory mapped files |
+-----------------------------------------------------------------+ *)
let map_file ~fd ?pos ~shared ?(size=(-1)) () =
Array1.map_file fd ?pos char c_layout shared size
external mapped : t -> bool = "lwt_unix_mapped" "noalloc"
type advice =
| MADV_NORMAL
| MADV_RANDOM
| MADV_SEQUENTIAL
| MADV_WILLNEED
| MADV_DONTNEED
#if windows
let madvise buf pos len advice =
raise (Lwt_sys.Not_available "madvise")
#else
external stub_madvise : t -> int -> int -> advice -> unit = "lwt_unix_madvise"
let madvise buf pos len advice =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "Lwt_bytes.madvise"
else
stub_madvise buf pos len advice
#endif
external get_page_size : unit -> int = "lwt_unix_get_page_size"
let page_size = get_page_size ()
#if windows
let mincore buffer offset states =
raise (Lwt_sys.Not_available "mincore")
let wait_mincore buffer offset =
raise (Lwt_sys.Not_available "mincore")
#else
external stub_mincore : t -> int -> int -> bool array -> unit = "lwt_unix_mincore"
let mincore buffer offset states =
if (offset mod page_size <> 0
|| offset < 0
|| offset > length buffer - (Array.length states * page_size)) then
invalid_arg "Lwt_bytes.mincore"
else
stub_mincore buffer offset (Array.length states * page_size) states
external wait_mincore_job : t -> int -> [ `unix_wait_mincore ] job = "lwt_unix_wait_mincore_job"
external wait_mincore_free : [ `unix_wait_mincore ] job -> unit = "lwt_unix_wait_mincore_free" "noalloc"
let wait_mincore buffer offset =
if offset < 0 || offset >= length buffer then
invalid_arg "Lwt_bytes.wait_mincore"
else begin
let state = [|false|] in
mincore buffer (offset - (offset mod page_size)) state;
if state.(0) then
return ()
else
execute_job (wait_mincore_job buffer offset) ignore wait_mincore_free
end
#endif

176
server/thirdparty/lwt-2.3.2/src/unix/lwt_bytes.mli vendored
View File

@ -1,176 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_unix
* Copyright (C) 2010 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Byte arrays *)
type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
(** Type of array of bytes. *)
val create : int -> t
(** Creates a new byte array of the given size. *)
val length : t -> int
(** Returns the length of the given byte array. *)
(** {6 Access} *)
external get : t -> int -> char = "%caml_ba_ref_1"
(** [get buffer offset] returns the byte at offset [offset] in
[buffer]. *)
external set : t -> int -> char -> unit = "%caml_ba_set_1"
(** [get buffer offset value] changes the value of the byte at
offset [offset] in [buffer] to [value]. *)
external unsafe_get : t -> int -> char = "%caml_ba_unsafe_ref_1"
(** Same as {!get} but without bound checking. *)
external unsafe_set : t -> int -> char -> unit = "%caml_ba_unsafe_set_1"
(** Same as {!set} but without bound checking. *)
(** {6 Conversions} *)
val of_string : string -> t
(** [of_string str] returns a newly allocated byte array with the
same contents as [str]. *)
val to_string : t -> string
(** [to_string buf] returns a newly allocated string with the same
contents as [buf]. *)
(** {6 Copying} *)
val blit : t -> int -> t -> int -> int -> unit
(** [blit buf1 ofs1 buf2 ofs2 len] copy [len] bytes from [buf1]
starting at offset [ofs1] to [buf2] starting at offset [ofs2]. *)
val blit_string_bytes : string -> int -> t -> int -> int -> unit
(** Same as blit but the first buffer is a string instead of a byte
array. *)
val blit_bytes_string : t -> int -> string -> int -> int -> unit
(** Same as blit but the second buffer is a string instead of a byte
array. *)
external unsafe_blit : t -> int -> t -> int -> int -> unit = "lwt_unix_blit_bytes_bytes" "noalloc"
(** Same as {!blit} but without bound checking. *)
external unsafe_blit_string_bytes : string -> int -> t -> int -> int -> unit = "lwt_unix_blit_string_bytes" "noalloc"
(** Same as {!blit_string_bytes} but without bound checking. *)
external unsafe_blit_bytes_string : t -> int -> string -> int -> int -> unit = "lwt_unix_blit_bytes_string" "noalloc"
(** Same as {!blit_bytes_string} but without bound checking. *)
val proxy : t -> int -> int -> t
(** [proxy buffer offset length] creates a ``proxy''. The returned
byte array share the data of [buffer] but with different
bounds. *)
val extract : t -> int -> int -> t
(** [extract buffer offset length] creates a new byte array of
length [length] and copy the [length] bytes of [buffer] at
[offset] into it. *)
val copy : t -> t
(** [copy buffer] creates a copy of the given byte array. *)
(** {6 Filling} *)
val fill : t -> int -> int -> char -> unit
(** [fill buffer offset length value] puts [value] in all [length]
bytes of [buffer] starting at offset [offset]. *)
external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc"
(** Same as {!fill} but without bound checking. *)
(** {6 IOs} *)
(** The following functions does the same as the functions in
{!Lwt_unix} except that they use byte arrays instead of
strings. *)
val read : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t
val write : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t
val recv : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t
val send : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t
val recvfrom : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> (int * Unix.sockaddr) Lwt.t
val sendto : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int Lwt.t
type io_vector = {
iov_buffer : t;
iov_offset : int;
iov_length : int;
}
val io_vector : buffer : t -> offset : int -> length : int -> io_vector
val recv_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> (int * Unix.file_descr list) Lwt.t
(** This call is not available on windows. *)
val send_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> fds : Unix.file_descr list -> int Lwt.t
(** This call is not available on windows. *)
(** {6 Memory mapped files} *)
val map_file : fd : Unix.file_descr -> ?pos : int64 -> shared : bool -> ?size : int -> unit -> t
(** [map_file ~fd ?pos ~shared ?size ()] maps the file descriptor
[fd] to an array of bytes. *)
external mapped : t -> bool = "lwt_unix_mapped" "noalloc"
(** [mapped buffer] returns [true] iff [buffer] is a memory mapped
file. *)
(** Type of advise that can be sent to the kernel by the program. See
the manual madvise(2) for a description of each advices. *)
type advice =
| MADV_NORMAL
| MADV_RANDOM
| MADV_SEQUENTIAL
| MADV_WILLNEED
| MADV_DONTNEED
val madvise : t -> int -> int -> advice -> unit
(** [madvise buffer pos len advice] advise the kernel about how the
program is going to use the part of the memory mapped file
between [pos] and [pos + len].
This call is not available on windows. *)
val page_size : int
(** Size of pages. *)
val mincore : t -> int -> bool array -> unit
(** [mincore buffer offset states] tests whether the given pages are
in the system memory (the RAM). The [offset] argument must be a
multiple of {!page_size}. [states] is used to store the result;
each cases is [true] if the corresponding page in the RAM and
[false] otherwise.
This call is not available on windows. *)
val wait_mincore : t -> int -> unit Lwt.t
(** [wait_mincore buffer offset] waits until the page containing the
byte at offset [offset] in the the RAM.
This functions is not available on windows. *)

86
server/thirdparty/lwt-2.3.2/src/unix/lwt_chan.ml vendored
View File

@ -1,86 +0,0 @@
(* Lightweight thread library for Objective Caml
* 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
open Lwt_io
type in_channel = Lwt_io.input_channel
type out_channel = Lwt_io.output_channel
let in_channel_of_descr fd = of_fd ~mode:Lwt_io.input fd
let make_in_channel ?close read =
make ~mode:Lwt_io.input ?close
(fun buf ofs len ->
let str = String.create len in
lwt n = read str 0 len in
if (n > 0) then Lwt_bytes.blit_string_bytes str 0 buf ofs len;
return n)
let input_line ic =
let rec loop buf =
read_char_opt ic >>= function
| None | Some '\n' ->
return (Buffer.contents buf)
| Some char ->
Buffer.add_char buf char;
loop buf
in
read_char_opt ic >>= function
| Some '\n' ->
return ""
| Some char ->
let buf = Buffer.create 128 in
Buffer.add_char buf char;
loop buf
| None ->
raise_lwt End_of_file
let input_value = read_value
let input = read_into
let really_input = read_into_exactly
let input_char = read_char
let input_binary_int = BE.read_int
let open_in_gen flags perm fname = open_file ~flags ~perm ~mode:Lwt_io.input fname
let open_in fname = open_file ~mode:Lwt_io.input fname
let close_in = close
let out_channel_of_descr fd = of_fd ~mode:Lwt_io.output fd
let make_out_channel ?close write =
make ~mode:Lwt_io.output ?close
(fun buf ofs len ->
let str = String.create len in
Lwt_bytes.blit_bytes_string buf ofs str 0 len;
write str 0 len)
let output = write_from_exactly
let flush = flush
let output_string = write
let output_value oc v = write_value oc v
let output_char = write_char
let output_binary_int = BE.write_int
let open_out_gen flags perm fname = open_file ~flags ~perm ~mode:Lwt_io.output fname
let open_out fname = open_file ~mode:Lwt_io.output fname
let close_out = close
let open_connection sockaddr = open_connection sockaddr

75
server/thirdparty/lwt-2.3.2/src/unix/lwt_chan.mli vendored
View File

@ -1,75 +0,0 @@
(* Lightweight thread library for Objective Caml
* 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. *)
(** {2 Cooperative input channels} *)
type in_channel = Lwt_io.input_channel
val in_channel_of_descr : Lwt_unix.file_descr -> in_channel
val make_in_channel : ?close:(unit -> unit Lwt.t) -> (string -> int -> int -> int Lwt.t) -> in_channel
(** [make_in_channel read] creates an input channel from the [read]
function. [read s ofs len] should (cooperatively) read [len] bytes from
the source, and put them in [s], at offset [ofs], and return the number
of bytes effectively read. If provided, [close] will be called by
[close_in]. By default, [close_in] does not do anything. *)
val input_line : in_channel -> string Lwt.t
val input_value : in_channel -> 'a Lwt.t
val input : in_channel -> string -> int -> int -> int Lwt.t
val really_input : in_channel -> string -> int -> int -> unit Lwt.t
val input_char : in_channel -> char Lwt.t
val input_binary_int : in_channel -> int Lwt.t
val open_in_gen : Unix.open_flag list -> int -> string -> in_channel Lwt.t
val open_in : string -> in_channel Lwt.t
val close_in : in_channel -> unit Lwt.t
(** {2 Cooperative output channels} *)
type out_channel = Lwt_io.output_channel
val out_channel_of_descr : Lwt_unix.file_descr -> out_channel
val make_out_channel : ?close:(unit -> unit Lwt.t) -> (string -> int -> int -> int Lwt.t) -> out_channel
(** [make_out_channel write] creates an output channel from the [write]
function. [write s ofs len] should (cooperatively) write [len] bytes from
[s], starting at offset [ofs], to the backend, and return the number of
bytes effectively written. If provided, [close] will be called by
[close_out]. By default, [close_out] does not do anything. *)
val output : out_channel -> string -> int -> int -> unit Lwt.t
val flush : out_channel -> unit Lwt.t
val output_string : out_channel -> string -> unit Lwt.t
val output_value : out_channel -> 'a -> unit Lwt.t
val output_char : out_channel -> char -> unit Lwt.t
val output_binary_int : out_channel -> int -> unit Lwt.t
val open_out_gen : Unix.open_flag list -> int -> string -> out_channel Lwt.t
val open_out : string -> out_channel Lwt.t
val close_out : out_channel -> unit Lwt.t
val open_connection : Unix.sockaddr -> (in_channel * out_channel) Lwt.t

89
server/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.ml vendored
View File

@ -1,89 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_io
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
open Lwt
let rec copy ic logger =
lwt line = Lwt_io.read_line ic in
lwt () = Lwt_log.log ?logger ~level:Lwt_log.Notice line in
copy ic logger
let redirect fd logger =
let fd_r, fd_w = Unix.pipe () in
Unix.set_close_on_exec fd_r;
Unix.dup2 fd_w fd;
Unix.close fd_w;
let ic = Lwt_io.of_unix_fd ~mode:Lwt_io.input fd in
ignore (copy ic logger)
let redirect_output dev_null fd mode = match mode with
| `Dev_null ->
Unix.dup2 dev_null fd
| `Close ->
Unix.close fd
| `Keep ->
()
| `Log_default ->
redirect fd None
| `Log logger ->
redirect fd (Some logger)
let daemonize ?(syslog=true) ?(stdin=`Dev_null) ?(stdout=`Log_default) ?(stderr=`Log_default) ?(directory="/") ?(umask=`Set 0o022) () =
if Unix.getppid () = 1 then
(* If our parent is [init], then we already are a demon *)
()
else begin
Unix.chdir directory;
(* Exit the parent, and continue in the child: *)
if Lwt_unix.fork () > 0 then begin
(* Do not run exit hooks in the parent. *)
Lwt_sequence.iter_node_l Lwt_sequence.remove Lwt_main.exit_hooks;
exit 0
end;
if syslog then Lwt_log.default := Lwt_log.syslog ~facility:`Daemon ();
(* Redirection of standard IOs *)
let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR] 0o666 in
begin match stdin with
| `Dev_null ->
Unix.dup2 dev_null Unix.stdin
| `Close ->
Unix.close Unix.stdin
| `Keep ->
()
end;
redirect_output dev_null Unix.stdout stdout;
redirect_output dev_null Unix.stderr stderr;
Unix.close dev_null;
begin match umask with
| `Keep ->
()
| `Set n ->
ignore (Unix.umask 0o022);
end;
ignore (Unix.setsid ())
end

81
server/thirdparty/lwt-2.3.2/src/unix/lwt_daemon.mli vendored
View File

@ -1,81 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_io
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Daemon helpers *)
val daemonize :
?syslog : bool ->
?stdin : [ `Dev_null | `Close | `Keep ] ->
?stdout : [ `Dev_null | `Close | `Keep | `Log_default | `Log of Lwt_log.logger ] ->
?stderr : [ `Dev_null | `Close | `Keep | `Log_default | `Log of Lwt_log.logger ] ->
?directory : string ->
?umask : [ `Keep | `Set of int ] ->
unit -> unit
(** Put the current running process into daemon mode. I.e. it forks
and exit the parent, detach it from its controlling terminal,
and redict standard intputs/outputs..
Notes:
- if the process is already a daemon, it does nothing.
- you must be sure that there is no pending threads when
calling this function, otherwise they may be canceled.
If [syslog] is [true] (the default), then {!Lwt_log.default} is
set to [Lwt_log.syslog ~facility:`Daemon ()], otherwise it is
kept unchanged.
[stdin] is one of:
- [`Dev_null] which means that [Unix.stdin] is reopened as
[/dev/null], this is the default behavior
- [`Close] means that [Unix.stdin] is simply closed
- [`Keep] means that [Unix.stdin] is left unchanged
[stdout] and [stderr] control how the two associated file
descriptors are redirected:
- [`Dev_null] means that the output is redirected to [/dev/null]
- [`Close] means that the file descriptor is closed
- [`Keep] means that it is left unchanged
- [`Log logger] means that the output is redirected to this
logger
- [`Log_default] means that the output is redirected to the
default logger
Both [stdout] and [stderr] defaults to [`Log_default].
Warning: do not redirect an output to a logger logging into this
outpout, for example this code will create an infinite loop:
{[
let logger = Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr () in
Lwt_daemon.daemonize ~syslog:false ~stderr:(`Log logger) ();
prerr_endline "foo"
]}
The current working directory is set to [directory], which
defaults to ["/"].
[umask] may be one of:
- [`Keep] which means that the umask is left unchanged
- [`Set n] which means that the umash is set to [n]
It defaults to [`Set 0o022].
*)

421
server/thirdparty/lwt-2.3.2/src/unix/lwt_engine.ml vendored
View File

@ -1,421 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_engine
* Copyright (C) 2011 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
#include "src/unix/lwt_config.ml"
(* +-----------------------------------------------------------------+
| Events |
+-----------------------------------------------------------------+ *)
type _event = {
stop : unit Lazy.t;
(* The stop method of the event. *)
node : Obj.t Lwt_sequence.node;
(* The node in the sequence of registered events. *)
}
type event = _event ref
external cast_node : 'a Lwt_sequence.node -> Obj.t Lwt_sequence.node = "%identity"
let stop_event ev =
let ev = !ev in
Lwt_sequence.remove ev.node;
Lazy.force ev.stop
let _fake_event = {
stop = lazy ();
node = Lwt_sequence.add_l (Obj.repr ()) (Lwt_sequence.create ());
}
let fake_event = ref _fake_event
(* +-----------------------------------------------------------------+
| Engines |
+-----------------------------------------------------------------+ *)
class virtual abstract = object(self)
method virtual iter : bool -> unit
method virtual private cleanup : unit
method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t
val readables = Lwt_sequence.create ()
(* Sequence of callbacks waiting for a file descriptor to become
readable. *)
val writables = Lwt_sequence.create ()
(* Sequence of callbacks waiting for a file descriptor to become
writable. *)
val timers = Lwt_sequence.create ()
(* Sequence of timers. *)
method destroy =
Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev) readables;
Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev) writables;
Lwt_sequence.iter_l (fun (delay, repeat, f, g, ev) -> stop_event ev) timers;
self#cleanup
method transfer (engine : abstract) =
Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev; ev := !(engine#on_readable fd f)) readables;
Lwt_sequence.iter_l (fun (fd, f, g, ev) -> stop_event ev; ev := !(engine#on_writable fd f)) writables;
Lwt_sequence.iter_l (fun (delay, repeat, f, g, ev) -> stop_event ev; ev := !(engine#on_timer delay repeat f)) timers
method fake_io fd =
Lwt_sequence.iter_l (fun (fd', f, g, stop) -> if fd = fd' then g ()) readables;
Lwt_sequence.iter_l (fun (fd', f, g, stop) -> if fd = fd' then g ()) writables
method on_readable fd f =
let ev = ref _fake_event in
let g () = f ev in
let stop = self#register_readable fd g in
ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) readables) };
ev
method on_writable fd f =
let ev = ref _fake_event in
let g () = f ev in
let stop = self#register_writable fd g in
ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) writables) } ;
ev
method on_timer delay repeat f =
let ev = ref _fake_event in
let g () = f ev in
let stop = self#register_timer delay repeat g in
ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (delay, repeat, f, g, ev) timers) };
ev
method readable_count = Lwt_sequence.length readables
method writable_count = Lwt_sequence.length writables
method timer_count = Lwt_sequence.length timers
end
class type t = object
inherit abstract
method iter : bool -> unit
method private cleanup : unit
method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t
end
(* +-----------------------------------------------------------------+
| The libev engine |
+-----------------------------------------------------------------+ *)
#if HAVE_LIBEV
type ev_loop
type ev_io
type ev_timer
external ev_init : unit -> ev_loop = "lwt_libev_init"
external ev_stop : ev_loop -> unit = "lwt_libev_stop"
external ev_loop : ev_loop -> bool -> unit = "lwt_libev_loop"
external ev_unloop : ev_loop -> unit = "lwt_libev_unloop"
external ev_readable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_readable_init"
external ev_writable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_writable_init"
external ev_io_stop : ev_loop -> ev_io -> unit = "lwt_libev_io_stop"
external ev_timer_init : ev_loop -> float -> bool -> (unit -> unit) -> ev_timer = "lwt_libev_timer_init"
external ev_timer_stop : ev_loop -> ev_timer -> unit = "lwt_libev_timer_stop"
class libev = object
inherit abstract
val loop = ev_init ()
method loop = loop
method private cleanup = ev_stop loop
method iter block =
try
ev_loop loop block
with exn ->
ev_unloop loop;
raise exn
method private register_readable fd f =
let ev = ev_readable_init loop fd f in
lazy(ev_io_stop loop ev)
method private register_writable fd f =
let ev = ev_writable_init loop fd f in
lazy(ev_io_stop loop ev)
method private register_timer delay repeat f =
let ev = ev_timer_init loop delay repeat f in
lazy(ev_timer_stop loop ev)
end
#else
type ev_loop
class libev = object(self)
inherit abstract
val loop : ev_loop = raise (Lwt_sys.Not_available "libev")
method loop : ev_loop = assert false
method iter = assert false
method private cleanup = assert false
method private register_readable = assert false
method private register_writable = assert false
method private register_timer = assert false
end
#endif
(* +-----------------------------------------------------------------+
| Select/poll based engines |
+-----------------------------------------------------------------+ *)
(* Type of a sleeper for the select engine. *)
type sleeper = {
mutable time : float;
(* The time at which the sleeper should be wakeup. *)
mutable stopped : bool;
(* [true] iff the event has been stopped. *)
action : unit -> unit;
(* The action for the sleeper. *)
}
module Sleep_queue =
Lwt_pqueue.Make(struct
type t = sleeper
let compare { time = t1 } { time = t2 } = compare t1 t2
end)
module Fd_map = Map.Make(struct type t = Unix.file_descr let compare = compare end)
let rec restart_actions sleep_queue now =
match Sleep_queue.lookup_min sleep_queue with
| Some{ stopped = true } ->
restart_actions (Sleep_queue.remove_min sleep_queue) now
| Some{ time = time; action = action } when time <= now ->
action ();
restart_actions (Sleep_queue.remove_min sleep_queue) now
| _ ->
sleep_queue
let rec get_next_timeout sleep_queue =
match Sleep_queue.lookup_min sleep_queue with
| Some{ stopped = true } ->
get_next_timeout (Sleep_queue.remove_min sleep_queue)
| Some{ time = time } ->
max 0. (time -. Unix.gettimeofday ())
| None ->
-1.
let bad_fd fd =
try
let _ = Unix.fstat fd in
false
with Unix.Unix_error (_, _, _) ->
true
let invoke_actions fd map =
match try Some(Fd_map.find fd map) with Not_found -> None with
| Some actions -> Lwt_sequence.iter_l (fun f -> f ()) actions
| None -> ()
class virtual select_or_poll_based = object(self)
inherit abstract
val mutable sleep_queue = Sleep_queue.empty
(* Threads waiting for a timeout to expire. *)
val mutable new_sleeps = []
(* Sleepers added since the last iteration of the main loop:
They are not added immediatly to the main sleep queue in order
to prevent them from being wakeup immediatly. *)
val mutable wait_readable = Fd_map.empty
(* Sequences of actions waiting for file descriptors to become
readable. *)
val mutable wait_writable = Fd_map.empty
(* Sequences of actions waiting for file descriptors to become
writable. *)
method private cleanup = ()
method private register_timer delay repeat f =
if repeat then begin
let rec sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = g }
and g () =
sleeper.time <- Unix.gettimeofday () +. delay;
new_sleeps <- sleeper :: new_sleeps;
f ()
in
new_sleeps <- sleeper :: new_sleeps;
lazy(sleeper.stopped <- true)
end else begin
let sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = f } in
new_sleeps <- sleeper :: new_sleeps;
lazy(sleeper.stopped <- true)
end
method private register_readable fd f =
let actions =
try
Fd_map.find fd wait_readable
with Not_found ->
let actions = Lwt_sequence.create () in
wait_readable <- Fd_map.add fd actions wait_readable;
actions
in
let node = Lwt_sequence.add_l f actions in
lazy(Lwt_sequence.remove node;
if Lwt_sequence.is_empty actions then wait_readable <- Fd_map.remove fd wait_readable)
method private register_writable fd f =
let actions =
try
Fd_map.find fd wait_writable
with Not_found ->
let actions = Lwt_sequence.create () in
wait_writable <- Fd_map.add fd actions wait_writable;
actions
in
let node = Lwt_sequence.add_l f actions in
lazy(Lwt_sequence.remove node;
if Lwt_sequence.is_empty actions then wait_writable <- Fd_map.remove fd wait_writable)
end
class virtual select_based = object(self)
inherit select_or_poll_based
method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list
method iter block =
(* Transfer all sleepers added since the last iteration to the
main sleep queue: *)
sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps;
new_sleeps <- [];
(* Collect file descriptors. *)
let fds_r = Fd_map.fold (fun fd _ l -> fd :: l) wait_readable [] in
let fds_w = Fd_map.fold (fun fd _ l -> fd :: l) wait_writable [] in
(* Compute the timeout. *)
let timeout = if block then get_next_timeout sleep_queue else 0. in
(* Do the blocking call *)
let fds_r, fds_w =
try
self#select fds_r fds_w timeout
with
| Unix.Unix_error (Unix.EINTR, _, _) ->
([], [])
| Unix.Unix_error (Unix.EBADF, _, _) ->
(* Keeps only bad file descriptors. Actions registered on
them have to handle the error: *)
(List.filter bad_fd fds_r,
List.filter bad_fd fds_w)
in
(* Restart threads waiting for a timeout: *)
sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ());
(* Restart threads waiting on a file descriptors: *)
List.iter (fun fd -> invoke_actions fd wait_readable) fds_r;
List.iter (fun fd -> invoke_actions fd wait_writable) fds_w
end
class virtual poll_based = object(self)
inherit select_or_poll_based
method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list
method iter block =
(* Transfer all sleepers added since the last iteration to the
main sleep queue: *)
sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps;
new_sleeps <- [];
(* Collect file descriptors. *)
let fds = [] in
let fds = Fd_map.fold (fun fd _ l -> (fd, true, false) :: l) wait_readable fds in
let fds = Fd_map.fold (fun fd _ l -> (fd, false, true) :: l) wait_writable fds in
(* Compute the timeout. *)
let timeout = if block then get_next_timeout sleep_queue else 0. in
(* Do the blocking call *)
let fds =
try
self#poll fds timeout
with
| Unix.Unix_error (Unix.EINTR, _, _) ->
[]
| Unix.Unix_error (Unix.EBADF, _, _) ->
(* Keeps only bad file descriptors. Actions registered on
them have to handle the error: *)
List.filter (fun (fd, _, _) -> bad_fd fd) fds
in
(* Restart threads waiting for a timeout: *)
sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ());
(* Restart threads waiting on a file descriptors: *)
List.iter
(fun (fd, readable, writable) ->
if readable then invoke_actions fd wait_readable;
if writable then invoke_actions fd wait_writable)
fds
end
class select = object
inherit select_based
method private select fds_r fds_w timeout =
let fds_r, fds_w, _ = Unix.select fds_r fds_w [] timeout in
(fds_r, fds_w)
end
(* +-----------------------------------------------------------------+
| The current engine |
+-----------------------------------------------------------------+ *)
#if HAVE_LIBEV && not windows
let current = ref (new libev :> t)
#else
let current = ref (new select :> t)
#endif
let get () =
!current
let set ?(transfer=true) ?(destroy=true) engine =
if transfer then !current#transfer (engine : #t :> abstract);
if destroy then !current#destroy;
current := (engine : #t :> t)
let iter block = !current#iter block
let on_readable fd f = !current#on_readable fd f
let on_writable fd f = !current#on_writable fd f
let on_timer delay repeat f = !current#on_timer delay repeat f
let fake_io fd = !current#fake_io fd
let readable_count () = !current#readable_count
let writable_count () = !current#writable_count
let timer_count () = !current#timer_count

194
server/thirdparty/lwt-2.3.2/src/unix/lwt_engine.mli vendored
View File

@ -1,194 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Interface Lwt_engine
* Copyright (C) 2011 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Lwt unix main loop engine *)
(** {6 Events} *)
type event
(** Type of events. An event represent a callback registered to be
called when some event occurs. *)
val stop_event : event -> unit
(** [stop_event event] stops the given event. *)
val fake_event : event
(** Event which does nothing when stopped. *)
(** {6 Event loop functions} *)
val iter : bool -> unit
(** [iter block] performs one iteration of the main loop. If [block]
is [true] the function must blocks until one event become
available, otherwise it should just check for available events
and return immediatly. *)
val on_readable : Unix.file_descr -> (event -> unit) -> event
(** [on_readable fd f] calls [f] each time [fd] becomes readable. *)
val on_writable : Unix.file_descr -> (event -> unit) -> event
(** [on_readable fd f] calls [f] each time [fd] becomes writable. *)
val on_timer : float -> bool -> (event -> unit) -> event
(** [on_timer delay repeat f] calls [f] one time after [delay]
seconds. If [repeat] is [true] then [f] is called each [delay]
seconds, otherwise it is called only one time. *)
val readable_count : unit -> int
(** Returns the number of events waiting for a file descriptor to
become readable. *)
val writable_count : unit -> int
(** Returns the number of events waiting for a file descriptor to
become writable. *)
val timer_count : unit -> int
(** Returns the number of registered timers. *)
val fake_io : Unix.file_descr -> unit
(** Simulates activity on the given file descriptor. *)
(** {6 Engines} *)
(** An engine represent a set of functions used to register different
kind of callbacks for different kind of events. *)
(** Abstract class for engines. *)
class virtual abstract : object
method destroy : unit
(** Destroy the engine, remove all its events and free its
associated resources. *)
method transfer : abstract -> unit
(** [transfer engine] moves all events from the current engine to
[engine]. Note that timers are reset in the destination
engine, i.e. if a timer with a delay of 2 seconds was
registered 1 second ago it will occurs in 2 seconds in the
destination engine. *)
(** {6 Event loop methods} *)
method virtual iter : bool -> unit
method on_readable : Unix.file_descr -> (event -> unit) -> event
method on_writable : Unix.file_descr -> (event -> unit) -> event
method on_timer : float -> bool -> (event -> unit) -> event
method fake_io : Unix.file_descr -> unit
method readable_count : int
method writable_count : int
method timer_count : int
(** {6 Backend methods} *)
(** Notes:
- the callback passed to register methods is of type [unit ->
unit] and not [event -> unit]
- register methods returns a lazy value which unregister the
event when forced
*)
method virtual private cleanup : unit
(** Cleanup resources associated to the engine. *)
method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t
end
(** Type of engines. *)
class type t = object
inherit abstract
method iter : bool -> unit
method private cleanup : unit
method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t
end
(** {6 Predefined engines} *)
type ev_loop
(** Type of libev loops. *)
(** Engine based on libev. If not compiled with libev support, the
creation of the class will raise {!Lwt_sys.Not_available}. *)
class libev : object
inherit t
val loop : ev_loop
(** The libev loop used for this engine. *)
method loop : ev_loop
(** Returns [loop]. *)
end
(** Engine based on [Unix.select]. *)
class select : t
(** Abstract class for engines based on a select-like function. *)
class virtual select_based : object
inherit t
method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list
(** [select fds_r fds_w timeout] waits for either:
- one of the file descriptor of [fds_r] to become readable
- one of the file descriptor of [fds_w] to become writable
- timeout to expire
and returns the list of readable file descriptor and the list
of writable file descriptors. *)
end
(** Abstract class for engines based on a poll-like function. *)
class virtual poll_based : object
inherit t
method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list
(** [poll fds tiomeout], where [fds] is a list of tuples of the
form [(fd, check_readable, check_writable)], waits for either:
- one of the file descriptor with [check_readable] set to
[true] to become readable
- one of the file descriptor with [check_writable] set to
[true] to become writable
- timeout to expire
and returns the list of file descriptors with their readable
and writable status. *)
end
(** {6 The current engine} *)
val get : unit -> t
(** [get ()] returns the engine currently in use. *)
val set : ?transfer : bool -> ?destroy : bool -> #t -> unit
(** [set ?transfer ?destroy engine] replaces the current engine by
the given one.
If [transfer] is [true] (the default) all events from the
current engine are transferred to the new one.
If [destroy] is [true] (the default) then the current engine is
destroyed before being replaced. *)

62
server/thirdparty/lwt-2.3.2/src/unix/lwt_gc.ml vendored
View File

@ -1,62 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_gc
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
let ensure_termination t =
if Lwt.state t = Lwt.Sleep then begin
let hook = Lwt_sequence.add_l (fun _ -> t) Lwt_main.exit_hooks in
(* Remove the hook when t has terminated *)
ignore (try_lwt t finally Lwt_sequence.remove hook; Lwt.return ())
end
let finaliser f x =
ensure_termination (f x)
let finalise f = Gc.finalise (finaliser f)
(* Exit hook for a finalise_or_exit *)
let foe_exit f weak _ =
match Weak.get weak 0 with
| None ->
(* The value has been garbage collected, normally this point
is never reached *)
Lwt.return ()
| Some x ->
(* Just to avoid double finalisation *)
Weak.set weak 0 None;
f x
(* Finaliser for a finalise_or_exit *)
let foe_finalise f hook weak x =
(* Remove the exit hook, it is not needed anymore *)
Lwt_sequence.remove hook;
(* This should not be necessary, i am just paranoid: *)
Weak.set weak 0 None;
(* Finally call the real finaliser: *)
finaliser f x
let finalise_or_exit f x =
(* Create a weak pointer, so the exit-hook will prevent [x] from
being garbage collected: *)
let weak = Weak.create 1 in
Weak.set weak 0 (Some x);
let hook = Lwt_sequence.add_l (foe_exit f weak) Lwt_main.exit_hooks in
Gc.finalise (foe_finalise f hook weak) x

36
server/thirdparty/lwt-2.3.2/src/unix/lwt_gc.mli vendored
View File

@ -1,36 +0,0 @@
(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Module Lwt_gc
* Copyright (C) 2009 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(** Interaction with the garbage collector *)
(** This module offer a convenient way to add a finaliser launching a
thread to a value, without having to use [Lwt_unix.run] in the
finaliser. *)
val finalise : ('a -> unit Lwt.t) -> 'a -> unit
(** [finalise f x] calls [f x] when [x] is garbage collected. If [f
x] yields, then Lwt will waits for its termination at the end of
the program. *)
val finalise_or_exit : ('a -> unit Lwt.t) -> 'a -> unit
(** [finalise_or_exit f x] call [f x] when [x] is garbage collected
or (exclusively) when the program exit. *)

Some files were not shown because too many files have changed in this diff Show More