ocamlnet-4.1.6/0000755000175000017500000000000013274252313011752 5ustar gerdgerdocamlnet-4.1.6/INSTALL0000644000175000017500000001721313274252307013012 0ustar gerdgerdHow to install ocamlnet ocamlnet is a quite large library, and is split up into several parts. Usually, it is not necessary to install all of ocamlnet, and there are configuration options allowing you to select what you want. There is now an oasis wrapper for the (custom) configure system. So "ocaml setup.ml -configure; ocaml setup.ml -build" should also work. The following table gives a rough overview. The libraries you must build at minimum are tagged as CORE. For the other libraries the configuration option is shown that will select them for build: Library Option What it provides ---------------------------------------------------------------------- equeue CORE Event queues equeue-gtk2 -enable-gtk2 Event queues - integration into lablgtk2 equeue-tcl -enable-tcl Event queues - integration into labltk netcamlbox CORE Multiprocessing netcgi2 CORE Web applications (revised lib) netcgi2-apache -enable-apache Web applications as Apache module netcgi2-plex CORE Web applications - support for netplex netclient CORE Clients for HTTP, FTP, Telnet, POP, SMTP netgss-system -enable-gssapi GSSAPI bindings nethttpd -with-nethttpd Web server netmulticore CORE Multiprocessing netplex CORE Generic server framework netshm CORE Shared memory for IPC netstring CORE String routines (e.g. URLs, HTML, Mail) netstring-pcre -enable[-full]-pcre PCRE layer netsys CORE System interfaces missing in Unix nettls-gnutls -enable-gnutls TLS library netunidata CORE Unicode tables netzip -enable-zip read/write gzip data using object channels rpc CORE Sophisticated SunRPC/ONCRPC implementation rpc-auth-local CORE (*) SunRPC/ONCRPC - Add-on for local auth rpc-generator CORE SunRPC/ONCRPC - Stub generator rpc-xti CORE (*) SunRPC/ONCRPC - Add-on for XTI-only transports shell CORE Sophisticated version of Sys.command ---------------------------------------------------------------------- (*) If the operation system supports it List of prerequisites: Option Prerequisite Version/Where to get/What it is ---------------------------------------------------------------------- CORE findlib >= 1.0 http://www.ocaml-programming.de/packages Library manager -enable-pcre or -enable-full-pcre pcre >= 5 (pcre-ocaml) http://www.ocaml.info/ocaml_sources Regular expressions library CHANGED IN OCAMLNET-3.6.4 !!! PLEASE READ doc/html-main/Regexp.html -enanle-gnutls gnutls 2.8 or better http://www.gnutls.org -enable-gssapi gssapi Any standard-compliant GSSAPI version should do, e.g. MIT Kerberos or Heimdal -enable-gtk2 lablgtk2 probably any (*) http://wwwfun.kurims.kyoto-u.ac.jp/soft/ olabl/lablgtk.html Bindings for gtk2 GUIs -enable-tcl labltk probably any part of the O'Caml distribution Bindings for tcl/tk GUIs -enable-zip camlzip >= 1.01 http://pauillac.inria.fr/~xleroy/software.html Bindings for zlib -with-nethttpd none none Note: nethttpd must be explicitly selected because it is distributed under different license conditions than the other libraries. See the file LICENSE for more. Note: At runtime, -with-auth-dh needs further prerequisites, namely the so-called keyserv daemon. ---------------------------------------------------------------------- (*) The distribution of this prerequite does not include findlib support. It is, however, silently assumed the prerequisite library is installed in the findlib way. Sorry if this is inconvenient for you. In order to configure ocamlnet, just run the "configure" script with the mentioned options (-enable-X and -with-X). There are a few other options, as listed below. By default, the library archives are installed into the findlib default location. You can find out this location with the command ocamlfind printconf destdir For every ocamlnet library, a subdirectory is created where the files are installed. The few binary executables are installed into the directory where the ocaml compilers are installed. The data files are installed into the same directory as the netstring archives. The "configure" run shows all effective options. Option What it changes ---------------------------------------------------------------------- -bindir Binary executables are installed in -datadir Data files are installed in . Note: This directory is compiled into the netstring library, and cannot be changed at runtime. -equeue-tcl-defs Only if you have -enable-tcl: Sets options for the C compiler so the include files for tcl are found. E.g. -equeue-tcl-defs -I/usr/include/tcl8.4 -equeue-tcl-libs Only if you have -enable-tcl: Sets options for the linker so the tcl library is found. E.g. -equeue-tcl-libs -ltcl8.4 ---------------------------------------------------------------------- The directory where the library archives are installed can be changed when you run "make install", see below. After having configured ocamlnet, you can build it: make all builds the bytecode version, and make opt builds the native version (if posssible on your platform). After the build you can install ocamlnet. It is not required to become root for this, as it is sufficient that you have write privileges in all directories where files are installed. Do this with: make install At this time, you can change the location where the library archives are installed: env OCAMLFIND_DESTDIR="" make install Here, is the replacement for what is output by "ocamlfind printconf destdir". In order to uninstall ocamlnet, run make uninstall ---------------------------------------------------------------------- Special notes for distributors The build system includes a few mechanisms making life easier to build ocamlnet in package management environments. First, it is suggested to distribute ocamlnet as several packages in binary form: - ocamlnet CORE only - ocamlnet-gnutls Add-on libraries needing gnutls - ocamlnet-gssapi Add-on libraries needing GSSAPI - ocamlnet-gtk2 Add-on libraries needing gtk2 - ocamlnet-tcl Add-on libraries needing tcl - ocamlnet-zip Add-on libraries needing camlzip - ocamlnet-pcre Add-on libraries needing pcre - ocamlnet-nethttpd nethttpd (optional, if it makes the different licensing conditions clearer) Second, you can completely separate the builds of the CORE and the add-on stuff: It is possible to build the add-on stuff later, i.e. after the ocamlnet CORE is already installed. To do so, use the special configuration option -disable-core, and run "make" with these extra variables: INC_NETSYS="-package netsys" INC_NETSTRING="-package netstring" INC_EQUEUE="-package equeue" INC_NETCGI2="-package netcgi2" INC_NETCGI2_APACHE="-package netcgi2-apache" INC_NETPLEX="-package netplex" INC_NETCAMLBOX="-package netcamlbox" INC_RPC="-package rpc" INC_SHELL="-package shell" INC_NETGSSAPI="-package netgssapi" i.e. "make all" becomes make all INC_NETSYS="..." INC_NETSTRING="..." ... The effect is that the add-on libraries are built against the already installed core. Third, at installation time, it is possible to install into a local directory hierarchy. To do so, use env DESTDIR="" \ OCAMLFIND_DESTDIR="/$(ocamlfind printconf destdir)" \ make install where is the local directory. You should ensure that the direcories "/$(ocamlfind printconf destdir)", and optionally, "/$(ocamlfind printconf destdir)"/stublibs already exist. ocamlnet-4.1.6/LICENSE0000644000175000017500000000265213274252307012767 0ustar gerdgerdThese license conditions apply to the libraries: - cgi - equeue - equeue-gtk2 - equeue-tcl - netcamlbox - netcgi2 - netcgi2-plex - netclient - netgss-system - netmulticore - netplex - netshm - netstring - netstring-pcre - netsys - nettls-gnutls - netunidata - netzip - rpc - rpc-auth-local - rpc-generator - rpc-xti - shell The same holds for all files for which there are no other license terms. The cppo utility is from Martin Jambon and has its own license terms. It is only needed for building Ocamlnet. ====================================================================== Copyright (c) 2001-2006 Patrick Doane and Gerd Stolpmann This software is provided 'as-is', without any express or implied warranty. In no event will the authors be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented; you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. ocamlnet-4.1.6/LICENSE.GPL0000644000175000017500000004346513274252307013417 0ustar gerdgerdThe library Nethttpd (incl. nethttpd-for-netcgi1 and nethttpd-for-netcgi2) is distributed under the terms of the GNU General Public License (GPL). ====================================================================== GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, 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 or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's 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 give any other recipients of the Program a copy of this License along with the Program. 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 Program or any portion of it, thus forming a work based on the Program, 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) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, 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 Program, 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 Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) 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; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, 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 executable. However, as a special exception, the source code 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. If distribution of executable or 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 counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program 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. 5. 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 Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program 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 to this License. 7. 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 Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program 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 Program. 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. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program 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. 9. The Free Software Foundation may publish revised and/or new versions of the 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 Program 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 Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, 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 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "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 PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. 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 PROGRAM 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 PROGRAM (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 PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 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 Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. ocamlnet-4.1.6/LICENSE.LGPL0000644000175000017500000000012013274252307013510 0ustar gerdgerdThese license conditions apply to the mod_caml part of the netcgi library. XXX ocamlnet-4.1.6/Makefile.xrules0000644000175000017500000000064413274252307014742 0ustar gerdgerd# Additional rules for the examples: OCAMLRPCGEN = ocamlfind rpc-generator/ocamlrpcgen .SUFFIXES: .x .astamp .cstamp .sstamp .s2stamp .x.astamp: $(OCAMLRPCGEN) -aux $(RPCGEN_AUX_OPTIONS) $< touch $@ .x.cstamp: $(OCAMLRPCGEN) -clnt $(RPCGEN_CLIENT_OPTIONS) $< touch $@ .x.sstamp: $(OCAMLRPCGEN) -srv $(RPCGEN_SERVER_OPTIONS) $< touch $@ .x.s2stamp: $(OCAMLRPCGEN) -srv2 $(RPCGEN_SERVER_OPTIONS) $< touch $@ ocamlnet-4.1.6/RELNOTES0000644000175000017500000000362313274252307013137 0ustar gerdgerd---------------------------------------------------------------------- Intro ---------------------------------------------------------------------- These are release notes for ocamlnet-3.0. Major changes include: - Port to Win32 - The new Rpc_proxy layer - Netplex has been extended (Netplex_sharedvar etc.) - New implementation of the Shell library for starting subprocesses - Uniform debugging with Netlog.Debug - Exception printers (Netexn) - Coordination of signal handling in Netsys_signal - New foundation for Unixqueue via pollsets - Extended Unixqueue engines (e.g. Uq_io) - More system calls in netsys - Camlboxes as an efficient way of message passing between processes - The netcgi1 library has been dropped in favor of netcgi2 Also, there are lots of smaller improvements and bug fixes. ---------------------------------------------------------------------- Known Problems ---------------------------------------------------------------------- There are known problems in this preview release: - The port to Win32 is incomplete and still alpha quality - Sometimes, DNS errors are just reported by the exception Not_found - In netcgi2-plex, the "mount_dir" and "mount_at" options are not yet implemented. - In netclient, aggressive caching of HTTP connections is still buggy. Do not use this option (by default, it is not enabled). - The FTP client is still incomplete. ---------------------------------------------------------------------- Resources ---------------------------------------------------------------------- The current development version is available in Subversion: https://godirepo.camlcity.org/svn/lib-ocamlnet2 Note that the ocamlnet file tree in Sourceforge refers to ocamlnet-1 only. There is a mailing list for Ocamlnet development: http://sourceforge.net/mail/?group_id=19774 In case of problems, you can also contact me directly: Gerd Stolpmann ocamlnet-4.1.6/_oasis0000644000175000017500000000570613274252307013165 0ustar gerdgerdOASISFormat: 0.4 Name: ocamlnet Version: 4.1.6 Synopsis: Internet protocols and helper data structures Authors: Gerd Stolpmann et al. ConfType: custom (0.4) BuildType: custom (0.4) InstallType: custom (0.4) BuildTools: make License: http://download.camlcity.org/download/licenses/ocamlnet OCamlVersion: >= 4.00.0 Homepage: http://projects.camlcity.org/projects/ocamlnet XCustomConf: ./configure PostConfCommand: make -s postconf XCustomBuild: make build XCustomInstall: make install XCustomUninstall: make uninstall Flag "gtk2" Description: gtk2: Support for gtk2 event loops Default: false Flag "tcl" Description: tcl: Support for Tcl/Tk event loops Default: false Flag "zlib" Description: zlib: Support for compression Default: false Flag "apache" Description: apache: Build the Apache module Default: false Flag "gnutls" Description: gnutls: Enable (Gnu) TLS Default: false Flag "gssapi" Description: gssapi: Enable GSSAPI Default: false Flag "pcre" Description: pcre: Build netstring-pcre library Default: false Flag "full_pcre" Description: full_pcre: Use pcre for all regular expressions Default: false Flag "nethttpd" Description: nethttpd: Build the webserver nethttpd Default: false Library "equeue" Path: src/equeue Library "equeue-gtk2" Path: src/equeue-gtk2 BuildDepends: lablgtk2 Build: false if flag(gtk2) Build: true Library "equeue-tcl" Path: src/equeue-tcl Build: false if flag(tcl) Build: true Library "netcamlbox" Path: src/netcamlbox Library "netcgi2" Path: src/netcgi2 Library "netcgi2-plex" Path: src/netcgi2-plex Library "netcgi2-apache" Path: src/netcgi2-apache Build: false if flag(apache) Build: true Library "netclient" Path: src/netclient Library "netgss-system" Path: src/netgss-system Build: false if flag(gssapi) Build: true Library "nethttpd" Path: src/nethttpd Build: false if flag(nethttpd) Build: true Library "netmulticore" Path: src/netmulticore Library "netplex" Path: src/netplex Library "netshm" Path: src/netshm Library "netstring" Path: src/netstring Library "netstring-pcre" Path: src/netstring-pcre BuildDepends: pcre Build: false if flag(pcre) || flag(full_pcre) Build: true Library "netsys" Path: src/netsys Library "nettls-gnutls" Path: src/netsys-gnutls Build: false if flag(gnutls) Build: true Library "netunidata" Path: src/netunidata Library "netzip" Path: src/netzip BuildDepends: zip Build: false if flag(zlib) Build: true Library "rpc" Path: src/rpc Library "rpc-auth-local" Path: src/rpc-auth-local Library "rpc-generator" Path: src/rpc-generator Library "rpc-xti" Path: src/rpc-xti Build: false if system(sunos) || system(solaris) Build: true Library "shell" Path: src/shell Executable "ocamlrpcgen" Path: src/rpc-generator MainIs: main.ml Executable "netplex-admin" Path: src/netplex MainIs: netplex_admin.ml ocamlnet-4.1.6/setup.ml0000644000175000017500000127334413274252307013465 0ustar gerdgerd(* setup.ml generated for the first time by OASIS v0.4.5 *) (* OASIS_START *) (* DO NOT EDIT (digest: 79615a4a25c706920347c2f635b9b951) *) (* Regenerated by OASIS v0.4.10 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISString = struct (* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; !what_idx = String.length what let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; !what_idx = -1 let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf let lowercase_ascii = replace_chars (fun c -> if (c >= 'A' && c <= 'Z') then Char.chr (Char.code c + 32) else c) let uncapitalize_ascii s = if s <> "" then (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s let uppercase_ascii = replace_chars (fun c -> if (c >= 'a' && c <= 'z') then Char.chr (Char.code c - 32) else c) let capitalize_ascii s = if s <> "" then (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) let compare_csl s1 s2 = String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (compare_csl s1 s2) = 0 let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) end) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in OASISString.lowercase_ascii buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt let rec file_location ?pos1 ?pos2 ?lexbuf () = match pos1, pos2, lexbuf with | Some p, None, _ | None, Some p, _ -> file_location ~pos1:p ~pos2:p ?lexbuf () | Some p1, Some p2, _ -> let open Lexing in let fn, lineno = p1.pos_fname, p1.pos_lnum in let c1 = p1.pos_cnum - p1.pos_bol in let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 | _, _, Some lexbuf -> file_location ~pos1:(Lexing.lexeme_start_p lexbuf) ~pos2:(Lexing.lexeme_end_p lexbuf) () | None, None, None -> s_ "" let failwithpf ?pos1 ?pos2 ?lexbuf fmt = let loc = file_location ?pos1 ?pos2 ?lexbuf () in Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt end module OASISUnixPath = struct (* # 22 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (OASISString.capitalize_ascii base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (OASISString.uncapitalize_ascii base) end module OASISHostPath = struct (* # 22 "src/oasis/OASISHostPath.ml" *) open Filename open OASISGettext module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = match Sys.os_type with | "Unix" | "Cygwin" -> ufn | "Win32" -> make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) | os_type -> OASISUtils.failwithf (f_ "Don't know the path format of os_type %S when translating unix \ filename. %S") os_type ufn end module OASISFileSystem = struct (* # 22 "src/oasis/OASISFileSystem.ml" *) (** File System functions @author Sylvain Le Gall *) type 'a filename = string class type closer = object method close: unit end class type reader = object inherit closer method input: Buffer.t -> int -> unit end class type writer = object inherit closer method output: Buffer.t -> unit end class type ['a] fs = object method string_of_filename: 'a filename -> string method open_out: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> writer method open_in: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> reader method file_exists: 'a filename -> bool method remove: 'a filename -> unit end module Mode = struct let default_in = [Open_rdonly] let default_out = [Open_wronly; Open_creat; Open_trunc] let text_in = Open_text :: default_in let text_out = Open_text :: default_out let binary_in = Open_binary :: default_in let binary_out = Open_binary :: default_out end let std_length = 4096 (* Standard buffer/read length. *) let binary_out = Mode.binary_out let binary_in = Mode.binary_in let of_unix_filename ufn = (ufn: 'a filename) let to_unix_filename fn = (fn: string) let defer_close o f = try let r = f o in o#close; r with e -> o#close; raise e let stream_of_reader rdr = let buf = Buffer.create std_length in let pos = ref 0 in let eof = ref false in let rec next idx = let bpos = idx - !pos in if !eof then begin None end else if bpos < Buffer.length buf then begin Some (Buffer.nth buf bpos) end else begin pos := !pos + Buffer.length buf; Buffer.clear buf; begin try rdr#input buf std_length; with End_of_file -> if Buffer.length buf = 0 then eof := true end; next idx end in Stream.from next let read_all buf rdr = try while true do rdr#input buf std_length done with End_of_file -> () class ['a] host_fs rootdir : ['a] fs = object (self) method private host_filename fn = Filename.concat rootdir fn method string_of_filename = self#host_filename method open_out ?(mode=Mode.text_out) ?(perm=0o666) fn = let chn = open_out_gen mode perm (self#host_filename fn) in object method close = close_out chn method output buf = Buffer.output_buffer chn buf end method open_in ?(mode=Mode.text_in) ?(perm=0o666) fn = (* TODO: use Buffer.add_channel when minimal version of OCaml will * be >= 4.03.0 (previous version was discarding last chars). *) let chn = open_in_gen mode perm (self#host_filename fn) in let strm = Stream.of_channel chn in object method close = close_in chn method input buf len = let read = ref 0 in try for _i = 0 to len do Buffer.add_char buf (Stream.next strm); incr read done with Stream.Failure -> if !read = 0 then raise End_of_file end method file_exists fn = Sys.file_exists (self#host_filename fn) method remove fn = Sys.remove (self#host_filename fn) end end module OASISContext = struct (* # 22 "src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type source type source_filename = source OASISFileSystem.filename let in_srcdir ufn = OASISFileSystem.of_unix_filename ufn type t = { (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; srcfs: source OASISFileSystem.fs; load_oasis_plugin: string -> bool; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; srcfs = new OASISFileSystem.host_fs(Sys.getcwd ()); load_oasis_plugin = (fun _ -> false); } let quiet = {!default with quiet = true} let fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), s_ " Output debug message"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", Arg.String (fun str -> Sys.chdir str; default := {!default with srcfs = new OASISFileSystem.host_fs str}), s_ "dir Change directory before running (affects setup.{data,log})."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module PropList = struct (* # 22 "src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 77 "src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then OASISString.lowercase_ascii else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct (* # 22 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 22 "src/oasis/OASISVersion.ml" *) open OASISGettext type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) end module OASISLicense = struct (* # 22 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext open OASISUtils type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISText = struct (* # 22 "src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISSourcePatterns = struct (* # 22 "src/oasis/OASISSourcePatterns.ml" *) open OASISUtils open OASISGettext module Templater = struct (* TODO: use this module in BaseEnv.var_expand and BaseFileAB, at least. *) type t = { atoms: atom list; origin: string } and atom = | Text of string | Expr of expr and expr = | Ident of string | String of string | Call of string * expr type env = { variables: string MapString.t; functions: (string -> string) MapString.t; } let eval env t = let rec eval_expr env = function | String str -> str | Ident nm -> begin try MapString.find nm env.variables with Not_found -> (* TODO: add error location within the string. *) failwithf (f_ "Unable to find variable %S in source pattern %S") nm t.origin end | Call (fn, expr) -> begin try (MapString.find fn env.functions) (eval_expr env expr) with Not_found -> (* TODO: add error location within the string. *) failwithf (f_ "Unable to find function %S in source pattern %S") fn t.origin end in String.concat "" (List.map (function | Text str -> str | Expr expr -> eval_expr env expr) t.atoms) let parse env s = let lxr = Genlex.make_lexer [] in let parse_expr s = let st = lxr (Stream.of_string s) in match Stream.npeek 3 st with | [Genlex.Ident fn; Genlex.Ident nm] -> Call(fn, Ident nm) | [Genlex.Ident fn; Genlex.String str] -> Call(fn, String str) | [Genlex.String str] -> String str | [Genlex.Ident nm] -> Ident nm (* TODO: add error location within the string. *) | _ -> failwithf (f_ "Unable to parse expression %S") s in let parse s = let lst_exprs = ref [] in let ss = let buff = Buffer.create (String.length s) in Buffer.add_substitute buff (fun s -> lst_exprs := (parse_expr s) :: !lst_exprs; "\000") s; Buffer.contents buff in let rec join = function | hd1 :: tl1, hd2 :: tl2 -> Text hd1 :: Expr hd2 :: join (tl1, tl2) | [], tl -> List.map (fun e -> Expr e) tl | tl, [] -> List.map (fun e -> Text e) tl in join (OASISString.nsplit ss '\000', List.rev (!lst_exprs)) in let t = {atoms = parse s; origin = s} in (* We rely on a simple evaluation for checking variables/functions. It works because there is no if/loop statement. *) let _s : string = eval env t in t (* # 144 "src/oasis/OASISSourcePatterns.ml" *) end type t = Templater.t let env ~modul () = { Templater. variables = MapString.of_list ["module", modul]; functions = MapString.of_list [ "capitalize_file", OASISUnixPath.capitalize_file; "uncapitalize_file", OASISUnixPath.uncapitalize_file; ]; } let all_possible_files lst ~path ~modul = let eval = Templater.eval (env ~modul ()) in List.fold_left (fun acc pat -> OASISUnixPath.concat path (eval pat) :: acc) [] lst let to_string t = t.Templater.origin end module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string (* TODO: replace everywhere. *) type host_dirname = string (* TODO: replace everywhere. *) type host_filename = string (* TODO: replace everywhere. *) type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_interface_patterns: OASISSourcePatterns.t list; bs_implementation_patterns: OASISSourcePatterns.t list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_findlib_extra_files: unix_filename list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_directory: unix_dirname option; lib_findlib_containers: findlib_name list; } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; obj_findlib_directory: unix_dirname option; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename (* TODO: source filename. *) | DocText | PDF | PostScript | Info of unix_filename (* TODO: source filename. *) | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; (* TODO: dest filename ?. *) doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; (* TODO: src filename. *) doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; (* TODO: source filename. *) copyrights: string list; maintainers: string list; authors: string list; homepage: url option; bugreports: url option; synopsis: string; description: OASISText.t option; tags: string list; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; (* TODO: source filename. *) sections: section list; plugins: [`Extra] plugin list; disable_oasis_section: unix_filename list; (* TODO: source filename. *) schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version (t:t).oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" (t:t).name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem (t:t).name features in if not has_feature then match (origin:origin) with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some _ -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Make building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Make running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "Compile the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allow the OASIS section comments and digests to be omitted in \ generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha (fun () -> s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") let findlib_directory = create "findlib_directory" beta (fun () -> s_ "Allow to install findlib libraries in sub-directories of the target \ findlib directory.") let findlib_extra_files = create "findlib_extra_files" beta (fun () -> s_ "Allow to install extra files for findlib libraries.") let source_patterns = create "source_patterns" alpha (fun () -> s_ "Customize mapping between module name and source file.") end module OASISSection = struct (* # 22 "src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section_kind = function | `Library -> "library" | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc" let string_of_section sct = let k, nm = section_id sct in (string_of_section_kind k)^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 22 "src/oasis/OASISBuildSection.ml" *) open OASISTypes (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs modul = let possible_lst = OASISSourcePatterns.all_possible_files (bs.bs_interface_patterns @ bs.bs_implementation_patterns) ~path:bs.bs_path ~modul in match List.filter source_file_exists possible_lst with | (fn :: _) as fn_lst -> `Sources (OASISUnixPath.chop_extension fn, fn_lst) | [] -> let open OASISUtils in let _, rev_lst = List.fold_left (fun (set, acc) fn -> let base_fn = OASISUnixPath.chop_extension fn in if SetString.mem base_fn set then set, acc else SetString.add base_fn set, base_fn :: acc) (SetString.empty, []) possible_lst in `No_sources (List.rev rev_lst) end module OASISExecutable = struct (* # 22 "src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 22 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISGettext let find_module ~ctxt source_file_exists cs bs modul = match OASISBuildSection.find_module source_file_exists bs modul with | `Sources _ as res -> res | `No_sources _ as res -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching module '%s' in library %s.") modul cs.cs_name; OASISMessage.warning ~ctxt (f_ "Use InterfacePatterns or ImplementationPatterns to define \ this file with feature %S.") (OASISFeatures.source_patterns.OASISFeatures.name); res let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module ~ctxt source_file_exists cs bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module ~ctxt source_file_exists cs bs modul with | `Sources (_, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* The headers and annot/cmt files that should be compiled along *) let headers = let sufx = if lib.lib_pack then [".cmti"; ".cmt"; ".annot"] else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map (List.fold_left (fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in List.map ((^) base) sufx @ accu) []) (find_modules lib.lib_modules "cmi") in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: if has_native_dynlink then ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath else acc_nopath end else begin acc_nopath end in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) end module OASISObject = struct (* # 22 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let find_module ~ctxt source_file_exists cs bs modul = match OASISBuildSection.find_module source_file_exists bs modul with | `Sources _ as res -> res | `No_sources _ as res -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching module '%s' in object %s.") modul cs.cs_name; OASISMessage.warning ~ctxt (f_ "Use InterfacePatterns or ImplementationPatterns to define \ this file with feature %S.") (OASISFeatures.source_patterns.OASISFeatures.name); res let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match find_module ~ctxt source_file_exists cs bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match find_module ~ctxt source_file_exists cs bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "src/oasis/OASISFindlib.ml" *) open OASISTypes open OASISUtils open OASISGettext type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * [`Library of library | `Object of object_] * unix_dirname option * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let unix_directory dn lib = let directory = match lib with | `Library lib -> lib.lib_findlib_directory | `Object obj -> obj.obj_findlib_directory in match dn, directory with | None, None -> None | None, Some dn | Some dn, None -> Some dn | Some dn1, Some dn2 -> Some (OASISUnixPath.concat dn1 dn2) in let rec group_of_tree dn mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> let current_dn = unix_directory dn lib in Package (nm, cs, bs, lib, current_dn, group_of_tree current_dn children) | Node (None, children) -> Container (nm, group_of_tree dn children) | Leaf (cs, bs, lib) -> let current_dn = unix_directory dn lib in Package (nm, cs, bs, lib, current_dn, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree None group_mp in let library_name_of_findlib_name = lazy begin (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty end in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 22 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 22 "src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a, b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") tgt end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 3159 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = let line = ref 1 in let lexer st = 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 Genlex.make_lexer ["="] st_line in let rec read_file lxr mp = match Stream.npeek 3 lxr with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; read_file lxr (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in match stream with | Some st -> read_file (lexer st) MapString.empty | None -> if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in try let mp = read_file (lexer st) MapString.empty in close_in chn; mp with e -> close_in chn; raise e end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 3239 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 22 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open OASISContext open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (_, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context:_ x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (_: unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = in_srcdir "setup.data" let load ~ctxt ?(allow_empty=false) ?(filename=default_filename) () = let open OASISFileSystem in env_from_file := let repr_filename = ctxt.srcfs#string_of_filename filename in if ctxt.srcfs#file_exists filename then begin let buf = Buffer.create 13 in defer_close (ctxt.srcfs#open_in ~mode:binary_in filename) (read_all buf); defer_close (ctxt.srcfs#open_in ~mode:binary_in filename) (fun rdr -> OASISMessage.info ~ctxt "Loading environment from %S." repr_filename; BaseEnvLight.load ~allow_empty ~filename:(repr_filename) ~stream:(stream_of_reader rdr) ()) end else if allow_empty then begin BaseEnvLight.MapString.empty end else begin failwith (Printf.sprintf (f_ "Unable to load environment, the file '%s' doesn't exist.") repr_filename) end let unload () = env_from_file := MapString.empty; Data.clear env let dump ~ctxt ?(filename=default_filename) () = let open OASISFileSystem in defer_close (ctxt.OASISContext.srcfs#open_out ~mode:binary_out filename) (fun wrtr -> let buf = Buffer.create 63 in let output nm value = Buffer.add_string buf (Printf.sprintf "%s=%S\n" nm value) in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try output nm (Schema.get schema env nm) with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; wrtr#output buf) let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration:\n"; List.iter (fun (name, value) -> Printf.printf "%s: %s" name (dot_pad name); if value = "" then Printf.printf "\n" else Printf.printf " %s\n" value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 22 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 22 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 22 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 22 "src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" || os_type () = "Cygwin" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> let _s: string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" | "Cygwin" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 22 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage open OASISContext let to_filename fn = if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; OASISFileSystem.of_unix_filename (Filename.chop_extension fn) let replace ~ctxt fn_lst = let open OASISFileSystem in let ibuf, obuf = Buffer.create 13, Buffer.create 13 in List.iter (fun fn -> Buffer.clear ibuf; Buffer.clear obuf; defer_close (ctxt.srcfs#open_in (of_unix_filename fn)) (read_all ibuf); Buffer.add_string obuf (var_expand (Buffer.contents ibuf)); defer_close (ctxt.srcfs#open_out (to_filename fn)) (fun wrtr -> wrtr#output obuf)) fn_lst end module BaseLog = struct (* # 22 "src/base/BaseLog.ml" *) open OASISUtils open OASISContext open OASISGettext open OASISFileSystem let default_filename = in_srcdir "setup.log" let load ~ctxt () = let module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) in if ctxt.srcfs#file_exists default_filename then begin defer_close (ctxt.srcfs#open_in default_filename) (fun rdr -> let line = ref 1 in let lxr = Genlex.make_lexer [] (stream_of_reader rdr) in let rec read_aux (st, lst) = match Stream.npeek 2 lxr with | [Genlex.String e; Genlex.String d] -> let t = e, d in Stream.junk lxr; Stream.junk lxr; if SetTupleString.mem t st then read_aux (st, lst) else read_aux (SetTupleString.add t st, t :: lst) | [] -> List.rev lst | _ -> failwithf (f_ "Malformed log file '%s' at line %d") (ctxt.srcfs#string_of_filename default_filename) !line in read_aux (SetTupleString.empty, [])) end else begin [] end let register ~ctxt event data = defer_close (ctxt.srcfs#open_out ~mode:[Open_append; Open_creat; Open_text] ~perm:0o644 default_filename) (fun wrtr -> let buf = Buffer.create 13 in Printf.bprintf buf "%S %S\n" event data; wrtr#output buf) let unregister ~ctxt event data = let lst = load ~ctxt () in let buf = Buffer.create 13 in List.iter (fun (e, d) -> if e <> event || d <> data then Printf.bprintf buf "%S %S\n" e d) lst; if Buffer.length buf > 0 then defer_close (ctxt.srcfs#open_out default_filename) (fun wrtr -> wrtr#output buf) else ctxt.srcfs#remove default_filename let filter ~ctxt events = let st_events = SetString.of_list events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ~ctxt ()) let exists ~ctxt event data = List.exists (fun v -> (event, data) = v) (load ~ctxt ()) end module BaseBuilt = struct (* # 22 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register ~ctxt t nm lst = BaseLog.register ~ctxt (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register ~ctxt (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else begin registered end) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister ~ctxt t nm = List.iter (fun (e, d) -> BaseLog.unregister ~ctxt e d) (BaseLog.filter ~ctxt [to_log_event_file t nm; to_log_event_done t nm]) let fold ~ctxt t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BObj -> (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter ~ctxt [to_log_event_file t nm]) let is_built ~ctxt t nm = List.fold_left (fun _ (_, d) -> try bool_of_string d with _ -> false) false (BaseLog.filter ~ctxt [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 22 "src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init ~ctxt pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, _) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold ~ctxt BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let test ~ctxt lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin ~ctxt pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let failed, n = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 22 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc ~ctxt lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin ~ctxt pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "src/base/BaseSetup.ml" *) open OASISContext open BaseEnv open BaseMessage open OASISTypes open OASISGettext open OASISUtils type std_args_fun = ctxt:OASISContext.t -> package -> string array -> unit type ('a, 'b) section_args_fun = name * (ctxt:OASISContext.t -> package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure ~ctxt t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load ~ctxt (); with _ -> () end; (* Run plugin's configure *) t.configure ~ctxt t.package args; (* Dump to allow postconf to change it *) dump ~ctxt ()) (); (* Reload environment *) unload (); load ~ctxt (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace ~ctxt t.package.files_ab let build ~ctxt t args = BaseCustom.hook t.package.build_custom (t.build ~ctxt t.package) args let doc ~ctxt t args = BaseDoc.doc ~ctxt (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test ~ctxt t args = BaseTest.test ~ctxt (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all ~ctxt t args = let rno_doc = ref false in let rno_test = ref false in let arg_rest = ref [] in Arg.parse_argv ~current:(ref 0) (Array.of_list ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", Arg.Set rno_doc, s_ "Don't run doc target"; "-no-test", Arg.Set rno_test, s_ "Don't run test target"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure ~ctxt t (Array.of_list (List.rev !arg_rest)); info "Running build step"; build ~ctxt t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init ~ctxt t.package; if not !rno_doc then begin info "Running doc step"; doc ~ctxt t [||] end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test ~ctxt t [||] end else begin info "Skipping test step" end let install ~ctxt t args = BaseCustom.hook t.package.install_custom (t.install ~ctxt t.package) args let uninstall ~ctxt t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall ~ctxt t.package) args let reinstall ~ctxt t args = uninstall ~ctxt t args; install ~ctxt t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean ~ctxt t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun ~ctxt:_ _ _ _ -> () in failsafe (f ~ctxt t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun ~ctxt:_ _ _ _ -> () in failsafe (f ~ctxt t.package (cs, doc)) args | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f ~ctxt t.package) args) mains) () in let clean ~ctxt t args = generic_clean ~ctxt t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean ~ctxt t args = (* Call clean *) clean ~ctxt t args; (* Call distclean code *) generic_clean ~ctxt t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated source files. *) List.iter (fun fn -> if ctxt.srcfs#file_exists fn then begin info (f_ "Remove '%s'") (ctxt.srcfs#string_of_filename fn); ctxt.srcfs#remove fn end) ([BaseEnv.default_filename; BaseLog.default_filename] @ (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version ~ctxt:_ (t: t) _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") (* TODO: srcfs *) let default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (fun n -> if n <> 0 then failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file default_oasis_fn then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in let act_ref = ref (fun ~ctxt:_ _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in try let () = Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n") in (* Instantiate the context. *) let ctxt = !BaseContext.default in (* Build initial environment *) load ~ctxt ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init ~ctxt t.package; if not (t.setup_update && update_setup_ml t) then !act_ref ~ctxt t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end module BaseCompat = struct (* # 22 "src/base/BaseCompat.ml" *) (** Compatibility layer to provide a stable API inside setup.ml. This layer allows OASIS to change in between minor versions (e.g. 0.4.6 -> 0.4.7) but still provides a stable API inside setup.ml. This enables to write functions that manipulate setup_t inside setup.ml. See deps.ml for an example. The module opened by default will depend on the version of the _oasis. E.g. if we have "OASISFormat: 0.3", the module Compat_0_3 will be opened and the function Compat_0_3 will be called. If setup.ml is generated with the -nocompat, no module will be opened. @author Sylvain Le Gall *) module Compat_0_4 = struct let rctxt = ref !BaseContext.default module BaseSetup = struct module Original = BaseSetup open OASISTypes type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } let setup t = let mk_std_args_fun f = fun ~ctxt pkg args -> rctxt := ctxt; f pkg args in let mk_section_args_fun l = List.map (fun (nm, f) -> nm, (fun ~ctxt pkg sct args -> rctxt := ctxt; f pkg sct args)) l in let t' = { Original. configure = mk_std_args_fun t.configure; build = mk_std_args_fun t.build; doc = mk_section_args_fun t.doc; test = mk_section_args_fun t.test; install = mk_std_args_fun t.install; uninstall = mk_std_args_fun t.uninstall; clean = List.map mk_std_args_fun t.clean; clean_doc = mk_section_args_fun t.clean_doc; clean_test = mk_section_args_fun t.clean_test; distclean = List.map mk_std_args_fun t.distclean; distclean_doc = mk_section_args_fun t.distclean_doc; distclean_test = mk_section_args_fun t.distclean_test; package = t.package; oasis_fn = t.oasis_fn; oasis_version = t.oasis_version; oasis_digest = t.oasis_digest; oasis_exec = t.oasis_exec; oasis_setup_args = t.oasis_setup_args; setup_update = t.setup_update; } in Original.setup t' end let adapt_setup_t setup_t = let module O = BaseSetup.Original in let mk_std_args_fun f = fun pkg args -> f ~ctxt:!rctxt pkg args in let mk_section_args_fun l = List.map (fun (nm, f) -> nm, (fun pkg sct args -> f ~ctxt:!rctxt pkg sct args)) l in { BaseSetup. configure = mk_std_args_fun setup_t.O.configure; build = mk_std_args_fun setup_t.O.build; doc = mk_section_args_fun setup_t.O.doc; test = mk_section_args_fun setup_t.O.test; install = mk_std_args_fun setup_t.O.install; uninstall = mk_std_args_fun setup_t.O.uninstall; clean = List.map mk_std_args_fun setup_t.O.clean; clean_doc = mk_section_args_fun setup_t.O.clean_doc; clean_test = mk_section_args_fun setup_t.O.clean_test; distclean = List.map mk_std_args_fun setup_t.O.distclean; distclean_doc = mk_section_args_fun setup_t.O.distclean_doc; distclean_test = mk_section_args_fun setup_t.O.distclean_test; package = setup_t.O.package; oasis_fn = setup_t.O.oasis_fn; oasis_version = setup_t.O.oasis_version; oasis_digest = setup_t.O.oasis_digest; oasis_exec = setup_t.O.oasis_exec; oasis_setup_args = setup_t.O.oasis_setup_args; setup_update = setup_t.O.setup_update; } end module Compat_0_3 = struct include Compat_0_4 end end # 5662 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author *) open BaseEnv open OASISGettext open OASISTypes type t = { cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; } let run = BaseCustom.run let main ~ctxt:_ t _ extra_args = let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in run cmd args extra_args let clean ~ctxt:_ t _ extra_args = match var_choose t.cmd_clean with | Some (cmd, args) -> run cmd args extra_args | _ -> () let distclean ~ctxt:_ t _ extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> run cmd args extra_args | _ -> () module Build = struct let main ~ctxt t pkg extra_args = main ~ctxt t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, _ = BaseBuilt.of_library OASISHostPath.of_unix (cs, bs, lib) in evs end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable OASISHostPath.of_unix (cs, bs, exec) in evs end | _ -> [] in List.iter (fun (bt, bnm, lst) -> BaseBuilt.register ~ctxt bt bnm lst) evs) pkg.sections let clean ~ctxt t pkg extra_args = clean ~ctxt t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections let distclean ~ctxt t pkg extra_args = distclean ~ctxt t pkg extra_args end module Test = struct let main ~ctxt t pkg (cs, _) extra_args = try main ~ctxt t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; 1.0 let clean ~ctxt t pkg _ extra_args = clean ~ctxt t pkg extra_args let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args end module Doc = struct let main ~ctxt t pkg (cs, _) extra_args = main ~ctxt t pkg extra_args; BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [] let clean ~ctxt t pkg (cs, _) extra_args = clean ~ctxt t pkg extra_args; BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args end end # 5794 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = CustomPlugin.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("./configure", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; build = CustomPlugin.Build.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["build"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; test = []; doc = []; install = CustomPlugin.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["install"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; uninstall = CustomPlugin.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["uninstall"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; clean = [ CustomPlugin.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("./configure", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.Build.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["build"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["install"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["uninstall"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] } ]; clean_test = []; clean_doc = []; distclean = [ CustomPlugin.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("./configure", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.Build.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["build"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["install"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["uninstall"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] } ]; distclean_test = []; distclean_doc = []; package = { oasis_version = "0.4"; ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.0"); version = "4.1.6"; license = OASISLicense.OtherLicense "http://download.camlcity.org/download/licenses/ocamlnet"; findlib_version = None; alpha_features = []; beta_features = []; name = "ocamlnet"; license_file = None; copyrights = []; maintainers = []; authors = ["Gerd Stolpmann et al."]; homepage = Some "http://projects.camlcity.org/projects/ocamlnet"; bugreports = None; synopsis = "Internet protocols and helper data structures"; description = None; tags = []; categories = []; files_ab = []; sections = [ Flag ({ cs_name = "gtk2"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "gtk2: Support for gtk2 event loops"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "tcl"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "tcl: Support for Tcl/Tk event loops"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "zlib"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "zlib: Support for compression"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "apache"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "apache: Build the Apache module"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "gnutls"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "gnutls: Enable (Gnu) TLS"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "gssapi"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "gssapi: Enable GSSAPI"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "pcre"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "pcre: Build netstring-pcre library"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "full_pcre"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "full_pcre: Use pcre for all regular expressions"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "nethttpd"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "nethttpd: Build the webserver nethttpd"; flag_default = [(OASISExpr.EBool true, false)] }); Library ({ cs_name = "equeue"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/equeue"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "equeue-gtk2"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "gtk2", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/equeue-gtk2"; bs_compiled_object = Best; bs_build_depends = [FindlibPackage ("lablgtk2", None)]; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "equeue-tcl"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "tcl", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/equeue-tcl"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netcamlbox"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netcamlbox"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netcgi2"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netcgi2"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netcgi2-plex"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netcgi2-plex"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netcgi2-apache"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "apache", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netcgi2-apache"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netclient"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netclient"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netgss-system"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "gssapi", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netgss-system"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "nethttpd"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "nethttpd", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/nethttpd"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netmulticore"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netmulticore"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netplex"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netplex"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netshm"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netshm"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netstring"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netstring"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netstring-pcre"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "pcre", OASISExpr.EFlag "full_pcre"), true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netstring-pcre"; bs_compiled_object = Best; bs_build_depends = [FindlibPackage ("pcre", None)]; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netsys"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netsys"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "nettls-gnutls"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "gnutls", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netsys-gnutls"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netunidata"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netunidata"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "netzip"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "zlib", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netzip"; bs_compiled_object = Best; bs_build_depends = [FindlibPackage ("zip", None)]; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "rpc"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/rpc"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "rpc-auth-local"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/rpc-auth-local"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "rpc-generator"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/rpc-generator"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "rpc-xti"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.ETest ("system", "sunos"), OASISExpr.ETest ("system", "solaris")), true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/rpc-xti"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "shell"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/shell"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Executable ({ cs_name = "ocamlrpcgen"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/rpc-generator"; bs_compiled_object = Byte; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "main.ml"}); Executable ({ cs_name = "netplex-admin"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netplex"; bs_compiled_object = Byte; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "netplex_admin.ml"}) ]; disable_oasis_section = []; conf_type = (`Configure, "custom", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, Some (("make", ["-s"; "postconf"]))) ] }; build_type = (`Build, "custom", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "custom", Some "0.4"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; plugins = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.10"; oasis_digest = Some "\182\232/v/\238\014o\225\240-\169\169\186\213\205"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 9791 "setup.ml" let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t open BaseCompat.Compat_0_4 (* OASIS_STOP *) let () = setup ();; ocamlnet-4.1.6/Makefile0000644000175000017500000000537413274252307013426 0ustar gerdgerd# make all: compiles the configured packages with ocamlc # make opt: compiles the configured packages with ocamlopt # make install: installs the configured packages # make clean: cleans everything up # Inclusion of Makefile.conf may fail when cleaning up: -include Makefile.conf NAME=ocamlnet TOP_DIR=. # PKGLIST: should be set in Makefile.conf. It contains the packages to # compile and to install. The following assignment sets it to its # default value if no Makefile.conf exists. PKGLIST ?= netstring cgi .PHONY: build build: all if ocamlopt 2>/dev/null; then $(MAKE) opt; fi .PHONY: all all: tools for pkg in $(PKGLIST); do \ ( cd src/$$pkg && $(MAKE) -f Makefile.pre generate ) || exit; \ ( cd src/$$pkg && $(MAKE) -f Makefile.pre depend ) || exit; \ ( cd src/$$pkg && $(MAKE) all ) || exit; \ done .PHONY: opt opt: tools for pkg in $(PKGLIST); do \ ( cd src/$$pkg && $(MAKE) -f Makefile.pre generate ) || exit; \ ( cd src/$$pkg && $(MAKE) -f Makefile.pre depend ) || exit; \ ( cd src/$$pkg && $(MAKE) opt ) || exit; \ done .PHONY: doc doc: for pkg in src/*/.; do \ test ! -f $$pkg/Makefile -o -f $$pkg/doc-ignore || \ { ( cd $$pkg && $(MAKE) -f Makefile.pre generate ) || exit; \ ( cd $$pkg && $(MAKE) -f Makefile.pre depend ) || exit; \ ( cd $$pkg && $(MAKE) doc-dump ) || exit; \ }; \ done cd doc; $(MAKE) doc .PHONY: tools tools: ( cd tools/cppo-$(CPPO_VERSION) && rm -f depend && $(MAKE) -f Makefile.pre generate && $(MAKE) all ) ( cd tools/unimap_to_ocaml && $(MAKE) all ) # The following PHONY rule is important for Cygwin: .PHONY: install install: for pkg in $(PKGLIST); do \ ( cd src/$$pkg && $(MAKE) -f Makefile.pre install ) || exit; \ done .PHONY: uninstall uninstall: for pkg in src/*/.; do \ test ! -f $$pkg/Makefile || \ ( cd $$pkg && $(MAKE) -f Makefile.pre uninstall); \ done .PHONY: clean clean: for pkg in src/*/.; do \ test ! -f $$pkg/Makefile || \ ( cd $$pkg && $(MAKE) -f Makefile.pre clean); \ done if test -f doc/Makefile; then cd doc && $(MAKE) clean; fi ( cd tools/cppo-$(CPPO_VERSION) && $(MAKE) clean ) ( cd tools/unimap_to_ocaml && $(MAKE) clean ) .PHONY: clean-doc clean-doc: for pkg in src/*/.; do \ test ! -f $$pkg/Makefile -o -f $$pkg/doc-ignore || \ ( cd $$pkg && $(MAKE) -f Makefile.pre clean-doc); \ done cd doc && $(MAKE) clean-doc .PHONY: CLEAN CLEAN: clean .PHONY: distclean distclean: rm -f Makefile.conf rm -rf tmp for pkg in src/*/.; do \ test ! -f $$pkg/Makefile || \ ( cd $$pkg && $(MAKE) -f Makefile.pre distclean); \ done # That one is for oasis .PHONY: postconf postconf: cat setup.save >>setup.data # phony because VERSION may also change .PHONY: _oasis _oasis: _oasis.in v=`./configure -version`; sed -e 's/@VERSION@/'"$$v/" _oasis.in >_oasis oasis setup ocamlnet-4.1.6/Makefile.rules0000644000175000017500000001566513274252307014563 0ustar gerdgerd# How to invoke compilers and tools: # (May be moved to Makefile.conf if necessary) OCAMLC = $(OCAMLFIND) ocamlc -g $(OCAMLC_OPTIONS) $(INCLUDES) -package "$(REQUIRES)" $(PP_OPTIONS) $(WARNINGS) OCAMLC_MLI= $(OCAMLFIND) ocamlc -g $(OCAMLC_OPTIONS) $(INCLUDES) -package "$(REQUIRES)" $(PP_OPTIONS) $(WARNINGS) OCAMLOPT = $(OCAMLFIND) ocamlopt -g $(OCAMLOPT_OPTIONS) $(INCLUDES) -package "$(REQUIRES)" $(PP_OPTIONS) $(WARNINGS) OCAMLDEP = $(OCAMLFIND) ocamldep $(OCAMLDEP_OPTIONS) $(PP_OPTIONS) OCAMLFIND = ocamlfind OCAMLYACC = ocamlyacc OCAMLLEX = ocamllex OCAMLMKLIB = $(TOP_DIR)/tools/mkstublib OCAMLDOC = $(OCAMLFIND) ocamldoc $(OCAMLDOC_OPTIONS) $(PP_OPTIONS) STUBCC = $(TOP_DIR)/tools/stubcc -ocamlc ocamlc # CPPO: is set by Makefile.conf # Set here which warnings we want to have: # 3: whether to report deprecated features. This is disabled because we are # massively using mutable strings (deprecated in 4.02) # 25: "all clauses guarded". I like this. #WARNINGS = -w -3-25 WARNINGS = -w -25 TOOLS_DIR = $(TOP_DIR)/tools COLLECT_FILES = $(TOOLS_DIR)/collect_files # To be overridden by the command line: INC_NETSYS = -I $(TOP_DIR)/src/netsys INC_NETSTRING = -I $(TOP_DIR)/src/netstring INC_EQUEUE = -I $(TOP_DIR)/src/equeue INC_EQUEUE_SSL = -I $(TOP_DIR)/src/equeue-ssl INC_NETCGI2 = -I $(TOP_DIR)/src/netcgi2 INC_NETCGI2_APACHE = -I $(TOP_DIR)/src/netcgi2-apache INC_NETPLEX = -I $(TOP_DIR)/src/netplex INC_NETCAMLBOX = -I $(TOP_DIR)/src/netcamlbox INC_RPC = -I $(TOP_DIR)/src/rpc INC_SHELL = -I $(TOP_DIR)/src/shell INC_NETGSSAPI = -I $(TOP_DIR)/src/netgssapi # Standard definitions and rules XOBJECTS = $(OBJECTS:.cmo=.cmx) POBJECTS = $(OBJECTS:.cmo=.p.cmx) ARCHIVE ?= $(PKGNAME) .PHONY: all opt all-mt-vm opt-mt-vm all-mt-posix opt-mt-posix ARCHIVE_CMA ?= $(ARCHIVE).cma ARCHIVE_CMXA ?= $(ARCHIVE).cmxa ARCHIVE_CMXS ?= $(ARCHIVE).cmxs ARCHIVE_P ?= $(ARCHIVE).p ARCHIVE_P_CMXA ?= $(ARCHIVE_P).cmxa ARCHIVE_P_CMXS ?= $(ARCHIVE_P).cmxs MT_TYPE ?= posix HAVE_GPROF ?= 0 HAVE_SHARED ?= 0 ALL ?= $(ARCHIVE_CMA) $(ALL_EXTRA) \ all-mt-$(MT_TYPE) OPT ?= $(ARCHIVE_CMXA) $(OPT_EXTRA) \ opt-mt-$(MT_TYPE) opt-p-$(HAVE_GPROF) opt-mt-$(MT_TYPE)-p-$(HAVE_GPROF) \ opt-shared-$(HAVE_SHARED) opt-p-$(HAVE_GPROF)-shared-$(HAVE_SHARED) all: $(ALL) opt: $(OPT) all-mt-vm: $(ALLMT_EXTRA) all-mt-posix: $(ALLMT_EXTRA) opt-mt-vm: opt-mt-posix: $(OPTMT_EXTRA) opt-p-0: opt-p-1: $(ARCHIVE_P_CMXA) $(OPTP_EXTRA) opt-mt-vm-p-0: opt-mt-posix-p-0: opt-mt-vm-p-1: opt-mt-posix-p-1: $(OPTMTP_EXTRA) opt-shared-0: opt-shared-1: $(ARCHIVE_CMXS) opt-p-0-shared-0: opt-p-0-shared-1: opt-p-1-shared-0: opt-p-1-shared-1: $(ARCHIVE_P_CMXS) $(ARCHIVE_CMA): $(OBJECTS) $(COBJECTS) if [ "X$(COBJECTS)" = "X" ]; then \ $(OCAMLC) -a -o $(ARCHIVE_CMA) $(OBJECTS); \ else \ $(OCAMLMKLIB) -o $(ARCHIVE) $(OBJECTS) $(COBJECTS) $(LINK_OPTIONS); \ fi $(ARCHIVE_CMXA): $(XOBJECTS) $(COBJECTS) if [ "X$(COBJECTS)" = "X" ]; then \ $(OCAMLOPT) -a -o $(ARCHIVE_CMXA) $(XOBJECTS); \ else \ $(OCAMLMKLIB) -o $(ARCHIVE) $(XOBJECTS) $(COBJECTS) $(LINK_OPTIONS); \ fi $(ARCHIVE_CMXS): $(ARCHIVE_CMXA) $(OCAMLOPT) -linkall -shared -I . -o $(ARCHIVE_CMXS) $(ARCHIVE_CMXA); $(ARCHIVE_P_CMXA): $(XOBJECTS) $(COBJECTS) if [ "X$(COBJECTS)" = "X" ]; then \ $(OCAMLOPT) -a -o $(ARCHIVE_P_CMXA) $(POBJECTS); \ else \ $(OCAMLMKLIB) -o $(ARCHIVE_P) $(POBJECTS) $(COBJECTS) $(LINK_OPTIONS); \ fi $(ARCHIVE_P_CMXS): $(ARCHIVE_P_CMXA) $(OCAMLOPT) -linkall -shared -I . -o $(ARCHIVE_P_CMXS) $(ARCHIVE_P_CMXA); # Files to remove everywhere by "make clean": CLEAN_LIST = *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa *.cmxs dll* packlist-* \ ocamldoc.dump META depend $(PACKLIST) $(GENERATE) # Generic build rules: .SUFFIXES: .cmo .cmi .cmx .ml .mli .mll .mly .c .o .ml.cmx: $(OCAMLOPT) -c $(OCAMLOPT_OPTIONS_FOR_$<) $< && \ [ $(HAVE_GPROF) -eq 0 ] || $(OCAMLOPT) -c -p -o `basename $@ .cmx`.p.cmx $(OCAMLOPT_OPTIONS_FOR_$<) $< .ml.cmo: $(OCAMLC) -c $(OCAMLC_OPTIONS_FOR_$<) $< .mli.cmi: opts="$(OPAQUE)"; \ if [ -f "$$(basename $< .ml)".nopaque ]; then opts=""; fi; \ $(OCAMLC_MLI) -c $(OCAMLC_OPTIONS_FOR_$<) $$opts $< .mll.ml: $(OCAMLLEX) $< .mly.ml: $(OCAMLYACC) $< .c.o: $(STUBCC) -ccopt "-O -g" $(CC_OPTIONS) $(CC_OPTIONS_FOR_$<) $< # We add $(OBJECTS) to the antecedents of ocamldoc.dump to ensure that # the files are compiled. ocamldoc needs the .cmi files, and this is # the simplest way of ensuring that. ocamldoc.dump: $(DOBJECTS) $(OBJECTS) rm -f ocamldoc.dump $(OCAMLDOC) -dump ocamldoc.dump -stars $(INCLUDES) -package "$(REQUIRES)" $(OCAMLDOC_OPTIONS) $(DOBJECTS) || { rm -f ocamldoc.dump; exit 1; } .PHONY: doc-dump doc-dump: @$(MAKE) ocamldoc.dump || { if [ -n "$(DOC_IGNORABLE)" ]; then echo "*** Ignoring error"; else exit 1; fi } # Install rules: .PHONY: install install: @$(MAKE) -f Makefile.pre realinstall .PHONY: realinstall realinstall: install-$(INSTMETHOD) $(INSTOTHER) $(PACKLIST) .PHONY: uninstall uninstall: @$(MAKE) -f Makefile.pre realuninstall .PHONY: realuninstall realuninstall: $(UNINSTOTHER) uninstall-$(INSTMETHOD) .PHONY: install-findlib install-findlib: META files=`$(COLLECT_FILES) *.mli *.cmi *.cma *.cmxa *.cmxs *.a dll* META $(INSTALL_EXTRA)` && \ $(OCAMLFIND) install $(PKGNAME) $$files .PHONY: uninstall-findlib uninstall-findlib: $(OCAMLFIND) remove $(PKGNAME) if [ -n "$(PACKLIST)" ]; then \ if packlist=`ocamlfind query $(PKGNAME)`/$(PACKLIST); then \ if [ -f "$$packlist" ]; then \ files=`cat $$packlist` && \ rm -f $$files; \ echo "$$files" | xargs echo "Removed "; \ fi; \ fi; \ fi META: META.in sed -e 's/@VERSION@/$(VERSION)/' \ -e 's/@AUTHDHREQS@/$(AUTHDHREQS)/' \ -e 's/@PREFERRED_CGI_PKG@/$(PREFERRED_CGI_PKG)/' \ -e 's/@REGEXP_PROVIDER@/$(REGEXP_PROVIDER)/' \ -e 's/@COMPAT_PCRE_PROVIDER@/$(COMPAT_PCRE_PROVIDER)/' \ -e 's/@ZIP_PROVIDER@/$(ZIP_PROVIDER)/' \ META.in >META #---------------------------------------------------------------------- # general rules: DEP_FILES ?= $(wildcard *.ml) $(wildcard *.mli) # Set NODEP to "@true" in order to disable "depend". depend: $(DEP_FILES) $(NODEP) $(OCAMLDEP) *.ml *.mli >$@ || { rm -f $@; exit 1; } .PHONY: clean clean:: genclean rm -f $(CLEAN_LIST) .PHONY: clean-doc clean-doc:: rm -f ocamldoc.dump .PHONY: distclean distclean:: genclean rm -f $(CLEAN_LIST) META rm -f *~ depend .PHONY: generate generate: @$(MAKE) -f Makefile.pre realgenerate .PHONY: realgenerate realgenerate:: $(GENERATE) .PHONY: genclean genclean: @test ! -f Makefile.pre || $(MAKE) -f Makefile.pre realgenclean .PHONY: realgenclean realgenclean:: rm -f $(CLEAN_LIST) META ocamlnet-4.1.6/ChangeLog0000644000175000017500000011121313274252307013526 0ustar gerdgerd2018-05-07 Gerd Stolpmann * Release 4.1.6 * Support for OCaml-4.07 2017-12-06 Gerd Stolpmann * Release 4.1.5 2017-12-05 Gerd Stolpmann * Support for native plugins (cmxs files) (Jaap Boender) * Fix Nettls_gnutls: If a TLS server is configured to authenticate the client, it does not expect that the name in the certificate matches the DNS name of the client. (In particular, the check is not done anymore when [peer_name] is [None].) * Fix: compatibility with library Nettle-3.4 2017-08-14 Gerd Stolpmann * Release 4.1.4 * Fix: incompatibility for OCaml < 4.03 because of -opaque 2017-08-05 Gerd Stolpmann * Release 4.1.3 * Building modules with -opaque flag when we don't install the cmx file * Fix: incompatbility with OCaml-4.05 (O_KEEPEXEC flag) * Fix: the local cppo built has been made compatible with -safe-string 2016-06-19 Gerd Stolpmann * Release 4.1.2 * Fixes so that OCamlnet builds with OCaml-4.03 2016-02-29 Gerd Stolpmann * Release 4.1.1 * Cryptography: adding basic support for public key cryptography (provided by GnuTLS) 2016-01-31 Gerd Stolpmann * Authentication: the module types for SASL and HTTP authentication have been changed to a stateless style. Added an experimental SCRAM module for HTTP. 2016-01-29 Gerd Stolpmann * Nethttp_client: Supporting Digest authentication with SHA-256 as hash algorithm. Supporting Basic authentication with "charset" parameter. 2016-01-24 Gerd Stolpmann * XDR/RPC: supporting that direct mappings can be disabled when this is disadvantegous. For now, this is done for internal RPC services, because direct mappings do not copy values, which would be very surprising here. 2015-12-01 Gerd Stolpmann * Netplex: adding support for so-called internal services. This is a fast and type-safe way of exchanging messages between netplex containers. 2015-11-28 Gerd Stolpmann * ALL MODULES: Transitioning to the new "bytes" type for mutable strings while using "string" only for immutable strings. If compiled with OCaml-4.02 or newer, Ocamlnet is built with the -safe-string compiler option. 2015-11-16 Gerd Stolpmann * Netplex_sharedvar: implementing a new protocol that uses shared memory for announcing variable updates. Also, almost all functions can now be called from controller context. * Netsys_global: new module, for keeping a dictionary of global strings. The dictionary is connected with Netplex_sharedvar, so that the strings can be updated across process boundaries if used with Netplex. * Netsys_polysocket: adding this module 2015-07-05 Gerd Stolpmann * Netsys_polypipe: adding this module 2015-01-05 Gerd Stolpmann * Netasn1_encoder: new module for encding ASN.1 messages -- OCamlnet-4.1 fork 2015-10-03 Gerd Stolpmann * Netnumber: on 64 bit platforms, the functions lt_uint4 and lt_uint8 were wrong. Fixed now. 2015-06-21 Gerd Stolpmann * Release 4.0.4 * GnuTLS: compatibility with GnuTLS-3.4.2 * Nethttpd_plex: the post_add_hook was not called by accident (since OCamlnet-4); this is now fixed. * Nethtml: new option case_sensitive 2015-06-14 Gerd Stolpmann * GnuTLS: initializing the library on-demand. This avoids that /dev/random is kept open all the time since program start, and works around incompatibilities with Netplex. (Thomas Calderon found the problem.) * GnuTLS: setting DH parameters on certificates (this was forgotten in previous releases). (Thomas Calderon found the problem.) 2015-04-27 Gerd Stolpmann * Release 4.0.3 * GnuTLS: supporting GnuTLS versions where SRP is disabled. Supporting GnuTLS-3.4. 2015-02-26 Gerd Stolpmann * Release 4.0.2 * OpenBSD build: fix linker option (Christopher Zimmermann) 2015-02-23 Gerd Stolpmann * Equeue: There is a new method request_proxy_notification, which is only used by Uq_engines.qseq_engine (but unfortunately needs to appear in the public type of the object). This new method permits that chains of Uq_engines.qseq_engine pairs can now be arbitrarily long without consuming too much memory and without the danger of getting stack overflows. This fixes issues where notification chains got too long. In particular, we saw a stack overflow when retrieving a video stream via HTTP. The stream was sent with many chunks, resulting in a long Uq_engines.qseq_engine chain. Implementers of engines can simply define request_proxy_notification as no-ops. 2015-01-27 Gerd Stolpmann * Nethttp.set_content_range: this function generated an incorrect header (the "bytes" word was missing). (Török Edwin) 2015-01-18 Gerd Stolpmann * Release 4.0.1 * _oasis is generated from _oasis.in 2014-12-30 Gerd Stolpmann * Netplex: the Netplex socket directory has a different default if not specified in the config file. * Netshm: the POSIX specifier has now two args * IPv6: automatically enabled if there is a global IPv6 address * Unicode tables: Moved them to a separate netunidata library. This library needs to be linked in for getting access to the tables (this is no longer the default). * Renamings: Http_client, Ftp_client etc. => Nethttp_client, Netftp_client Mimestring => Netmime_string Xdr => Netxdr * Netmime: moved functions to Netmime_header and Netmime_channels * Netmech_scram: Removed the check that passwords only consist of ASCII chars. The user can now call Netsaslprep.saslprep. * Removed: rpc-auth-dh, nethttpd-for-netcgi2 2014-09-28 Gerd Stolpmann * Http_client: the authentication mechanisms are now encapsulated in a first-class module HTTP_MECHANISM. So far, there is Digest authentication in this form. The signature of HTTP_MECHANISM is similar to SASL_MECHANISM. Another visible change is that the insecure Basic authentication is no longer enabled for non-TLS-secured connections. This can be changed back by setting flags, though. Some fixes in the design improve Digest authentication for proxy connections. 2014-09-19 Gerd Stolpmann * Netpop: implementating SASL authentication for POP3. Moved Netpop into netclient. * Netsmtp: implementing SASL authentication for SMTP. Moved Netsmtp into netclient. * Adding a framework for SASL, and a number of mechanisms (PLAIN, CRAM-MD5, DIGEST-MD5, SCRAM-SHA1). 2014-08-31 Gerd Stolpmann * fcgi/scgi/ajp connectors: exporting a handle_connection function, and unifying existing such functions (Christopher Zimmermann) 2014-08-20 Gerd Stolpmann * adding support for modular cryptography (symmetric ciphers and digests) * SCRAM is now implemented with the new crypto providers * removing dependency on Cryptokit * removed library netgssapi; now part of netsys/netstring * removed library netmech-scram; now part of netstring Ocamlnet-4 adds: - new library netgss-system - new library nettls-gnutls - removed equeue-ssl and rpc-ssl - X.500 modules Netasn1, Netdn, Netx509 - Crypto definitions Netsys_crypto_types, Netsys_crypto - TLS modules Netsys_tls, Nettls_support - Support for SASL and GSSAPI - Moved many functions from Uq_engines to new modules in the equeue library (Uq_client, Uq_server, Uq_multiplex, Uq_transfer) Development of Ocamlnet-4 starts ====================================================================== 2014-10-27 Gerd Stolpmann * Release ocamlnet-3.7.7 2014-10-19 Gerd Stolpmann * Netsys_posix.mli.mkfifoat: this function is not supported on OS X 10.10, and this is now detected at config time. 2014-09-16 Gerd Stolpmann * Release ocamlnet-3.7.6 * netstring-pcre: removing dependency on camlp4 (an oversight). 2014-09-06 Gerd Stolpmann * Fixing bad format strings (Damien Doligez) 2014-08-31 Gerd Stolpmann * Release ocamlnet-3.7.5 * Windows: various fixes, including int sizes for 64-bit Windows, the invocation of cppo, and CR characters. Also, unixsupport.h is now used instead of declaring the prototypes directly. (Andreas Hauptmann) * C99: use int64_t instead of int64 in C code. The latter is gone in OCaml-4.02. (Richard Jones) 2014-08-25 Gerd Stolpmann * Build: no longer requiring camlp4 (as it is not distributed with ocaml-4.02) * Fixing some unit tests 2014-08-24 Gerd Stolpmann * Netexn: new exception representation in ocaml-4.02 * Build: renaming file for a configure test to avoid a naming conflict (Richard Jones) 2013-10-01 Gerd Stolpmann * Release OCamlnet-3.7.4 * Https_client and aggressive connection caching: In previous versions there was a problem with the reinitialization of the SSL socket when a former connection was reused. The fix requires an API change of connection_cache: The SSL socket can now be stored with the inactive connection. * Http_client: fixing a bug with connection caching: Address resolution was not taken into account for computing the key in the connection cache. 2013-09-30 Gerd Stolpmann * ssl_exts_stubs.c: releasing global lock on shutdown error (Török Edwin) 2013-09-08 Gerd Stolpmann * Uq_ssl: Fix error path when SSL connection fails during the handshake * NB. Ocamlnet-3.7.1 to 3.7.3 only contain fixes of the build system, and one minor change to make ocaml-4.01 happy 2013-08-30 Gerd Stolpmann * Release Ocamlnet-3.7.0 * Shell.to_file: implement the append flag as documented (bug reported by David Chase) * The libraries netcamlbox and netmulticore are now only built if completely supported. * Porting netcamlbox and netmulticore to ocaml-4.01: There are new implementations in OCaml for caml_modify and caml_initialize that are incompatible with our usage here. Fortunately, these symbols are now weak, and we can override them. This is done in netsys.outofheap, and for the time being we just use the old implementation from ocaml-4.00. 2013-08-30 Gerd Stolpmann * Porting netsys to ocaml-4.01: O_CLOEXEC is now supported if found 2013-08-19 Gerd Stolpmann * Netsys_sem: fix for systems that don't have Netsys_posix.sysconf_open_max (e.g. Win32). (Davild Allsopp) 2013-08-16 Gerd Stolpmann * Http_fs: read method: fixing a problem with resent messages * Http_client: better reaction after "100" responses * Http_client: implementing verbose_response_header, and verbose_response_contents again * Uq_ssl: debugging of payload data (Uq_ssl.Debug.dump_data) 2013-08-13 Gerd Stolpmann * Http_fs: fixing chunked encoding for PUT (this is already done in Http_client) * Nethttp: new function base_code * Http_client: handling the case better that an unknown status code is returned by the server. Before, [response_status] simply raised [Not_found]. Now, the base status is returned instead. 2013-07-31 Gerd Stolpmann * Extending ocamlrpcgen: It supports now six new directives, _lowercase, _uppercase, _capitalize, _prefix, _equals, and _tuple (see documentation). 2013-07-21 Gerd Stolpmann * Release Ocamlnet-3.6.6 * Netplex_container: emits now backtraces if these are enabled. * Http_fs: adding [last_response_status] method * Rpc_client: fixing a potential endless loop when session IDs are reused * Rpc_client: fixing the shutdown when a TCP connection is immediately refused, and GSS-API authentication is active. 2013-06-16 Gerd Stolpmann * Netcgi_fcgi.run: no longer ignoring the sockaddr argument (problem reported by Watanabe Masaki) 2013-06-13 Gerd Stolpmann * Remove duplicate method Netpop.stat 2013-06-06 Gerd Stolpmann * Release Ocamlnet-3.6.5 * Build fix for netstring-pcre 2013-06-03 Gerd Stolpmann * Release Ocamlnet-3.6.4 * Regular expressions: The config switch -enable-pcre no longer switches the default backend to PCRE. The default remains Str, and only Netstring_pcre is additionally built. The new switch -enable-full-pcre has now the stronger meaning of also using PCRE as default backend. New documentation page Regexp explaining this. * Netmcore_basics.txt: more documentation for Netmulticore 2013-05-27 Gerd Stolpmann * Netgzip.ml: Fixing a bug in the inflating pipe (bad calculation of the crc) * Netplex_mbox: implementation of a simple message box allowing communication between Netplex components. This module does neither need Netmulticore nor Netcamlbox, but is relatively slow. 2013-05-13 Gerd Stolpmann * netcgi2-apache: fixing build against apache-2.4. * netcgi2-apache: fixing bug that PKGNAME was incorrect * netcgi2-apache: the directory of the OCaml stdlib is now added via rpath to mod_netcgi_apache.so so that libcamlrun_shared.so is automatically found * Http_client: more liberal interpretation of the "domain" part of authentication keys * src/netsys/netsys_c_poll.c: Fix FD_CLOEXEC (Guillem Jover ) 2013-03-29 Gerd Stolpmann * Http_client authentication: The domain for authentication keys can be set to ["*"]. Also, port number can be omitted in such domains. * Http_client authentication: adding skip_challenges auth style * Uq_engines: New [qseq_engine] class. This is the same as [seq_engine], but it does not forward pure progress events. The operator [++] is now backed by [qseq_engine]. This change fixes performance bugs (e.g. Http_client had problems with HTTP responses consisting of many chunks). 2013-02-12 Gerd Stolpmann * Netmcore, Netmcore_process: also adding a function [run] in in addition to [startup] for jobs that want to return something. With [join_nowait] one can now get the result of the first process. Also updated examples/multicore/create_join.ml. 2013-02-10 Gerd Stolpmann * Netplex_main: new function [run], designed for compute jobs run under Netplex regime * Netdate: adding ISO-8601 week numbering. Fixing test suite and some bugs 2013-01-13 Gerd Stolpmann * Release OCamlnet-3.6.3 * Netmcore_heap.mli: allowing to [add] bigarrays. New function [add_string] for creating uninitialized strings on heaps. New function [add_immutable] for retaining value sharing. * Netsys_mem: New options [Copy_conditionally] and [Keep_atom] for function [init_value]. 2012-12-26 Gerd Stolpmann * Release OCamlnet-3.6.2 * netsys_c_subprocess.c: fixing a deadlock issue (when calling commands via the Shell library) 2012-11-19 Gerd Stolpmann * Netdate: Fix interpretation of the ~localzone argument of several functions. Now the timezone is assumed for the target time, not the calling time * Netdate: Adding localization * Netconversion: Adding functions for converting to lowercase/ uppercase/titlecase, and for case-insensitive comparison 2012-11-07 Gerd Stolpmann * Release OCamlnet-3.6.1 * Fix Netfs.copy: When the copy method throws EXDEV, it is fallen back to a streaming-type copy * Several fixes for OS X * Daemonizer: now using a signal for waiting until the children are up and running * Fixes for OCaml-4.00 2012-09-30 Gerd Stolpmann * Better endianness check as suggested by Matias Giovannini * Fixing handling of `Recv_send_implied sockets in socket_multiplex_controller 2012-08-27 Gerd Stolpmann * netzip: it is now autodetected whether the camlzip library is available under the findlib name "zip" or "camlzip" 2012-07-20 Gerd Stolpmann * Release Ocamlnet-3.6 * Netsys_sem: a new abstraction for emulating anonymous semaphores on systems that only provide named semaphores, like OS X. All users of semaphores inside Ocamlnet now base on Netsys_sem. 2012-07-19 Gerd Stolpmann * reimplementing Netstring_str for the case the Str engine is used. It is now thread-safe without having to use mutexes. * The default is now -disable-pcre * The module Netstring_pcre has been moved to a library of its own, namely netstring-pcre. It is only installed if -enable-pcre 2012-06-27 Gerd Stolpmann * Nethttp.Header.best_media_type: improved (patch by Christopher Zimmemann) 2012-06-22 Gerd Stolpmann * Netsys_mem.alloc_memory_pages: one can now mark the memory pages as executable 2012-05-31 Gerd Stolpmann * src/netsys/configure: disabling POSIX semaphore check for win32 2012-05-26 Gerd Stolpmann * Fixes for OpenBSD (by Christopher Zimmermann) * Netcgi connectors (SCGI, AJP, FCGI): unifying the ~sockaddr and ~port arguments. ~port now also assumes a loopback binding. (Suggested by Christopher Zimmermann). 2012-03-15 Gerd Stolpmann * Allowing posix_spawn again for MacOS. It turns out the number of file actions is limited. If we are above the limit, posix_spawn is not used. 2012-03-01 Gerd Stolpmann * Ssl_exts: adding function for returning the fingerprint of a certificate * Https_client: new verify callback for additional certificate checks 2012-02-29 Gerd Stolpmann * Release Ocamlnet-3.5.1 * Fixing various build problems: - FreeBSD-9: clock_getcpuclockid problem - FreeBSD-9: PATH_MAX problem - Mac OS: disbling posix_spawn (cannot debug this right now) - Linux: adding -lpthread to ocamlopt link flags 2012-02-22 Gerd Stolpmann * Release Ocamlnet-3.5 * Documentation: new Equeue_howto introduction into Equeue/engines 2012-02-21 Gerd Stolpmann * Netplex: new option "greedy_accpepts" for improving the speed of Netplex systems accepting new connections at a very high rate (> 1000/s). * Netplex: the constant workload manager gets the option max_jobs_per_thread. 2012-02-20 Gerd Stolpmann * Netchannels: new option ~pass_through for buffered netchannels * Netshm_data.string_manager: speeding up (using memory_of_bigarray) * Netsys_mem.memory_of_bigarray: added * Netmcore_condition: There is now a second kind of wait_entry allowing it to wait via file descriptor polling. 2012-02-16 Gerd Stolpmann * Http_client: fixing the case that a non-idempotent request needs authentication, but should always be tried again even if reconnect_mode does not allow to create a new connection. * Netplex: making many container methods/functions thread-safe 2012-02-15 Gerd Stolpmann * Uq_mt: this new module coordinates access to shared engine-based resources from multiple threads (e.g. share an RPC client by several threads) * Uq_ssl + Https_client: fixing problem when the client times out while still connecting. Before, the module closed the file descriptor too early. (Thanks to Henry Hughes for reporting.) 2012-02-14 Gerd Stolpmann * XDR/RPC: implemented direct mapping from byte representation to Ocaml value. Use new switch -direct with ocamlrpcgen to enable. 2012-02-10 Gerd Stolpmann * Xdr: additional check against invalid XDR messages. * Xdr: calling Netnumber instead of Rtypes * Netnumber: speeding int8 readers and writers up (only on 64 bit systems) 2012-02-08 Gerd Stolpmann * epoll: Adding support. This is exported as "event aggregator" in Netsys_posix (the API is prepared for other poll implementations). There is also Netsys_pollset_posix.accelerated_pollset. * Netplex: Adding container_event_system and container_run to [processor_hooks] so users can override these functions (for using Lwt in Netplex containers). 2012-02-06 Gerd Stolpmann * Netsys_posix: Adding a second implementation for spawn basing on posix_spawn 2012-02-05 Gerd Stolpmann * Netsys_posix: Adding POSIX clock functions. These allow operations with nanosecond resolution * Netlog and Netdate have been extended to support high resolution clocks. New "nanos" field in Netdate.t. * Netsys_posix: Adding event abstraction. Under Linux this is backed by eventfd and timerfd. For other OS, an emulation with pipes is available. * Netsys_posix: Adding POSIX timers. They can be connected with events (the event is signaled when the timer expires). * Netsys in general: Splitting netsys_c.c up into several files. Improved configure script. * Netplex_log: Using the new standard formatter. 2012-01-23 Gerd Stolpmann * Http_client: forgot to configure Digest authentication for the convenience module (thanks to Paolo Donadeo for finding it) 2012-01-13 Gerd Stolpmann * Fix memory leak: Adding finalizer for Netsys_posix.poll_mem values (thanks to Henry Hughes) * Fix (build): ocamlrpcgen respects existing OCAMLPATH (Dmitry Grebeniuk) 2011-12-30 Gerd Stolpmann * Security: adding limit max_arguments to Netcgi. This is more a general measure of precaution against DoS attacks where a specially crafted POST request contains many keys that collide massively in the hash table. Actually, Ocamlnet is not directly vulnerable; however, application programs can nevertheless be when they access a degenerated hash table. 2011-10-12 Gerd Stolpmann * Release 3.4.1 2011-10-11 Gerd Stolpmann * Rpc_client: new functions get_xid_of_last_call, and abandon_call 2011-09-23 Gerd Stolpmann * rpc-auth-local: Implementing this for more types of OS. * Rpc: fixing some bugs 2011-09-20 Gerd Stolpmann * Rpc_client and Rpc_server: disabling the Nagle algorithm. At the same time, Rpc_transport is improved so it almost never calls write() several times with small strings. 2011-09-10 Gerd Stolpmann * bugfixes in the Netplex shutdown procedure 2011-08-30 Gerd Stolpmann * Uq_io: adding input_lines_e * IPv6 support for Neturl and Uq_resolver. Also fixes in Uq_socks5 and netcgi2. * Netplex: print line number for syntax errors in config files. * Netplex: the method socket_directory returns an absolute path. The method startup_directory is now also available in containers. * Release 3.4 2011-08-29 Gerd Stolpmann * Http_client: one can set a different proxy server for each transport type * Netfs: new methods read_file and write_file, for file-based downloads and uploads, respectively. * Netfs: new method cancel to stop an upload prematurely * Http_fs, Ftp_fs: new method translate to get the URL for a file operation * Ftp_fs: the get_password and get_account functions take the user name as input 2011-08-23 Gerd Stolpmann * Build fixes for Ocaml-3.11. There were some regressions. 2011-08-16 Gerd Stolpmann * netcgi_apache: adding support for Findlib (new directives NetcgiRequire et al) 2011-08-05 Gerd Stolpmann * Released: ocamlnet-3.3.7 2011-08-03 Gerd Stolpmann * Netplex: new workload_hook. It is called whenever a connection is accepted or terminated. * Netplex: new config conn_limit to set the maximum number of connections a container can accept * Netplex: new config gc_when_idle to run Gc.full_major when the container is idle for some time * Reducing memory consumption (Uq_io and users such as Http_client, Netplex, Rpc) by recycling bigarray buffers more quickly * New admin messages netplex.mem.major, netplex.mem.compact, netplex.mem.pools, netplex.mem.stats * Docs netplex_admin.txt 2011-07-29 Gerd Stolpmann * Shell: calling subprograms did not work when multi-threading was enabled because of a caml_leave_blocking_section without prior caml_enter_blocking_section. This is fixed. * Uq_ssl: Changed the method of closing SSL tunnels. Before, a close-notify SSL message was sent, and also expected by the peer before the connection was closed on TCP level. Now, we half-close the TCP connection immediately after sending close-notify. This seems to fix some SSL sessions where the server ignores close-notify, and only reacts on TCP closes. This method of closing seems to be ok with the standard, which is apparently not very precise on SSL closures. * Released: Ocamlnet-3.3.6 2011-07-20 Gerd Stolpmann * Fix filter in Rpc_server: they are no longer accidentally reset for longer TCP messages * Fix Http_client: avoiding an assert when the server immediately responds without awaiting the request * Mimestring: reimplementing the MIME scanner w/o regexps. Also new string processing functions for iterating over lines. * Nethttpd: banning all regexps in message parsing that could cause stack overflows * Nethttpd: Returning better Content-Encoding for statically served files. In particular, the encoding of compressed files is taken into account * Released: Ocamlnet-3.3.5 2011-07-12 Gerd Stolpmann * Shell_sys: Fixing descriptor assignments (avoiding EBADF errors) * Netplex: support for TCP_NODELAY in servers * Released: Ocamlnet-3.3.4 2011-06-24 Gerd Stolpmann * Rpc_client: fix for GSS-API authentication how exceptions are passed back to the caller, avoiding double callbacks * Packing error for Netglob_lex. 2011-06-16 Gerd Stolpmann * Rpc_client: fix when trying several authentication methods: The original call is no longer marked as pending. This avoids a hanging event system. * Netsys_posix: adding with_tty, tty_read_password 2011-06-14 Gerd Stolpmann * Adding Netsockaddr module, and a few conversion functions for socksymbol 2011-06-13 Gerd Stolpmann * Fix: sending HTTP requests in URL-encoded form (thanks to Joel Reymont for pointing it out) * Fix: redirects after POST * Fix: timeouts in Unixqueue_pollset no longer cause failed assertions (thanks to Stéphane Legrand) * Released: Ocamlnet-3.3.3 2011-06-12 Gerd Stolpmann * Fix: Http_client removed the query path from URLs accidentally * Released: Ocamlnet-3.3.2 2011-06-10 Gerd Stolpmann * Released: Ocamlnet-3.3.1 2011-06-10 Gerd Stolpmann * FTP protocol: Finishing Ftp_client (w/ API changes). Adding Ftp_fs * HTTP protocol: adding support for TLS * HTTP protocol: can handle compression automatically * Adding tutorial for Netclient * Using Uq_resolver, finally * Adding Uq_lwt for (limited) compatibility with Lwt * Reorganizing regression test suite 2011-05-06 Gerd Stolpmann * Unixqueue: important bug fixes that were introduced since Ocamlnet-3.2, and affect e.g. Http_client. 2011-04-29 Gerd Stolpmann * Preventing errors "Netchannels: Suppressed error in close_out: Netchannels.Closed_channel" (tentative fix) 2011-04-28 Gerd Stolpmann * Reverting Netencoding.Url to the implementation used in Ocamlnet-2. The new impl introduces some incompatibilities with Neturl. * Ocamlnet can now also be built without PCRE! Just configure with -disable-pcre. 2011-04-14 Gerd Stolpmann * Test release: 3.3.0test1 * Netmulticore: adding a lot of modules for managing shared heaps. Also contains a tutorial now. 2011-03-07 Gerd Stolpmann * Netnumber: better successor of Rtypes, with both big-endian and little-endian support. Rtypes is still available as legacy module * Xdr, Xdr_mstring, Rtypes: have been moved to the "netstring" library part * Adding support for GSS-API: The generic interface is defined in Netgssapi. ONC-RPC support can be found in Rpc_auth_gssapi. The authentication framework of ONC-RPC had to be slightly extended. * Adding the SCRAM authentication method. Also includes an encapsulation as GSS-API method. * Rpc_client: one can now set the user identifier (also for Rpc_proxy) * Rpc_server: added is_dummy * Netsys_rng: secure random numbers on all platforms 2011-01-31 Gerd Stolpmann * Rpc_proxy: if initial_ping is enabled, the calls are queued up in the right order. * Netsys_posix: also allowing flags POSIX_FADV_* for better compatibility with extunix. 2011-01-30 Gerd Stolpmann * Build fixes for FreeBSD 8.1 * Build fixes for Ocaml 3.11 2011-01-17 Gerd Stolpmann * Http_fs: PUT semantics can be better controlled with the If-Match and If-None-Match headers. * Netchannels: Fixing some close_out problems when errors occur while closing 2011-01-04 Gerd Stolpmann * Optimizations (especially async code) * Netplex_sharedvar.dump: new function for debugging 2010-12-23 Gerd Stolpmann * Released: Ocamlnet-3.2 * Http_fs: fixing the case that the channel is closed before everything is downloaded * Netfs: adding `Dummy as value to all flags * Netfs: fixing symlinks in iter and copy_into. * Netglob: behaves better when the pattern encoding is distinct from the filename encoding * Shell_fs: expose input_stream_adapter, output_stream_adapter 2010-12-20 Gerd Stolpmann * Shell_fs: added stream_fs implementation via shell 2010-12-19 Gerd Stolpmann * Http_fs: added stream_fs implementation for HTTP * Netfs: new `Streaming flags for read and write * Netsys_tmp: new module for globally setting where temporary directories are created 2010-12-17 Gerd Stolpmann * Netglob: new module for globbing 2010-12-16 Gerd Stolpmann * Netsys_posix: adding query_langinfo function for basic locale support * Netconversion: new fn: user_encoding * Netfs: new abstraction representing simple filesystems (both local and remote) * Netsys_posix: adding the *at functions (like openat). Also fchdir and fdopendir are new. 2010-12-09 Gerd Stolpmann * Http_client: fixing aggressive connection caching. Also new module Http_client_conncache for extending the functionality of connection caches. 2010-12-06 Gerd Stolpmann * Netdate: Fixing possible exceptions 2010-11-27 Gerd Stolpmann * Netplex bugfixes: services could not be finished that had already no containers * Netplex_semaphore: added destroy. Some functions can now be called from controller context. * Netplex config files: added support for config_tree. No longer defaulting to /etc/netplex. Instead, the suffix ".conf" is appended to the name of the executable. * Adding Netmcore, Netmcore_camlbox 2010-11-23 Gerd Stolpmann * Released: Ocamlnet-3.1 * Rtypes: on 64 bit platforms, negative ints were incorrectly decoded 2010-11-22 Gerd Stolpmann * Uq_engines.Operators: generalized the type of ( >> ) * Netsys_mem: init_value allows now to set the custom_ops struct for custom blocks. Also, some corner cases for bigarrays have been fixed. Renamed Copy_custom to Copy_custom_int. * Netsys_mem: new function copy_value * Netcamlbox: it is now also possible to put messages with int32,int64,nativeint and bigarrays into boxes 2010-10-01 Gerd Stolpmann * Nethttpd: Fixing a bug in Nethttpd_services that prevents in some cases that HTTP connections with pipelining are correctly processed. This bug showed especially up in conjuction with Nethttpd_engine. * Nethttpd: adding encap args in Nethttpd_plex. 2010-09-09 Gerd Stolpmann * Released: Ocamlnet-3.0.3 * Nethttpd: Nethttpd_plex.nethttpd_factory got new arg processor_factory. This allows it to override this factory. (Caveat: this factory must be polymorphic.) * Netsys: netsys_oothr.cma no longer contains a reference to Thread. New archive netsys_oothr_mt.cma for this. * Netsys: resolving circular dep netsys <-> netsys_signal 2010-08-31 Gerd Stolpmann * Released Ocamlnet-3.0.0 ---------------------------------------------------------------------- These are old change logs before the Ocamlnet-3 development started. ---------------------------------------------------------------------- 2008-03-30 Gerd Stolpmann * Adding netzip library * Enhancement: Netplex controllers can send and receive messages * Enhancement: Plugins for Netplex controllers * Adding Netplex_semaphore using the new plugin feature 2008-03-29 Gerd Stolpmann * Adding subchannel logging to Netplex * Adding access logging to Nethttpd 2008-03-04 Gerd Stolpmann * Recognize GNU/kFreeBSD (Stéphane Glondu ) * Fix: Upgraded equeue-ssl for use with ocaml-ssl >= 0.4 (thanks to Debian ocaml maintainers) * [ChriS]: Removal of old cgi stuff * [ChriS]: Preparing netcgi-apache for OCaml 3.11 * Enhancements: Introducing pollsets and Unixqueue2. This work is experimental for now and not yet complete. 2007-11-18 Gerd Stolpmann * Adding syscalls to Netsys: poll, fsync, fdatasync, fadvise, fallocate, ioprio_get/set 2007-11-01 Gerd Stolpmann * Release 2.2.9 * Fix: Http_client becomes more robust when it sees illegal header fields. * Fix: Netshm decodes pairs correctly 2007-07-31 Gerd Stolpmann * Release 2.2.8 * Fix: stop all timers on Netplex shutdown * Improved Netbuffer module * [ChriS]: Improved examples for netcgi2 2007-05-06 Gerd Stolpmann * Fix: For Unix domain sockets, getsockname and getpeername may return EAFNOSUPPORT. This code is generated by the OCaml runtime when it sees an address it does not support. We handle this case as a connected socket with inaccessible address. The problem was reported to happen for MacOS. * Fix: IPv6 is now supported by most functionality. Exception is the SOCKS stuff. * Fix netcgi2: Improving compatibility of Netcgi1_compat, such that nethttpd works together with netcgi2. Porting examples/nethttpd/netplex.ml to nethttpd+netcgi2. * [ChriS]: Netcgi2-apache builds for Apache 2 2007-04-09 Gerd Stolpmann * Release 2.2.7 * Including netcgi2-apache into the release * Fix: Error handling in Nethttpd. * Fix: Build of nethttpd examples 2007-03-28 Gerd Stolpmann * Release 2.2.6 * Improving timeout handling in Rpc_client. TCP timeouts are now handled better. Added Unbound_exception. 2007-03-05 Gerd Stolpmann * Release 2.2.5 * Addition of Rpc_client.set_dgram_destination and get_sender_of_last_response to support unconnected UDP sockets. 2007-02-20 Gerd Stolpmann * Addition of EUC-KR, by Deokhwan Kim 2007-01-18 Gerd Stolpmann * Fix: The library netshm needs bigarray as requirement. 2007-01-07 Gerd Stolpmann * Releases 2.2.3 and 2.2.4: Minor clean-ups in the build system. 2006-12-31 Gerd Stolpmann * Releases 2.2.1 and 2.2.2: Single build fix for Mac OS X. ocamlnet-4.1.6/configure0000755000175000017500000010275613274252307013677 0ustar gerdgerd#! /bin/sh # $Id$ ####################################################################### # Constants: cppo_version=0.9.4 # Helpers: # Split $PATH into words: oldifs="$IFS" IFS=" :" spacepath=`echo $PATH` IFS="$oldifs" in_path () { # Does $1 exist in $PATH? for d in $spacepath; do if test -x "$d/$1"; then return 0 fi done return 1 } get_path () { for d in $spacepath; do if test -x "$d/$1"; then echo "$d/$1" return fi done } ####################################################################### # Defaults #--- Options --- # value 0: off # value 1: on # defaults: set_defaults () { enable_gtk=0 enable_gtk2=0 enable_tcl=0 enable_zip=0 enable_apache=0 enable_gnutls=0 enable_gssapi=0 enable_pcre=0 enable_full_pcre=0 compat_pcre=0 enable_nethttpd=0 bindir=`dirname "$ocamlc"` tcl_defs="" tcl_libs="" disable_core=0 apxs="" apache="" cpp=cpp cpp_set=0 gnutls_cflags="" gnutls_libs="" gnutls_system_trust_file="" gssapi_cflags="" gssapi_libs="" destdir="" } ocamlc=`get_path ocamlc` set_defaults version="4.1.6" exec_suffix="" path_sep=":" ####################################################################### # Option parsing ehelp_gtk="Enable/disable parts that depend on lablgtk" ehelp_gtk2="Enable/disable parts that depend on lablgtk2" ehelp_tcl="Enable/disable parts that depend on tcl/tk" ehelp_gnutls="Enable/disable parts that depend on GnuTLS" ehelp_gssapi="Enable/disable parts that depend on GSSAPI/Kerberos" ehelp_zip="Enable/disable parts that depend on camlzip" ehelp_apache="Enable/disable Apache mod connector (EXPERIMENTAL)" ehelp_pcre="Enable/disable the build against pcre-ocaml" ehelp_full_pcre="Enable/disable the build against pcre-ocaml (no Str)" ehelp_nethttpd="Enable/disable nethttpd web server component (GPL!)" # Which options exist? eoptions for enable/disable eoptions="pcre full_pcre gtk gtk2 tcl gnutls gssapi zip apache nethttpd" # Packages to include anyway: requires="bytes unix" # Directory where to install data files: net_db_dir="" net_db_dir_set=0 check_library () { # $1: the name of the library (findlib) # # $2: a typical file in $incdirs # if [ "$enable_findlib" -gt 0 ]; then ocamlfind query "$1" >/dev/null 2>/dev/null return # else # stdlib=`ocamlc -where` # for dir in $incdirs; do # case "$dir" in # +*) # dir=`echo "$dir" | sed -e "s|^\+|$stdlib/|"` ;; # esac # if [ -f "$dir/$2" ]; then # return 0 # fi # done return 1 # not found # fi } print_options () { for opt in $eoptions; do e="o=\$enable_$opt" eval "$e" uopt=`echo $opt | sed -e 's/_/-/g'` if [ $o -gt 0 ]; then echo " -enable-$uopt" else echo " -disable-$uopt" fi done echo " -bindir $bindir" echo " -datadir $net_db_dir" if [ $enable_tcl -gt 0 ]; then echo " -equeue-tcl-defs \"$tcl_defs\"" echo " -equeue-tcl-libs \"$tcl_libs\"" fi if [ -n "$apxs" ]; then echo " -apxs $apxs" fi if [ -n "$apache" ]; then echo " -apache $apache" fi if [ -n "$gnutls_cflags" ]; then echo " -gnutls-cflags $gnutls_cflags" fi if [ -n "$gnutls_libs" ]; then echo " -gnutls-libs $gnutls_libs" fi if [ -n "$gnutls_system_trust_file" ]; then echo " -gnutls-system-trust-file $gnutls_system_trust_file" fi if [ -n "$gssapi_cflags" ]; then echo " -gssapi-cflags $gssapi_cflags" fi if [ -n "$gssapi_libs" ]; then echo " -gssapi-libs $gssapi_libs" fi echo " -cpp $cpp" } usage () { set_defaults cat <<_EOF_ >&2 usage: ./configure [ options ] _EOF_ for opt in $eoptions; do e="help=\$ehelp_$opt" eval "$e" uopt=`echo $opt | sed -e 's/_/-/g'` echo "-enable-$uopt:" >&2 echo "-disable-$uopt:" >&2 echo " $help" >&2 done cat <<_EOF_ >&2 -bindir dir Install binaries into this directory -datadir dir Install the run-time data file into this directory -equeue-tcl-defs Set C compiler options to find tcl.h (for -enable-tcl) -equeue-tcl-libs Set C compiler options to link against libtcl (for -enable-tcl) -apxs /path/to/apxs Set which apxs to use for -enable-apache -apache /path/to/apache Set which apache executable to use for -enable-apache -gnutls-cflags Flags for the C compiler for GnuTLS -gnutls-libs Libraries for GnuTLS -gnutls-system-trust-file /path/to/certificates.crt File with the certificates that are trusted by default -gssapi-cflags Flags for the C compiler for GSSAPI -gssapi-libs Libraries for GSSAPI -prefer-netcgi2 This option is ignored for compatibility with older versions -cpp Use this C preprocessor program for ocamlrpcgen -compat-pcre Makes the netstring library dependent on netstring-pcre, for better compatibility with old versions of Ocamlnet Defaults are: _EOF_ print_options >&2 exit 1 } check_eopt () { for x in $eoptions; do if [ "$x" = "$1" ]; then return 0 fi done echo "Unknown option: $1" >&2 exit 1 } echo "Welcome to Ocamlnet version $version" >&2 while [ "$#" -gt 0 ]; do case "$1" in -enable-*|--enable-*) opt=`echo "$1" | sed -e 's/--\{0,1\}enable-//' -e 's/-/_/g'` check_eopt "$opt" eval "enable_$opt=2" shift ;; -disable-core|--disable-core) # Intentionally undocumented. disable_core=1 shift ;; -disable-*|--disable-*) opt=`echo "$1" | sed -e 's/--\{0,1\}disable-//' -e 's/-/_/g'` check_eopt "$opt" eval "enable_$opt=-1" shift ;; -with-*|--with*) opt=`echo "$1" | sed -e 's/--\{0,1\}with-//' -e 's/-/_/g'` check_eopt "$opt" eval "enable_$opt=2" shift ;; -without-*|--without*) opt=`echo "$1" | sed -e 's/--\{0,1\}without-//' -e 's/-/_/g'` check_eopt "$opt" eval "enable_$opt=-1" shift ;; -prefix|--prefix) bindir="$2/bin"; shift 2 ;; --prefix=*) p=`echo "$1" | set -e 's/--prefix=//'` bindir="$p/bin"; shift ;; -bindir|--bindir) bindir="$2" shift shift ;; --bindir=*) bindir=`echo "$1" | set -e 's/--bindir=//'` shift ;; -datadir|--datadir) net_db_dir="$2" net_db_dir_set=1 shift; shift ;; --datadir=*) net_db_dir=`echo "$1" | set -e 's/--datadir=//'` net_db_dir_set=1 shift ;; -equeue-tcl-defs|--equeue-tcl-defs) tcl_defs="$tcl_defs $2" shift shift ;; --equeue-tcl-defs=*) tcl_defs=`echo "$1" | set -e 's/--equeue-tcl-defs=//'`" $2" shift ;; -equeue-tcl-libs|--equeue-tcl-libs) tcl_libs="$tcl_libs $2" shift shift ;; --equeue-tcl-libs=*) tcl_libs=`echo "$1" | set -e 's/--equeue-tcl-libs=//'`" $2" shift ;; -apxs|--apxs) apxs="$2" shift shift ;; --apxs=*) apxs=`echo "$1" | set -e 's/--apxs=//'` shift ;; -apache|--apache) apache="$2" shift shift ;; --apache=*) apache=`echo "$1" | set -e 's/--apache=//'` shift ;; -gnutls-cflags|--gnutls-cflags) gnutls_cflags="$2" shift shift ;; --gnutls-cflags=*) gnutls_cflags=`echo "$1" | set -e 's/--gnutls-cflags=//'` shift ;; -gnutls-libs|--gnutls-libs) gnutls_libs="$2" shift shift ;; --gnutls-libs=*) gnutls_libs=`echo "$1" | set -e 's/--gnutls-libs=//'` shift ;; -gnutls-system-trust-file|--gnutls-system-trust-file) gnutls_system_trust_file="$2" shift 2 ;; --gnutls-system-trust-file=*) gnutls_system_trust_file=`echo "$1" | set -e 's/--gnutls-system-trust-file=//'` shift ;; -gssapi-cflags|--gssapi-cflags) gssapi_cflags="$2" shift shift ;; --gssapi-cflags=*) gssapi_cflags=`echo "$1" | set -e 's/--gssapi-cflags=//'` shift ;; -gssapi-libs|--gssapi-libs) gssapi_libs="$2" shift shift ;; --gssapi-libs=*) gssapi_libs=`echo "$1" | set -e 's/--gssapi-libs=//'` shift ;; -prefer-netcgi2|--prefer-netcgi2) # ignore! shift ;; -cpp|--cpp) cpp="$2" cpp_set=1 shift shift ;; --cpp=*) cpp=`echo "$1" | set -e 's/--cpp=//'` cpp_set=1 shift ;; -version|--version) echo "$version" exit 0 ;; -compat-pcre|--compat-pcre) compat_pcre=1 shift ;; -destdir|--destdir) destdir="$2"; shift 2;; --destdir=*) destdir=`echo "$1" | set -e 's/--destdir=//'`; shift;; *) usage esac done ###################################################################### # cleanup rm -f config.cppo ###################################################################### # Check OS with_rpc_xti=0 with_cppo_tweak=0 printf "%s" "Checking operating system... " u=`uname` case "$u" in CYGWIN*) printf "Cygwin, and target is: " exec_suffix=".exe" path_sep=";" # this is only for OCAMLPATH, ";" is correct for Cygwin case `ocamlc -config | grep os_type` in *Win32*) with_cppo_tweak=1 if [ $cpp_set = 0 ]; then cpp=`realpath /bin/cpp | cygpath -m -f -` fi echo "Win32" ;; *) echo "Cygwin" ;; esac ;; MINGW*) echo "MinGW" exec_suffix=".exe" with_cppo_tweak=2 path_sep=";" mingw_lib=`get_path gcc` mingw_lib=`dirname "$mingw_lib"`/../lib OCAMLOPTFLAGS="-ccopt -L\"${mingw_lib}\"" ;; Linux) echo "Linux" ;; *FreeBSD) # also GNU/kFreeBSD echo "FreeBSD" echo echo "*** Note that you might need to load the 'sem' kernel" echo "*** module to make semaphores work: kldload sem" echo ;; NetBSD) echo "NetBSD" ;; SunOS) case `uname -r` in [1234]*) echo "SunOS" ;; *) echo "Solaris" with_rpc_xti=1 ;; esac ;; *) echo "Generic" ;; esac if [ $with_rpc_xti -gt 0 ]; then echo " This OS supports XTI networking" echo " Building rpc-xti" fi ###################################################################### # Check ocamlfind printf "%s" "Checking for findlib... " if ocamlfind query stdlib >/dev/null 2>/dev/null; then echo "found" if [ "$net_db_dir_set" -eq 0 ]; then net_db_dir=`ocamlfind printconf destdir | tr -d '\\r'`/netunidata net_db_dir_set=1 fi else echo "not found" echo "Make sure that ocamlfind is in your PATH, or download findlib" echo "from www.ocaml-programming.de" exit 1 fi if [ "$net_db_dir_set" -eq 0 ]; then net_db_dir="$libdir" net_db_dir_set=1 fi ###################################################################### # Does ocamlopt support multi-threading? printf "%s" "Checking multi-threading support... " mt_type=vm mt_switch="-vmthread" mt_comment="(unsupported)" rm -rf tmp mkdir -p tmp cat <<_EOF_ >tmp/t.ml let _ = Mutex.create();; _EOF_ if ocamlopt -thread -o tmp/t${exec_suffix} ${OCAMLOPTFLAGS} unix.cmxa threads.cmxa tmp/t.ml 2>/dev/null || ocamlc -thread -o tmp/t${exec_suffix} unix.cma threads.cma tmp/t.ml 2>/dev/null; then if tmp/t${exec_suffix} 2>/dev/null; then mt_type=posix mt_switch="-thread" mt_comment="(ok)" fi fi echo "$mt_type $mt_comment" ###################################################################### # Check for cmxs support printf "%s" "Checking whether cmxs is supported... " have_shared=0 if ocamlopt -shared -o .dummy.cmxs >/dev/null 2>/dev/null; then have_shared=1 echo "yes" else echo "no" fi ###################################################################### # Check word size at al printf "%s" "Checking word size... " cat <<_EOF_ >tmp/t.ml print_endline(string_of_int(Sys.word_size)) _EOF_ word_size="$(ocaml tmp/t.ml | tr -d '\r')" echo "$word_size bit" printf "%s" "Checking endianess... " cat <<_EOF_ >tmp/tend.c /* new check from Matías Giovannini */ #include "caml/mlvalues.h" value check(value d) { int i = 1; char *s = (char*) &i; return (s[0] == 0 ? Val_true : Val_false); } _EOF_ cat <<_EOF_ >tmp/t.ml external check : unit -> bool = "check";; let () = exit (if check() then 0 else 1) _EOF_ ( cd tmp ocamlc -custom -o t tend.c t.ml ) || exit if tmp/t; then echo "big" endianess="BIG_ENDIAN" else echo "little" endianess="LITTLE_ENDIAN" fi ###################################################################### printf "Checking for GPROF... " stdlib=`ocamlc -where | tr -d '\r'` if [ -f $stdlib/std_exit.p.cmx ]; then echo "found" have_gprof=1 else echo "not found" have_gprof=0 fi ###################################################################### printf "Checking for attributes... " case `ocamlc -version` in [123].*) echo "no" attrs=0 ;; 4.0[01].*) echo "no" attrs=0 ;; *) echo "yes" attrs=1 ;; esac if [ $attrs -gt 0 ]; then cat <>config.cppo #define DEPRECATED(arg) [@@deprecated arg] \(** @deprecated arg *) EOF else cat <>config.cppo #define DEPRECATED(arg) EOF fi ###################################################################### printf "Checking for immutable strings... " if ocamlc -safe-string >/dev/null 2>/dev/null; then istring=1 echo "yes" else istring=0 echo "no" fi if [ $istring -gt 0 ]; then string_opts="-safe-string" pp_bytes="-D HAVE_BYTES" echo "#define STRING_COPY (fun s -> s)" >> config.cppo else string_opts="" pp_bytes="-U HAVE_BYTES" echo "#define STRING_COPY String.copy" >> config.cppo fi ###################################################################### printf "Checking for String.lowercase_ascii and the like... " cat <tmp/t.ml let s = String.lowercase_ascii "FOO" EOF if ocamlc -c tmp/t.ml >/dev/null 2>/dev/null; then echo "yes" echo "#define STRING_LOWERCASE String.lowercase_ascii" >> config.cppo echo "#define STRING_UPPERCASE String.uppercase_ascii" >> config.cppo echo "#define STRING_CAPITALIZE String.capitalize_ascii" >> config.cppo echo "#define CHAR_LOWERCASE Char.lowercase_ascii" >> config.cppo echo "#define CHAR_UPPERCASE Char.uppercase_ascii" >> config.cppo else echo "no" echo "#define STRING_LOWERCASE String.lowercase" >> config.cppo echo "#define STRING_UPPERCASE String.uppercase" >> config.cppo echo "#define STRING_CAPITALIZE String.capitalize" >> config.cppo echo "#define CHAR_LOWERCASE Char.lowercase" >> config.cppo echo "#define CHAR_UPPERCASE Char.uppercase" >> config.cppo fi ###################################################################### printf "Checking for extensible variants... " cat <tmp/extvariant.ml type t = .. type t += X EOF if ocamlc -c tmp/extvariant.ml >/dev/null 2>/dev/null; then echo "yes" echo "#define HAVE_EXTENSIBLE_VARIANTS" >> config.cppo else echo "no" echo "#undef HAVE_EXTENSIBLE_VARIANTS" >> config.cppo fi ###################################################################### # check whether we have Unix.map_file printf "Checking for Unix.map_file... " mkdir -p tmp cat <<_EOF_ >tmp/t.ml let f = Unix.map_file;; _EOF_ if ocaml unix.cma tmp/t.ml >/dev/null 2>/dev/null; then echo "yes" echo "#define HAVE_UNIX_MAP_FILE" >> config.cppo else echo "no" echo "#undef HAVE_UNIX_MAP_FILE" >> config.cppo fi ###################################################################### # check whether to prefer [@@noalloc] printf "Checking for [@@noalloc]... " mkdir -p tmp cat <<_EOF_ >tmp/t.ml external foo : float -> float = "foo" [@@noalloc] _EOF_ if ocamlc -c tmp/t.ml >/dev/null 2>/dev/null; then mkdir -p tmp cat <<_EOF_ >tmp/t.ml external foo : float -> float = "foo" "noalloc" _EOF_ if ocamlc -c tmp/t.ml >tmp/t.log 2>&1; then if [ -s tmp/t.log ]; then echo "yes" echo '#define NOALLOC [@@noalloc]' >> config.cppo else echo "unclear" echo '#define NOALLOC "noalloc"' >> config.cppo fi else echo "something is wrong" exit 2 fi else echo "no" echo '#define NOALLOC "noalloc"' >> config.cppo fi ###################################################################### # check for -opaque printf "checking for -opaque... " if ocamlc -opaque >/dev/null 2>/dev/null; then echo "present" opaque="-opaque" else echo "not present" opaque="" fi ###################################################################### # Check that pcre is available: if [ $enable_pcre -gt 0 -o $enable_full_pcre -gt 0 ]; then printf "%s" "Checking for PCRE... " if check_library pcre pcre.cmi; then echo "found" # This means to build netstring-pcre have_pcre=1 if [ $enable_full_pcre -gt 0 ]; then # In netstring: Netstring_str uses PCRE as backend regexp_defs="-D HAVE_PCRE" regexp_provider="netstring-pcre" # which again depends on pcre regexp_provider_make="pcre" # also solved via -I to netstring-pcre else # In netstring: Netstring_str uses Str as backend regexp_defs="-D ENABLE_STR_EXTERNALS -D HAVE_PCRE" regexp_provider="str" regexp_provider_make="str" fi else echo "not found" echo "Sorry, PCRE was requested." echo "Get the PCRE-OCaml library from:" echo "http://www.ocaml.info/home/ocaml_sources.html," echo "or disable the build against PCRE-Ocaml (not recommended)". exit 1 fi else # ENABLE_STR_EXTERNALS works for all recent OCaml versions have_pcre=0 regexp_defs="-D ENABLE_STR_EXTERNALS" regexp_provider="str" regexp_provider_make="str" fi compat_pcre_provider="" if [ $compat_pcre -gt 0 ]; then # in this case, netstring is dependent on netstring-pcre for # better compatibility with OCamlnet-3.5 and older. Even if we # did NOT -enable-pcre. compat_pcre_provider="netstring-pcre" fi ###################################################################### # Netsys ( cd src/netsys; ./configure ) ( cd src/rpc-auth-local; ./configure ) ###################################################################### # whether we can support camlboxes and multicore support_outofheap=0 if grep 'OOH_OBJECT = .' src/netsys/Makefile.conf >/dev/null 2>/dev/null; then support_outofheap=1 fi support_semaphores=0 if grep '#define HAVE_POSIX_SEM_NAMED' src/netsys/config.h \ >/dev/null 2>/dev/null; then support_semaphores=1 fi enable_camlbox=0 enable_multicore=0 printf "Checking whether netcamlbox and netmulticore are supported... " if [ $support_outofheap -gt 0 -a $support_semaphores -gt 0 ]; then echo "yes" enable_camlbox=1 enable_multicore=1 else echo "no" fi ###################################################################### # TCL with_equeue_tcl=0 if [ $enable_tcl -gt 0 ]; then printf "%s" "Checking switches for tcl.h... " tcl_defs_1="" for d in $tcl_defs; do tcl_defs_1="$tcl_defs_1 -ccopt '$d'" done rm -rf tmp mkdir -p tmp cat <tmp/t.c #include "tcl.h" main () { } EOF if ( cd tmp; ocamlc $tcl_defs_1 -c t.c >/dev/null 2>/dev/null ) then echo "ok" else echo "not ok" echo echo "Please check -equeue-tcl-defs!" exit 1 fi printf "%s" "Checking switches to link libtcl... " cat <tmp/t.c #include #include #include "tcl.h" do_something () { void (*x)(int); x = Tcl_Exit; exit(0); } EOF cat <tmp/t.ml exit 0 EOF if ( cd tmp ocamlc $tcl_defs_1 -c t.c >/dev/null 2>/dev/null && ocamlc -c t.ml >/dev/null 2>/dev/null && ocamlc -o t -custom t.o t.cmo -cclib "$tcl_libs" ) then if tmp/t; then echo "ok" else echo "not ok (check ldd output of tmp/t)" echo echo "Please check -equeue-tcl-libs!" exit 1 fi else echo "not ok" echo echo "Please check -equeue-tcl-libs!" exit 1 fi with_equeue_tcl=1 fi ###################################################################### # Check lablgtk with_equeue_gtk1=0 if [ $enable_gtk -gt 0 ]; then printf "%s" "Checking for lablgtk... " if ocamlfind query lablgtk >/dev/null 2>/dev/null; then echo "found" with_equeue_gtk1=1 else echo "not found" echo "Required library lablgtk not found!" exit 1 fi fi ###################################################################### # Check lablgtk2 with_equeue_gtk2=0 gtk2_io_add_watch_supports_lists="" if [ $enable_gtk2 -gt 0 ]; then printf "%s" "Checking for lablgtk2... " if ocamlfind query lablgtk2 >/dev/null 2>/dev/null; then echo "found" else echo "not found" echo "Required library lablgtk2 not found!" exit 1 fi printf "%s" "Checking whether lablgtk2 has GMain.Io.remove... " mkdir -p tmp cat <tmp/gtktest.ml let _ = GMain.Io.remove;; EOF if ocamlfind ocamlc -package lablgtk2 -c tmp/gtktest.ml >/dev/null 2>/dev/null; then echo "yes" else echo "no" echo "Your version of lablgtk2 is too old!" exit 1 fi printf "%s" "Checking whether lablgtk2 has GMain.Io.add_watch with list support... " mkdir -p tmp cat <<'EOF' >tmp/gtktest.ml open GMain.Io let _ = (add_watch : cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id);; exit 0 EOF # Note: this newer API is never broken in the sense checked below, i.e. # such lablgtk2 versions do not exist. if ocamlfind ocamlc -package unix,lablgtk2 -linkpkg -o tmp/gtk tmp/gtktest.ml >/dev/null 2>/dev/null && tmp/gtk; then echo "yes" gtk2_io_add_watch_supports_lists="-D GTK2_IO_ADD_WATCH_SUPPORTS_LISTS" else echo "no" printf "%s" "Checking whether lablgtk2's GMain.Io.add_watch is broken... " mkdir -p tmp cat <<'EOF' >tmp/gtktest.ml GMain.Main.init();; let ch = GMain.Io.channel_of_descr (Unix.stdout) in let w = GMain.Io.add_watch ~cond:`OUT ~callback:(fun () -> true) ch in (* add_watch is broken when it just returns Val_unit, and ok when it * returns a positive int *) if (Obj.magic w : int) > 0 then exit 0 else exit 1 EOF if ocamlfind ocamlc -package unix,lablgtk2 -linkpkg -o tmp/gtk tmp/gtktest.ml >/dev/null 2>/dev/null && tmp/gtk; then echo "no" else echo "yes" echo "You should apply the patch-ab-ml_glib.c to lablgtk2 to fix this!" exit 1 fi fi for f in Makefile uq_gtk.ml uq_gtk.mli uq_gtk_helper.ml; do rm -f src/equeue-gtk2/$f ln -s ../equeue-gtk1/$f src/equeue-gtk2 done with_equeue_gtk2=1 fi ###################################################################### # GnuTLS with_gnutls=0 if [ $enable_gnutls -gt 0 ]; then ( cd src/nettls-gnutls GNUTLS_CFLAGS="$gnutls_cflags" GNUTLS_LIBS="$gnutls_libs" GNUTLS_SYSTEM_TRUST_FILE="$gnutls_system_trust_file" ./configure ) if [ $? -eq 0 ]; then with_gnutls=1 # There is now also src/nettls-gnutls/config.mk, which needs to be # appended to Makefile.conf else echo "Required library GnuTLS not found!" exit 1 fi fi ###################################################################### # GSSAPI with_gssapi=0 if [ $enable_gssapi -gt 0 ]; then ( cd src/netgss-system GSSAPI_CFLAGS="$gssapi_cflags" GSSAPI_LIBS="$gssapi_libs" ./configure ) if [ $? -eq 0 ]; then with_gssapi=1 # There is now also src/netgss-system/config.mk, which needs to be # appended to Makefile.conf else echo "Required library for GSSAPI (probably -lkrb5) not found!" exit 1 fi fi ###################################################################### # Check camlzip with_netzip=0 if [ $enable_zip -gt 0 ]; then printf "%s" "Checking for zip/camlzip... " if ocamlfind query zip >/dev/null 2>/dev/null; then echo "found" with_netzip=1 zip_provider=zip else if ocamlfind query camlzip >/dev/null 2>/dev/null; then echo "found" with_netzip=1 zip_provider=camlzip else echo "not found" echo "Required library camlzip not found!" exit 1 fi fi fi ###################################################################### # Check Apache apache_major=0 # otherwise syntax error if [ $enable_apache -gt 0 ]; then printf "Apache mod connector... " # echo "CURRENTLY BROKEN - disabling for now" # enable_apache=0 if [ -z "$apxs" ]; then # guess apxs=`get_path apxs` fi if [ -z "$apache" ]; then # guess apache=`get_path apache` fi if [ -x "$apxs" ] && [ -x "$apache" ]; then apache_major=`$apache -v | head -n1 | sed -e "s,.*/\([1-9]\).*,\1,"` apache_libdir="`$apxs -q LIBEXECDIR`" apache_incdir="`$apxs -q INCLUDEDIR`" apache_confdir="`$apxs -q SYSCONFDIR`" apache_ldflags_shlib="`$apxs -q LDFLAGS_SHLIB`" apache_cc="`$apxs -q CC`" apache_cflags="-I \$(APACHE_INCDIR) \ `$apxs -q CFLAGS` `$apxs -q CFLAGS_SHLIB`" # This is to allow modules residing in the standard ocaml library # directory to be loaded with relative paths. #apache_ocamllibdir=`ocamlfind printconf destdir` apache_ocamllibdir=`ocamlc -where` # The apache module requires the construction of a shared library # embedding the ocaml runtime. On platforms where PIC code differs # from non-PIC, it requires a shared camlrun. Check whether it is # available. See http://caml.inria.fr/mantis/view.php?id=3866 apache_camlrun=camlrun if [ -f "$apache_ocamllibdir/libcamlrun_shared.so" ]; then apache_camlrun=camlrun_shared echo "enabled (Apache $apache_major)" else echo "enabled (Apache $apache_major)" echo -e " WARNING: libcamlrun_shared.so was not found. That \ may prevent the build\n of the apache module on platforms \ where PIC code differs from non-PIC\n such as x86_64, hppa,..." fi # at some point libstr.a was renamed to libcamlstr.a libstr="str" if [ -f "$apache_ocamllibdir/libcamlstr.a" ]; then libstr="camlstr" fi else enable_apache=0 echo "apxs or apache not found" echo " Maybe you need to use the -apache option?" exit 1 fi fi ###################################################################### # cpp echo "Preprocessor for ocamlrpcgen: $cpp" ###################################################################### # Summary echo echo "Effective options:" print_options echo pkglist="netsys netshm netstring netunidata equeue shell rpc-generator rpc rpc-auth-local netclient netcgi2 netplex netcgi2-plex" full_pkglist="$pkglist netstring-pcre rpc-auth-local rpc-xti equeue-tcl equeue-gtk1 equeue-gtk2 nethttpd netzip netcgi2-apache nettls-gnutls netgss-system" if [ $enable_camlbox -gt 0 ]; then pkglist="$pkglist netcamlbox" fi if [ $enable_multicore -gt 0 ]; then pkglist="$pkglist netmulticore" fi if [ $enable_nethttpd -gt 0 ]; then pkglist="$pkglist nethttpd" fi if [ $disable_core -gt 0 ]; then # Omit the core packages: pkglist="" with_rpc_xti=0 fi for opt in rpc_xti $woptions equeue_tcl equeue_gtk1 equeue_gtk2 netzip; do e="o=\$with_$opt" eval "$e" if [ $o -gt 0 ]; then uopt=`echo "$opt" | sed -e 's/_/-/g'` pkglist="$pkglist $uopt" fi done if [ $enable_pcre -gt 0 -o $enable_full_pcre -gt 0 ]; then pkglist="netstring-pcre $pkglist" fi if [ $enable_apache -gt 0 ]; then pkglist="$pkglist netcgi2-apache" fi if [ $enable_gnutls -gt 0 ]; then pkglist="$pkglist nettls-gnutls" fi if [ $enable_gssapi -gt 0 ]; then pkglist="$pkglist netgss-system" fi ###################################################################### # Write Makefile.conf if [ $with_cppo_tweak -ne 0 ]; then # Under Windows, calling cppo by relative path is difficult. If we # use forward slashes, we need to escape these for cmd.exe. If we # use backward slashes, the escaping is difficult for sh+make. # The workaround is to call cppo implicitly by PATH search. xdir="$(readlink -f "$(dirname "$0")")" if [ $with_cppo_tweak -eq 1 ]; then xdir="$(cygpath "${xdir}")" fi xdir="${xdir}/tools/cppo-${cppo_version}" export_path="export PATH:=${xdir}:\$(PATH)" cppo="cppo-ocamlnet.exe" else export_path="" cppo="\$(TOP_DIR)/tools/cppo-${cppo_version}/cppo" fi echo "Writing Makefile.conf" cat <<_EOF_ >Makefile.conf # Makefike.conf written by configure # The Ocamlnet version VERSION = $version # The packages to build in the right order: PKGLIST = $pkglist # All packages: FULL_PKGLIST = $full_pkglist # Whether the OS needs an .exe suffix for executables: EXEC_SUFFIX = $exec_suffix PATH_SEP = $path_sep # Required packages (findlib): REQUIRES += $requires # zip: ZIP_PROVIDER = $zip_provider # Additional options only for ocamlc: OCAMLC_OPTIONS = # Additional options only for ocamlopt: OCAMLOPT_OPTIONS = # Where the ocamlnet lookup tables are to be installed (both findlib # and non-findlib): NET_DB_DIR = $net_db_dir # Where binaries are installed: BINDIR = $bindir # Method of installation: INSTMETHOD = findlib # Multi-threading type: MT_TYPE = $mt_type # whether cmxs is supported: HAVE_SHARED = $have_shared # word size: WORD_SIZE = $word_size # endianess ENDIANESS = $endianess # gprof: HAVE_GPROF = $have_gprof # opaque OPAQUE = $opaque # definition of the DEPRECATED macro PP_DEPRECATED = # strings STRING_OPTS = $string_opts PP_BYTES = $pp_bytes # REGEXP support: REGEXP_DEFS = $regexp_defs HAVE_PCRE = $have_pcre REGEXP_PROVIDER = $regexp_provider REGEXP_PROVIDER_MAKE = $regexp_provider_make COMPAT_PCRE_PROVIDER = $compat_pcre_provider # Compiler switch to enable multi-threading: THREAD = $mt_switch # For -enable-tcl: EQUEUE_TCL_DEFS = $tcl_defs_1 EQUEUE_TCL_LIBS = $tcl_libs # For -enable-gtk2: GTK_EXTRA_DEFINES = $gtk2_io_add_watch_supports_lists # For -enable-apache APACHE_MAJOR = $apache_major APACHE_LIBDIR = $apache_libdir APACHE_OCAMLLIBS = -l$apache_camlrun -ltermcap -lunix -l$libstr APACHE_INCDIR = $apache_incdir APACHE_CONFDIR = $apache_confdir APACHE_LDFLAGS_SHLIB = $apache_ldflags_shlib APACHE_CC = $apache_cc APACHE_CFLAGS = $apache_cflags APACHE_OCAMLLIBDIR = $apache_ocamllibdir APXS = $apxs # ocamlrpcgen OCAMLRPCGEN_CPP = $cpp # cppo: CPPO = $cppo -include \$(TOP_DIR)/config.cppo CPPO_VERSION = $cppo_version $export_path _EOF_ if [ $with_gnutls -gt 0 ]; then cat src/nettls-gnutls/config.mk >>Makefile.conf fi if [ $with_gssapi -gt 0 ]; then cat src/netgss-system/config.mk >>Makefile.conf fi if [ -n "$destdir" ]; then echo "DESTDIR = $destdir" >>Makefile.conf fi rm -f src/netcgi2-apache/config.h ###################################################################### # make oasis happy: setup.save will be picked up by "make postconf" # and will be appended to setup.data. That way the config update # will reach oasis. rm -f setup.save echo "pkg_version=\"$version\"" >>setup.save echo "bindir= \"$bindir\"" >>setup.save echo "datadir=\"$net_db_dir\"" >>setup.save echo "prefix=\"\"" >>setup.save echo "destdir=\"$destdir\"" >>setup.save for opt in $eoptions; do e="o=\$enable_$opt" eval "$e" if [ $o -gt 0 ]; then echo "$opt=\"true\"" >>setup.save else echo "$opt=\"false\"" >>setup.save fi done ###################################################################### # Finish echo echo "Please check Makefile.conf." echo echo "You can now compile Ocamlnet by invoking" echo " make all" echo "for the bytecode compiler, and optionally by invoking" echo " make opt" echo "for the native-code compiler (if supported on your architecture)." echo "Finally, a" echo " make install" echo "will install the package(s)." ocamlnet-4.1.6/src/0000755000175000017500000000000013274252312012540 5ustar gerdgerdocamlnet-4.1.6/src/netstring/0000755000175000017500000000000013274252310014553 5ustar gerdgerdocamlnet-4.1.6/src/netstring/META.in0000644000175000017500000000100613274252307015634 0ustar gerdgerdversion = "@VERSION@" requires = "@REGEXP_PROVIDER@ unix netsys @COMPAT_PCRE_PROVIDER@" description = "Ocamlnet - String processing library" archive(byte) = "netstring.cma" archive(byte,toploop) = "netstring.cma netstring_top.cmo" archive(native) = "netstring.cmxa" archive(native,gprof) = "netstring.p.cmxa" archive(byte,-nonetaccel) += "netaccel.cma netaccel_link.cmo" plugin(byte) = "netstring.cma" plugin(native) = "netstring.cmxs" plugin(native,gprof) = "netstring.p.cmxs" ocamlnet-4.1.6/src/netstring/Makefile0000644000175000017500000000630213274252307016222 0ustar gerdgerdTOP_DIR=../.. include $(TOP_DIR)/Makefile.conf OBJECTS = netconst.cmo netstring_str.cmo netbuffer.cmo netunichar.cmo \ netaux.cmo netstring_tstring.cmo \ netchannels.cmo netchannels_crypto.cmo netsockaddr.cmo \ netdb.cmo netmappings_asn1.cmo netmappings.cmo netconversion.cmo \ netulex.cmo netencoding.cmo netstream.cmo netdate.cmo \ netmime_string.cmo \ nethtml_scanner.cmo nethtml.cmo \ neturl.cmo neturl_ldap.cmo netsaslprep_data.cmo netsaslprep.cmo \ netaddress.cmo netcompression.cmo \ netmime.cmo netmime_header.cmo netmime_channels.cmo \ netsendmail.cmo nethttp.cmo \ netpagebuffer.cmo netfs.cmo netglob_lex.cmo netglob.cmo \ netauth.cmo netnumber.cmo netxdr_mstring.cmo netxdr.cmo \ netasn1.cmo netasn1_encode.cmo netoid.cmo netdn.cmo netx509.cmo \ netascii_armor.cmo netx509_pubkey.cmo netx509_pubkey_crypto.cmo \ nettls_support.cmo \ netgssapi_support.cmo netgssapi_auth.cmo \ netmech_scram.cmo netmech_scram_gssapi.cmo netmech_scram_sasl.cmo \ netmech_scram_http.cmo \ netmech_plain_sasl.cmo netmech_crammd5_sasl.cmo \ netmech_digest.cmo netmech_digest_sasl.cmo \ netmech_digest_http.cmo netmech_gs2_sasl.cmo netmech_krb5_sasl.cmo \ netmech_spnego_http.cmo PKGNAME = netstring REQUIRES += $(REGEXP_PROVIDER_MAKE) bigarray INCLUDES += $(INC_NETSYS) INCLUDES += -I ../netstring-pcre DOBJECTS = netconversion.mli netchannels.mli netstream.mli netmime_string.mli \ netmime.mli netsendmail.mli neturl.mli netaddress.mli netbuffer.mli \ netmime_header.mli netmime_channels.mli neturl_ldap.mli \ netdate.mli netencoding.mli netulex.mli netaccel.mli \ netaccel_link.mli nethtml.mli netstring_str.mli \ netmappings.mli netaux.mli nethttp.mli netpagebuffer.mli \ netfs.mli netglob.mli netauth.mli netsockaddr.mli \ netnumber.mli netxdr_mstring.mli netxdr.mli \ netcompression.mli netunichar.mli netasn1.mli netasn1_encode.mli \ netoid.mli netstring_tstring.mli \ netdn.mli netx509.mli netascii_armor.mli nettls_support.mli \ netmech_scram.mli netmech_scram_gssapi.mli netmech_scram_sasl.mli \ netmech_scram_http.mli \ netgssapi_support.mli netgssapi_auth.mli netchannels_crypto.mli \ netx509_pubkey.mli netx509_pubkey_crypto.mli netsaslprep.mli \ netmech_plain_sasl.mli netmech_crammd5_sasl.mli \ netmech_digest_sasl.mli netmech_digest_http.mli \ netmech_krb5_sasl.mli netmech_gs2_sasl.mli netmech_spnego_http.mli \ netchannels_tut.txt netmime_tut.txt netsendmail_tut.txt \ netulex_tut.txt neturl_tut.txt OCAMLC_OPTIONS += $(STRING_OPTS) OCAMLOPT_OPTIONS += $(STRING_OPTS) PP_OPTIONS = -pp "$(CPPO) $(NETNUMBER_DEFS) $(REGEXP_DEFS) $(PP_BYTES) $(PP_DEPRECATED)" ALL_EXTRA = netaccel.cma netaccel_link.cmo netstring_top.cmo netaccel.cma: netaccel_c.o netaccel.cmo $(OCAMLMKLIB) -o netaccel -oc netaccel_c netaccel_c.o netaccel.cmo NETNUMBER_DEFS = -D WORDSIZE_$(WORD_SIZE) -D HOST_IS_$(ENDIANESS) \ -D USE_NETSYS_XDR OCAMLOPT_OPTIONS_FOR_netbuffer.ml = -inline 10 OCAMLOPT_OPTIONS_FOR_netnumber.ml = -inline 10 OCAMLOPT_OPTIONS_FOR_xdr.ml = -inline 5 OCAMLC_OPTIONS_FOR_netstring_top.ml = -I +compiler-libs include $(TOP_DIR)/Makefile.rules distclean:: $(MAKE) clean include depend ocamlnet-4.1.6/src/netstring/Makefile.pre0000644000175000017500000000366213274252307017015 0ustar gerdgerdTOP_DIR=../.. include $(TOP_DIR)/Makefile.conf PRE = 1 PKGNAME = netstring GENERATE = netconst.ml netglob_lex.ml \ netunichar.ml netmappings_asn1.ml META CLEAN_LIST += $(GENERATE) NETNUMBER_DEFS = -D WORDSIZE_$(WORD_SIZE) -D HOST_IS_$(ENDIANESS) \ -D USE_NETSYS_XDR PP_OPTIONS = -pp "$(CPPO) $(NETNUMBER_DEFS) $(REGEXP_DEFS) $(PP_BYTES) $(PP_DEPRECATED)" INSTALL_EXTRA_CMO = netstring_top \ netaccel_link INSTALL_EXTRA_CMX = netconversion \ netbuffer netnumber netxdr INSTALL_EXTRA = $(INSTALL_EXTRA_CMO:=.cmo) \ $(INSTALL_EXTRA_CMX:=.cmx) $(INSTALL_EXTRA_CMX:=.p.cmx) \ $(INSTALL_EXTRA_CMX:=.o) $(INSTALL_EXTRA_CMX:=.p.o) netconst.ml: netconst.mlp sed -e 's/@VERSION@/$(VERSION)/' netconst.mlp >netconst.ml unicode_charinfo.txt: ocaml ../../tools/unicode_extract.ml > unicode_charinfo.txt netunichar.ml: unicode_charinfo.txt ocaml ../../tools/unicode_charinfo.ml unicode_charinfo.txt \ > netunichar.ml ASN1_MAPPINGS = ../netunidata/mappings/asn1_*.unimap unimap_to_ocaml = $(TOP_DIR)/tools/unimap_to_ocaml/unimap_to_ocaml # The .pmap files are the distributed files. The .unimap files cannot be # distributed because of license conditions. netmappings_asn1.pmap: $(unimap_to_ocaml) \ -o netmappings_asn1.pmap -pmap $(ASN1_MAPPINGS) netmappings_asn1.ml: netmappings_asn1.pmap $(unimap_to_ocaml) \ -o netmappings_asn1.ml netmappings_asn1.pmap # How I created netsaslprep_data.ml: #netsaslprep_data.ml: tmp/CompositionExclusions-3.2.0.txt \ # tmp/UnicodeData-3.2.0.txt # ocaml str.cma ../../tools/saslprep-extract-from-unicode.ml \ # > netsaslprep_data.ml # #tmp/CompositionExclusions-3.2.0.txt: # mkdir -p tmp # cd tmp && \ # wget 'http://www.unicode.org/Public/3.2-Update/CompositionExclusions-3.2.0.txt' # #tmp/UnicodeData-3.2.0.txt: # mkdir -p tmp # cd tmp && \ # wget 'http://www.unicode.org/Public/3.2-Update/UnicodeData-3.2.0.txt' include $(TOP_DIR)/Makefile.rules ocamlnet-4.1.6/src/netstring/netaccel.ml0000644000175000017500000000334013274252307016671 0ustar gerdgerd(* $Id$ *) external int_blit : int array -> int -> int array -> int -> int -> unit = "netstring_int_blit_ml" ;; external int_series : int array -> int -> int array -> int -> int -> int -> unit = "netstring_int_series_byte" "netstring_int_series_ml";; external read_iso88591_str : int -> Netconversion.encoding -> int array -> int array -> string -> int -> int -> (int*int*Netconversion.encoding) = "netstring_read_iso88591_byte" "netstring_read_iso88591_ml" ;; external read_utf8_str : bool -> int array -> int array -> string -> int -> int -> (int*int*Netconversion.encoding) = "netstring_read_utf8_byte" "netstring_read_utf8_ml" ;; let read_iso88591 limit enc = let open Netstring_tstring in let open Netconversion in let read : type s . s tstring_ops -> _ -> _ -> s -> _ -> _ -> _ = fun ops chars blen s pos len -> match ops.kind with | Some String_kind -> read_iso88591_str limit enc chars blen s pos len | _ -> (Netconversion.read_iso88591 limit enc).read ops chars blen s pos len in { Netconversion.read } let read_utf8 is_java = let open Netstring_tstring in let open Netconversion in let read : type s . s tstring_ops -> _ -> _ -> s -> _ -> _ -> _ = fun ops chars blen s pos len -> match ops.kind with | Some String_kind -> read_utf8_str is_java chars blen s pos len | _ -> (Netconversion.read_utf8 is_java).read ops chars blen s pos len in { Netconversion.read } let init() = Netaux.ArrayAux.int_blit_ref := int_blit; Netaux.ArrayAux.int_series_ref := int_series; Netconversion.read_iso88591_ref := read_iso88591; Netconversion.read_utf8_ref := read_utf8;; ocamlnet-4.1.6/src/netstring/netaccel.mli0000644000175000017500000000132513274252307017043 0ustar gerdgerd(* $Id$ *) (** Accelerators for bytecode * * This module can be linked with executables to accelerate * certain functions. In particular, the following functions * will run faster: * * - {!Netaux.ArrayAux.int_blit} * - All conversion functions in {!Netconversion} when they * must read an ISO-8859-1 or UTF-8 encoded string * * It is not recommended to install the accelerators for native * code, however (and with the distributed build rules, this * is not done). * * To link this module, you must name both [netaccel.cma] and * [netaccel_link.cmo] explicitly on the ocamlc command line * (after [netstring.cma]). * If you use [findlib], this is done automatically. *) (**/**) val init : unit -> unit ocamlnet-4.1.6/src/netstring/netaccel_c.c0000644000175000017500000001622013274252307017006 0ustar gerdgerd/* $Id$ * * Accelerators, especially for bytecode */ #include "caml/mlvalues.h" #include "caml/alloc.h" #include "caml/memory.h" #include "caml/fail.h" #include "caml/callback.h" /* Accelerator for Netaux.ArrayAux.int_blit */ value netstring_int_blit_ml (value src, value srcpos, value dest, value destpos, value len) { long srcpos_c, destpos_c, len_c, i; CAMLparam5(src,srcpos,dest,destpos,len); srcpos_c = Long_val(srcpos); destpos_c = Long_val(destpos); len_c = Long_val(len); if (len_c < 0 || srcpos_c < 0 || srcpos_c+len_c > Wosize_val(src) || destpos_c < 0 || destpos_c+len_c > Wosize_val(dest)) invalid_argument("Netaccel.int_blit"); if (src != dest || destpos_c <= srcpos_c) { for (i=0; i=0; i--) { Field(dest, destpos_c + i) = Field(src, srcpos_c + i); } } CAMLreturn(Val_unit); } /* Accelerator for Netaux.ArrayAux.int_series */ value netstring_int_series_ml (value src, value srcpos, value dest, value destpos, value len, value n) { long srcpos_c, destpos_c, len_c, n_c, i, s; CAMLparam5(src,srcpos,dest,destpos,len); CAMLxparam1(n); srcpos_c = Long_val(srcpos); destpos_c = Long_val(destpos); len_c = Long_val(len); n_c = Long_val(n); if (len_c < 0 || srcpos_c < 0 || srcpos_c+len_c > Wosize_val(src) || destpos_c < 0 || destpos_c+len_c > Wosize_val(dest)) invalid_argument("Netaccel.int_series"); s = n_c; for (i=0; i string_length(s_in)) invalid_argument("Netaccel.read_iso88591"); m = l_in_c; if (slice_char_len < m) m = slice_char_len; for (k=0; k maxcode_c) { Field(slice_char, k) = Val_long(-1); r = alloc_tuple(3); Store_field(r, 0, Val_long(k)); Store_field(r, 1, Val_long(k)); Store_field(r, 2, enc); raise_with_arg(*caml_named_value("Netconversion.Malformed_code_read"), r); }; Field(slice_char, k) = Val_int((signed int) ch); }; if (m < slice_char_len) { Field(slice_char, m) = Val_long(-1); }; r = alloc_tuple(3); Store_field(r, 0, Val_long(m)); Store_field(r, 1, Val_long(m)); Store_field(r, 2, enc); CAMLreturn(r); } value netstring_read_iso88591_byte (value *argv, int argn) { return netstring_read_iso88591_ml(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); } /* Accelerator for Netconversion.read_utf8 */ /* The exception Netconversion.Malformed_code_read must have been * registered with Callback. */ value netstring_read_utf8_ml (value is_java, value slice_char, value slice_blen, value s_in, value p_in, value l_in) { long is_java_c, p_in_c, l_in_c; long slice_char_len, p, p_max, n_ret, n; long k_inc, cp; unsigned char ch, ch2, ch3, ch4; CAMLparam5(is_java, slice_char, slice_blen, s_in, p_in); CAMLxparam1(l_in); CAMLlocal1(r); is_java_c = Long_val(is_java); p_in_c = Long_val(p_in); l_in_c = Long_val(l_in); slice_char_len = Wosize_val(slice_char); if (slice_char_len != Wosize_val(slice_blen)) invalid_argument("Netaccel.read_utf8"); if (p_in_c < 0 || l_in_c < 0 || p_in_c + l_in_c > string_length(s_in)) invalid_argument("Netaccel.read_utf8"); p = p_in_c; p_max = p_in_c + l_in_c; n = 0; n_ret = (-1); while (p < p_max && n < slice_char_len) { k_inc = 0; ch = Byte_u(s_in, p); if (ch == 0) { if (is_java_c) goto malformed_code; Field(slice_char, n) = Val_int(0); k_inc = 1; } else if (ch <= 127) { Field(slice_char, n) = Val_int((int) ch); k_inc = 1; } else if (ch <= 223) { if (p+1 < p_max) { ch2 = Byte_u(s_in, p+1); if (is_java_c && ch == 0x80 && ch2 == 0xc0) { Field(slice_char, n) = Val_int(0); k_inc = 2; } else { if (ch2 < 0x80 || ch2 >= 0xc0) goto malformed_code; cp = ((ch & 0x1f) << 6) | (ch2 & 0x3f); if (cp < 0x80) goto malformed_code; Field(slice_char, n) = Val_int((int) cp); k_inc = 2; } } } else if (ch <= 239) { if (p+2 < p_max) { ch2 = Byte_u(s_in, p+1); ch3 = Byte_u(s_in, p+2); if (ch2 < 0x80 || ch2 >= 0xc0) goto malformed_code; if (ch3 < 0x80 || ch3 >= 0xc0) goto malformed_code; cp = ((ch & 0xf) << 12) | ((ch2 & 0x3f) << 6) | (ch3 & 0x3f); if (cp < 0x800) goto malformed_code; if (cp >= 0xd800 && cp < 0xe000) goto malformed_code; if (cp >= 0xfffe && cp <= 0xffff) goto malformed_code; Field(slice_char, n) = Val_int((int) cp); k_inc = 3; } } else if (ch <= 247) { if (p+3 < p_max) { ch2 = Byte_u(s_in, p+1); ch3 = Byte_u(s_in, p+2); ch4 = Byte_u(s_in, p+3); if (ch2 < 0x80 || ch2 >= 0xc0) goto malformed_code; if (ch3 < 0x80 || ch3 >= 0xc0) goto malformed_code; if (ch4 < 0x80 || ch4 >= 0xc0) goto malformed_code; cp = ((ch & 7) << 18) | ((ch2 & 0x3f) << 12) | ((ch3 & 0x3f) << 6) | (ch4 & 0x3f); if (cp < 0x10000) goto malformed_code; if (cp >= 0x110000) goto malformed_code; Field(slice_char, n) = Val_int((int) cp); k_inc = 4; } } else goto malformed_code; if (k_inc > 0) { Field(slice_blen, n) = Val_int((int) k_inc); p += k_inc; n++; } else { n_ret = n; n = slice_char_len; } }; if (n_ret == (-1)) n_ret = n; if (n_ret < slice_char_len) { Field(slice_char, n_ret) = Val_long(-1); } r = alloc_tuple(3); Store_field(r, 0, Val_long(n_ret)); Store_field(r, 1, Val_long(p-p_in_c)); Store_field(r, 2, hash_variant("Enc_utf8")); CAMLreturn(r); malformed_code: Field(slice_char, n) = Val_long(-1); r = alloc_tuple(3); Store_field(r, 0, Val_long(n)); Store_field(r, 1, Val_long(p-p_in_c)); Store_field(r, 2, hash_variant("Enc_utf8")); raise_with_arg(*caml_named_value("Netconversion.Malformed_code_read"), r); /* Cannot reach this point! */ CAMLreturn(Val_unit); } value netstring_read_utf8_byte (value *argv, int argn) { return netstring_read_utf8_ml(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } ocamlnet-4.1.6/src/netstring/netaccel_link.ml0000644000175000017500000000003613274252307017705 0ustar gerdgerd(* $Id$ *) Netaccel.init();; ocamlnet-4.1.6/src/netstring/netaccel_link.mli0000644000175000017500000000015213274252307020055 0ustar gerdgerd(* $Id$ *) (** Enables accelerator module [Netaccel] * * This module exists for technical reasons. *) ocamlnet-4.1.6/src/netstring/netaddress.ml0000644000175000017500000001371013274252307017251 0ustar gerdgerd(* Addresses indicate the senders and recipients of messages and * correspond to either an individual mailbox or a group of * mailboxes. *) type local_part = string type domain = string type addr_spec = local_part * domain option class mailbox ?(name : string option) (route : string list) (spec : addr_spec) = object method name = match name with Some s -> s | _ -> raise Not_found method route = route method spec = spec end class group (name : string) (mailboxes : mailbox list) = object method name = name method mailboxes = mailboxes end type t = [ `Mailbox of mailbox | `Group of group ] let mbox_addr_spec spec = `Mailbox (new mailbox [] spec) let mbox_route_addr personal (route, spec) = `Mailbox (new mailbox ?name:personal route spec) open Netmime_string let rev = List.rev exception Parse_error of int * string let parse string = let scanner = create_mime_scanner ~specials:specials_rfc822 ~scan_options:[] string in (* manage lookahead token *) let lookahead_et, lookahead = let et, t = Netmime_string.scan_token scanner in ref et, ref t in let next () = let et, t = Netmime_string.scan_token scanner in lookahead_et := et; lookahead := t in let peek () = !lookahead in (* parsing error - some kind of location/error recovery? *) let error s = let pos = Netmime_string.get_pos !lookahead_et in raise (Parse_error (pos, s)) in (* parse a list of elements *) let list elem next acc = next (elem () :: acc) in (* match a special token for a character *) let special c = match peek () with | Special c' when c = c' -> next () | _ -> error (Printf.sprintf "expecting '%c'" c) in (* main entry point *) let rec address_list acc = match peek () with | End -> rev acc | _ -> list address next_address acc and next_address acc = match peek () with | End -> rev acc | Special ',' -> next (); address_list acc | _ -> error "expecting ','" (* RFC-1123 section 5.2.15: syntax definition of "mailbox" is changed to allow route address with no phrase *) and address () = match peek () with | (Atom _ | QString _) -> address1 () | Special '<' -> mbox_route_addr None (route_addr ()) | Special ',' -> next (); address () (* RFC 2822 section 4.4: support for "null" members *) | _ -> error "expecting address" and address1 () = let w0 = word () in match peek () with | Special '@' -> mbox_addr_spec (w0, Some (at_domain ())) | Special ('<'|':') -> address2 (w0) | Special '.' -> next (); mbox_addr_spec (addr_spec [w0]) | (Atom _ | QString _) -> address2 (phrase [w0]) | _ -> error "syntax error" and address2 name = match peek () with | Special '<' -> mbox_route_addr (Some name) (route_addr ()) | Special ':' -> next (); group name | _ -> error "expecting '<' or ':'" and group name = let mboxes = mailbox_list_opt () in special ';'; `Group (new group name mboxes) and mailbox_list_opt () = match peek () with | Special ';' -> [] | _ -> list mailbox next_mailbox [] and next_mailbox acc = match peek () with | Special ',' -> next (); list mailbox next_mailbox acc | _ -> rev acc (* reuse parsing code for address () and filter out group response *) and mailbox () = match address () with | `Mailbox m -> m | _ -> error "expecting mailbox" and route_addr () = special '<'; let x = match peek () with | (Atom _ | QString _) -> let spec = addr_spec [] in ([], spec) | Special '@' -> let r = route () in let spec = addr_spec [] in (r, spec) | _ -> error "expecting local part or route address" in special '>'; x and route () = let r = at_domain_list [] in special ':'; r and addr_spec acc = let lp = local_part acc in match peek () with | Special '@' -> (lp, Some (at_domain ())) | _ -> (lp, None) and local_part acc = list word next_local_part acc and next_local_part acc = match peek () with | Special '.' -> next (); local_part acc | _ -> String.concat "." (rev acc) and at_domain_list acc = list at_domain next_at_domain_list acc and next_at_domain_list acc = match peek () with | Special ',' -> next (); at_domain_list acc | _ -> rev acc and at_domain () = special '@'; domain [] and domain acc = list subdomain next_subdomain acc and next_subdomain acc = match peek () with | Special '.' -> next (); domain acc | _ -> String.concat "." (rev acc) and subdomain () = match peek () with | Atom s -> next (); s | DomainLiteral s -> next (); s | _ -> error "expecting atom or domain" and phrase acc = list word_or_dot next_phrase acc and next_phrase acc = match peek() with | (Atom _ | QString _ | Special '.') -> phrase acc | _ -> String.concat " " (rev acc) (* RFC 2822 section 4.1: support for '.' often used for initials in names *) and word_or_dot () = match peek () with | Atom s -> next (); s | QString s -> next (); s | Special '.' -> next (); "." | _ -> error "expecting atom or quoted-string" and word () = match peek () with | Atom s -> next (); s | QString s -> next (); s | _ -> error "expecting atom or quoted-string" in address_list [] ocamlnet-4.1.6/src/netstring/netaddress.mli0000644000175000017500000000513113274252307017420 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) (** Parsing of mail addresses *) (** Addresses indicate the senders and recipients of messages and * correspond to either an individual mailbox or a group of * mailboxes. *) type local_part = string (** Usually the user name *) type domain = string (** The domain of the mailbox *) type addr_spec = local_part * domain option (** The pair [local_part\@domain] as O'Caml type. The domain may be * missing. *) (** A [mailbox] has a name, optionally a route (not used nowadays), and * a formal address specification. * * Create a [mailbox] with * * [ new mailbox ~name route addr_spec ] * * Pass [route = []] if not used (formerly, routes were used to specify * the way the mail should take from the sender to the receiver, and * contained a list of hostnames/IP addresses). *) class mailbox : ?name:string -> string list -> addr_spec -> object method name : string (** The name of the mailbox. Raises [Not_found] if not set *) method route : string list (** The route to the mailbox *) method spec : addr_spec (** The formal address specification *) end (** A [group] has a name, and consists of a number of mailboxes. * * Create a group with [new group name mailboxes]. *) class group : string -> mailbox list -> object method name : string (** The name of the group *) method mailboxes : mailbox list (** The member mailboxes *) end (** The union of [mailbox] and [group] *) type t = [ `Mailbox of mailbox | `Group of group ] exception Parse_error of int * string (** A parsing error. The [int] is the position in the parsed string *) val parse : string -> t list (** Parse a list of addresses in string representation, and return * them as list of mailboxes or groups. * * Examples: * - [parse "gerd\@gerd-stolpmann.de"] returns a single [mailbox] * without name and route, and the given spec * - [parse "Gerd Stolpmann "] returns a * single [mailbox] with name and spec, but without route * - [parse "abc\@def.net, ghi"] returns two [mailbox]es without * name and route, and the two specs. The second address only * has a local part, but no domain. * - [parse "g:abc\@def.net, Me ;, gs\@npc.de"] * returns one group [g] with members [abc\@def.net] and * [me\@domain.net], and another [mailbox] [gs\@npc.de]. * * Old-style naming of mailboxes is not supported * (e.g. "gerd\@gerd-stolpmann.de (Gerd Stolpmann)" - the part * in parentheses is simply ignored. *) ocamlnet-4.1.6/src/netstring/netascii_armor.ml0000644000175000017500000001260313274252307020114 0ustar gerdgerd(* $Id$ *) type armor_type = [ `Plain | `Base64 | `OpenPGP ] type armored_message = [ `Plain of Netmime.mime_body | `Base64 of Netmime.mime_body | `OpenPGP of Netmime.mime_header * Netmime.mime_body * int ] type armored_message_ro = [ `Plain of Netmime.mime_body_ro | `Base64 of Netmime.mime_body_ro | `OpenPGP of Netmime.mime_header_ro * Netmime.mime_body_ro * int ] type armor_spec = (string * armor_type) list let begin_re = Netstring_str.regexp "^-----BEGIN \\(.*\\)-----[ \t\r]*$" let end_re = Netstring_str.regexp "^-----END \\(.*\\)-----[ \t\r]*$" let cksum_re = Netstring_str.regexp "^=\\([A-Za-z0-9+/=]+\\)[ \t\r]*$" let parse spec (ch : Netchannels.in_obj_channel) = let rec next_begin_boundary() = let line_opt = try Some(ch # input_line()) with End_of_file -> None in match line_opt with | None -> [] | Some line -> if line <> "" && line.[0] = '-' then match Netstring_str.string_match begin_re line 0 with | None -> next_begin_boundary() | Some m -> let tag = Netstring_str.matched_group m 1 line in let armor_type_opt = try Some(List.assoc tag spec) with Not_found -> None in ( match armor_type_opt with | None -> next_begin_boundary() | Some armor_type -> read_message tag armor_type ) else next_begin_boundary() and read_message tag armor_type = let body = new Netmime.memory_mime_body "" in let body_ch = body # open_value_wr() in match armor_type with | `Plain -> let followup code = body_ch # close_out(); match code with | `Error -> [] | `End -> let body_ro = (body :> Netmime.mime_body_ro) in (tag, `Plain body_ro) :: next_begin_boundary() | `End_cksum _ -> assert false in parse_message_body ~enable_checksum:false ~followup tag armor_type body_ch | `Base64 -> let filter = new Netencoding.Base64.decoding_pipe ~accept_spaces:true () in let base64_ch = new Netchannels.output_filter filter body_ch in let followup code = base64_ch # close_out(); body_ch # close_out(); match code with | `Error -> [] | `End -> let body_ro = (body :> Netmime.mime_body_ro) in (tag, `Base64 body_ro) :: next_begin_boundary() | `End_cksum _ -> assert false in parse_message_body ~enable_checksum:false ~followup tag armor_type base64_ch | `OpenPGP -> assert false (* TODO *) and is_expected_end_boundary line tag = match Netstring_str.string_match end_re line 0 with | None -> false | Some m -> let real_tag = Netstring_str.matched_group m 1 line in real_tag = tag and parse_message_body ~enable_checksum ~followup tag armor_type out_ch = let rec parse() = let line_opt = try Some(ch # input_line()) with End_of_file -> None in match line_opt with | None -> followup `Error | Some line -> let checksum_opt = if enable_checksum && line <> "" && line.[0] = '=' then match Netstring_str.string_match cksum_re line 0 with | Some m -> let sum = Netstring_str.matched_group m 1 line in if String.length sum = 4 then try Some(Netencoding.Base64.decode sum) with _ -> None else None | None -> None else None in match checksum_opt with | None -> if is_expected_end_boundary line tag then followup `End else ( out_ch # output_string line; out_ch # output_string "\n"; parse() ) | Some checksum -> assert(String.length checksum = 3); let v = ((Char.code checksum.[0]) lsl 16) lor ((Char.code checksum.[1]) lsl 8) lor (Char.code checksum.[2]) in let line_opt = try Some(ch # input_line()) with End_of_file -> None in ( match line_opt with | None -> followup `Error | Some line -> if is_expected_end_boundary line tag then followup (`End_cksum v) else followup `Error ) in parse() in next_begin_boundary() ocamlnet-4.1.6/src/netstring/netascii_armor.mli0000644000175000017500000000325113274252307020264 0ustar gerdgerd(* $Id$ *) (** Messages with ASCII armor *) (** There are various forms of ASCII-armored messages: - PEM messages (privacy enhanced mail) - a historic message format - OpenPGP messages. This type of message has a header, a BASE-64-encoded body, and a checksum. - X.509 keys. These just use BASE-64. *) type armor_type = [ `Plain | `Base64 | `OpenPGP ] type armored_message = [ `Plain of Netmime.mime_body | `Base64 of Netmime.mime_body | `OpenPGP of Netmime.mime_header * Netmime.mime_body * int ] (** Messages: - [`Plain m]: The body [m] is written as-is - [`Base64 m]: The body [m] needs to be BASE-64-encoded in order to create the ASCII armor - [`OpenPGP(h,m,chksum)]: There is a header [h], a body [m] which will be BASE-64-encoded, and a checksum [chksum] *) type armored_message_ro = [ `Plain of Netmime.mime_body_ro | `Base64 of Netmime.mime_body_ro | `OpenPGP of Netmime.mime_header_ro * Netmime.mime_body_ro * int ] (** The read-only version of [armored_message] *) type armor_spec = (string * armor_type) list (** Which types of armor to decode, and how. The strings are the identifiers in the boundaries, e.g. include "PRIVACY-ENHANCED MESSAGE" if the boundaries are "-----BEGIN PRIVACY-ENHANCED MESSAGE-----" and "-----END PRIVACY-ENHANCED MESSAGE-----". For every type you can define the [armor_type]. *) val parse : armor_spec -> Netchannels.in_obj_channel -> (string * armored_message_ro) list (** Parses the channel, and returns all messages that are enabled in the specification. The channel is read line-by-line. *) ocamlnet-4.1.6/src/netstring/netasn1.ml0000644000175000017500000010172513274252307016472 0ustar gerdgerd(* $Id$ *) exception Out_of_range exception Parse_error of int exception Header_too_short module Type_name = struct type type_name = | Bool | Integer | Enum | Real | Bitstring | Octetstring | Null | Seq | Set | OID | ROID | ObjectDescriptor | External | Embedded_PDV | NumericString | PrintableString | TeletexString | VideotexString | VisibleString | IA5String | GraphicString | GeneralString | UniversalString | BMPString | UTF8String | CharString | UTCTime | GeneralizedTime end module Value = struct type pc = Primitive | Constructed type value = | Bool of bool | Integer of int_value | Enum of int_value | Real of real_value | Bitstring of bitstring_value | Octetstring of string | Null | Seq of value list | Set of value list | Tagptr of tag_class * int * pc * Netstring_tstring.tstring_polybox * int * int | Tag of tag_class * int * pc * value | ITag of tag_class * int * value | OID of int array | ROID of int array | ObjectDescriptor of string | External of value list | Embedded_PDV of value list | NumericString of string | PrintableString of string | TeletexString of string | VideotexString of string | VisibleString of string | IA5String of string | GraphicString of string | GeneralString of string | UniversalString of string | BMPString of string | UTF8String of string | CharString of string | UTCTime of time_value | GeneralizedTime of time_value and tag_class = | Universal | Application | Context | Private and int_value = string and real_value = string and bitstring_value = string and time_value = U of string | G of string type time_subtype = [ `U | `G ] let rec equal v1 v2 = let open Netstring_tstring in match (v1, v2) with | (Seq s1, Seq s2) -> List.length s1 = List.length s2 && List.for_all2 equal s1 s2 | (Set s1, Set s2) -> (* FIXME: compare the set *) List.length s1 = List.length s2 && List.for_all2 equal s1 s2 | (Tag(c1,t1,pc1,sub1), Tag(c2,t2,pc2,sub2)) -> c1=c2 && t1=t2 && pc1=pc2 && equal sub1 sub2 | (Tagptr(c1,t1,pc1,box1,pos1,len1), Tagptr(c2,t2,pc2,box2,pos2,len2)) -> let Tstring_polybox(ops1,s1) = box1 in let Tstring_polybox(ops2,s2) = box2 in c1=c2 && t1=t2 && pc1=pc2 && ops1.substring s1 pos1 len1 = ops2.substring s2 pos2 len2 | (External s1, External s2) -> List.length s1 = List.length s2 && List.for_all2 equal s1 s2 | (Embedded_PDV s1, Embedded_PDV s2) -> List.length s1 = List.length s2 && List.for_all2 equal s1 s2 | _ -> v1 = v2 let type_of_value = function | Bool _ -> Some Type_name.Bool | Integer _ -> Some Type_name.Integer | Enum _ -> Some Type_name.Enum | Real _ -> Some Type_name.Real | Bitstring _ -> Some Type_name.Bitstring | Octetstring _ -> Some Type_name.Octetstring | Null -> Some Type_name.Null | Seq _ -> Some Type_name.Seq | Set _ -> Some Type_name.Set | OID _ -> Some Type_name.OID | ROID _ -> Some Type_name.ROID | ObjectDescriptor _ -> Some Type_name.ObjectDescriptor | External _ -> Some Type_name.External | Embedded_PDV _ -> Some Type_name.Embedded_PDV | NumericString _ -> Some Type_name.NumericString | PrintableString _ -> Some Type_name.PrintableString | TeletexString _ -> Some Type_name.TeletexString | VideotexString _ -> Some Type_name.VideotexString | VisibleString _ -> Some Type_name.VisibleString | IA5String _ -> Some Type_name.IA5String | GraphicString _ -> Some Type_name.GraphicString | GeneralString _ -> Some Type_name.GeneralString | UniversalString _ -> Some Type_name.UniversalString | BMPString _ -> Some Type_name.BMPString | UTF8String _ -> Some Type_name.UTF8String | CharString _ -> Some Type_name.CharString | UTCTime _ -> Some Type_name.UTCTime | GeneralizedTime _ -> Some Type_name.GeneralizedTime | Tagptr _ | Tag _ | ITag _ -> None let get_int_repr v = v let get_int_b256 v = if v = "\000" then [| |] else Array.init (String.length v) (fun k -> Char.code v.[k]) let get_int64 v = match get_int_b256 v with | [| |] -> 0L | [| x0 |] -> Int64.shift_right (Int64.shift_left (Int64.of_int x0) 56) 56 | i when Array.length i <= 8 -> let x = ref 0L in let shift = ref 64 in for k = 0 to Array.length i - 1 do shift := !shift - 8; x := Int64.logor !x (Int64.shift_left (Int64.of_int i.(k)) !shift); done; Int64.shift_right !x !shift | _ -> raise Out_of_range let max_intL = Int64.of_int max_int let min_intL = Int64.of_int min_int let max_int32L = Int64.of_int32 (Int32.max_int) let min_int32L = Int64.of_int32 (Int32.min_int) let get_int v = let x = get_int64 v in if x > max_intL || x < min_intL then raise Out_of_range; Int64.to_int x let get_int32 v = let x = get_int64 v in if x > max_int32L || x < min_int32L then raise Out_of_range; Int64.to_int32 x let int64_a n = let rec recurse n p bit7 = if n = 0L then if bit7 then ( let a = Array.make (p+1) 0 in a.(0) <- 0; a ) else Array.make p 0 else if n = (-1L) then if bit7 then Array.make p 0 else ( let a = Array.make (p+1) 0 in a.(0) <- 255; a ) else let byte = Int64.to_int (Int64.logand n 0xffL) in let n' = Int64.shift_right n 8 in (* arithm. shift *) let a = recurse n' (p+1) (byte >= 0x80) in let l = Array.length a in a.(l-1-p) <- byte; a in if n = 0L || n = (-1L) then ( [| Int64.to_int (Int64.logand n 0xffL) |] ) else recurse n 0 false let intstr a = let l = Array.length a in let s = Bytes.make l '\x00' in for k = 0 to l-1 do Bytes.set s k (Char.chr a.(k)) done; Bytes.unsafe_to_string s let int64 n = intstr(int64_a n) let int32 n = int64 (Int64.of_int32 n) let int n = int64 (Int64.of_int n) let int_b256_a a = (* normalize the number (express it with as few bytes as possible) *) let l = Array.length a in if l=0 then [| 0 |] else ( let k = ref 0 in while !k < l-1 && ((a.(!k) = 0 && a.(!k+1) < 0x80) || (a.(!k) = 0xff && a.(!k+1) >= 0x80)) do incr k done; Array.sub a !k (l - !k) ) let int_b256 a = intstr (int_b256_a a) let get_real_repr v = v let get_bitstring_repr v = v let get_bitstring_size v = let n_unused = Char.code v.[0] in (String.length v - 1) * 8 - n_unused let get_bitstring_data v = String.sub v 1 (String.length v - 1) let get_bitstring_bits ?size v = let v_size = get_bitstring_size v in let size = match size with | None -> v_size | Some n -> n in Array.init size (fun k -> if k < v_size then let p = k lsr 3 in let q = k land 7 in let x = Char.code v.[ p + 1 ] in (x lsl q) land 0x80 <> 0 else false ) let bitstring_of_bits bits = let buf = Buffer.create 80 in let l = Array.length bits in let p = l land 0x7 in Buffer.add_char buf (Char.chr (if p=0 then 0 else 8-p)); let c = ref 0 in let sh = ref 7 in Array.iteri (fun k bit -> let b = if bit then 1 else 0 in c := !c lor (b lsl !sh); if !sh = 0 then ( Buffer.add_char buf (Char.chr !c); c := 0; sh := 7 ) else decr sh ) bits; if !sh < 7 then Buffer.add_char buf (Char.chr !c); Buffer.contents buf let mask = [| 0b1000_0000; 0b1100_0000; 0b1110_0000; 0b1111_0000; 0b1111_1000; 0b1111_1100; 0b1111_1110; 0b1111_1111; |] let bitstring_of_string s size = if size < 0 then invalid_arg "Netasn1.Value.bitstring_of_string"; let slen = String.length s in let buf = Buffer.create 80 in let p = size land 0x7 in Buffer.add_char buf (Char.chr (if p=0 then 0 else 8-p)); let q = size / 8 in Buffer.add_string buf (String.sub s 0 (min q slen)); if slen < q then Buffer.add_string buf (String.make (q - slen) '\x00'); if p > 0 then ( let last = if slen > q then Char.code (s.[q]) else 0 in let m = mask.(p-1) in let last' = last land m in Buffer.add_char buf (Char.chr last') ); Buffer.contents buf let truncate_trailing_zero_bits s = let slen = String.length s in let size_in = ((slen - 1) lsl 3) - Char.code s.[0] in let size = ref size_in in let k = ref (slen-1) in let cont = ref true in while !cont && !k >= 1 do let b = 8 - (if !k = slen-1 then Char.code s.[0] else 0) in if s.[ !k ] = '\x00' then size := !size - b else ( let c = Char.code s.[ !k ] in let j = ref 0 in while (mask.( !j ) land c) <> c do incr j done; size := !size - b + !j + 1; cont := false ); decr k; done; bitstring_of_string (String.sub s 1 (slen-1)) !size let utc_re = Netstring_str.regexp "^\\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\\(.*\\)$" let gentime_re = Netstring_str.regexp "^\\([0-9][0-9][0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\(.[0-9]+\\)?\\([-Z+].*\\)$" let zone_re = Netstring_str.regexp "^[-+][0-9][0-9][0-9][0-9]$" let get_time_subtype = function | U s -> `U | G s -> `G let get_time_repr = function | U s -> s | G s -> s let get_zone s = if s = "Z" then 0 else ( match Netstring_str.string_match zone_re s 0 with | None -> failwith "Netasn1.Value.get_zone" | Some _ -> let h = int_of_string (String.sub s 1 2) in let m = int_of_string (String.sub s 3 2) in let v = h*60 + m in if s.[0] = '-' then -v else v ) let get_time = function | U s -> (match Netstring_str.string_match utc_re s 0 with | Some m -> let y2 = int_of_string (Netstring_str.matched_group m 1 s) in let year = if y2 >= 50 then 1950 + y2 else 2000 + y2 in let month = int_of_string (Netstring_str.matched_group m 2 s) in let day = int_of_string (Netstring_str.matched_group m 3 s) in let hour = int_of_string (Netstring_str.matched_group m 4 s) in let minute = int_of_string (Netstring_str.matched_group m 5 s) in let second = int_of_string (Netstring_str.matched_group m 6 s) in let zonestr = Netstring_str.matched_group m 7 s in let zone = get_zone zonestr in if month = 0 || month > 12 || day = 0 || day > 31 || hour > 23 || minute > 59 || second > 59 then failwith "Netasn1.Value.get_time"; { Netdate.year; month; day; hour; minute; second; nanos = 0; zone; week_day = (-1) } | None -> failwith "Netasn1.Value.get_time" ) | G s -> (match Netstring_str.string_match gentime_re s 0 with | Some m -> let year = int_of_string (Netstring_str.matched_group m 1 s) in let month = int_of_string (Netstring_str.matched_group m 2 s) in let day = int_of_string (Netstring_str.matched_group m 3 s) in let hour = int_of_string (Netstring_str.matched_group m 4 s) in let minute = int_of_string (Netstring_str.matched_group m 5 s) in let second = int_of_string (Netstring_str.matched_group m 6 s) in let zonestr = Netstring_str.matched_group m 8 s in let zone = get_zone zonestr in if month = 0 || month > 12 || day = 0 || day > 31 || hour > 23 || minute > 59 || second > 59 then failwith "Netasn1.Value.get_time"; let nanos = try let n1 = Netstring_str.matched_group m 7 s in let n2 = String.sub n1 1 (String.length n1 - 1) in let n3 = if String.length n2 > 9 then String.sub n2 0 9 else n2 in let n4 = n3 ^ String.make (9 - String.length n3) '0' in int_of_string n4 with Not_found -> 0 in { Netdate.year; month; day; hour; minute; second; nanos; zone; week_day = (-1) } | None -> failwith "Netasn1.Value.get_time" ) let utctime date = let open Netdate in if date.year < 1950 || date.year >= 2050 then failwith "Netasn1.Value.utctime: year out of valid range"; let s = if date.zone = 0 then Netdate.format ~fmt:"%y%m%d%H%M%SZ" date else Netdate.format ~fmt:"%y%m%d%H%M%S%z" date in U s let gentime ~digits date = if digits > 9 then invalid_arg "Netasn1.Value.gentime"; let s = if Netdate.(date.zone)=0 then Netdate.format ~fmt:("%Y%m%d%H%M%." ^ string_of_int digits ^ "SZ") date else Netdate.format ~fmt:("%Y%m%d%H%M%." ^ string_of_int digits ^ "S%z") date in G s end let type_of_tag = function | 1 -> Type_name.Bool | 2 -> Type_name.Integer | 3 -> Type_name.Bitstring | 4 -> Type_name.Octetstring | 5 -> Type_name.Null | 6 -> Type_name.OID | 7 -> Type_name.ObjectDescriptor | 8 -> Type_name.External | 9 -> Type_name.Real | 10 -> Type_name.Enum | 11 -> Type_name.Embedded_PDV | 12 -> Type_name.UTF8String | 13 -> Type_name.ROID | 16 -> Type_name.Seq | 17 -> Type_name.Set | 18 -> Type_name.NumericString | 19 -> Type_name.PrintableString | 20 -> Type_name.TeletexString | 21 -> Type_name.VideotexString | 22 -> Type_name.IA5String | 23 -> Type_name.UTCTime | 24 -> Type_name.GeneralizedTime | 25 -> Type_name.GraphicString | 26 -> Type_name.VisibleString | 27 -> Type_name.GeneralString | 28 -> Type_name.UniversalString | 29 -> Type_name.CharString | 30 -> Type_name.BMPString | _ -> raise Not_found let n_max = if Sys.word_size = 32 then 3 else 7 let decode_rel_oid s = (* will raise Not_found on parse error *) let cur = ref 0 in let end_pos = String.length s in let l = ref [] in while !cur < end_pos do let x = ref 0 in while s.[ !cur ] >= '\128' do x := (!x lsl 7) lor (Char.code s.[ !cur ] - 128); incr cur; if !cur > end_pos then raise Not_found; done; x := (!x lsl 7) lor (Char.code s.[ !cur ]); l := !x :: !l; incr cur; done; Array.of_list (List.rev !l) let decode_region_poly ?(pos=0) ?len ops s = let open Netstring_tstring in let pos_end = match len with | None -> ops.length s | Some n -> pos+n in (pos, pos_end) let decode_ber_header_poly ?pos ?len ?(skip_length_check=false) ops s = let open Netstring_tstring in let pos, pos_end = decode_region_poly ?pos ?len ops s in let cur = ref pos in let next() = if !cur < pos_end then ( let c = Char.code (ops.get s !cur) in incr cur; c ) else raise Header_too_short in let id0 = next() in let pc = if (id0 land 0x20) <> 0 then Value.Constructed else Value.Primitive in let tc = match id0 land 0xc0 with | 0x00 -> Value.Universal | 0x40 -> Value.Application | 0x80 -> Value.Context | 0xc0 -> Value.Private | _ -> assert false in let tag0 = id0 land 0x1f in let tag = ( if tag0 < 31 then tag0 else ( let tag = ref 0 in let b = ref (next()) in let n = ref 1 in while !b > 127 do incr n; if !n = 5 then raise(Parse_error !cur); (* impl limit *) tag := (!tag lsl 7) lor (!b land 0x7f); b := next(); done; tag := (!tag lsl 7) lor !b; !tag ) ) in let length_opt = ( let l0 = next() in if l0 < 128 then Some l0 else ( let n = l0-128 in if n=0 then None (* indefinite length *) else ( if n > n_max then raise(Parse_error !cur); (* impl limit *) let l = ref 0 in for k = 1 to n do l := (!l lsl 8) lor (next()) done; Some !l ) ) ) in ( match length_opt with | None -> if pc = Value.Primitive then raise(Parse_error !cur) | Some n -> if not skip_length_check && n > pos_end - !cur then raise(Parse_error !cur) ); let hdr_len = !cur - pos in (hdr_len, tc, pc, tag, length_opt) let rec decode_ber_length_poly ?pos ?len ops s = let open Netstring_tstring in let pos, pos_end = decode_region_poly ?pos ?len ops s in let (hdr_len, tc, pc, tag, length_opt) = try decode_ber_header_poly ~pos ~len:(pos_end - pos) ops s with | Header_too_short -> raise(Parse_error pos_end) in match length_opt with | Some n -> hdr_len + n | None -> let cur = ref (pos + hdr_len) in let at_end_marker() = !cur+2 <= pos_end && ops.get s !cur = '\000' && ops.get s (!cur+1) = '\000' in while not (at_end_marker()) do assert(!cur < pos_end); let n = decode_ber_length_poly ~pos:!cur ~len:(pos_end - !cur) ops s in cur := !cur + n; done; (!cur - pos) + 2 let rec decode_homo_construction_poly f pos pos_end indefinite expected_tag ops s = (* A construction where the primitives have all the same tag. The depth is arbitrary. [f] is called for every found primitive. *) let open Netstring_tstring in let cur = ref pos in let at_end() = if indefinite then !cur+2 <= pos_end && ops.get s !cur = '\000' && ops.get s (!cur+1) = '\000' else !cur = pos_end in while not (at_end()) do assert(!cur < pos_end); let (hdr_len, tc, pc, tag, length_opt) = try decode_ber_header_poly ~pos:!cur ~len:(pos_end - !cur) ops s with | Header_too_short -> raise (Parse_error pos_end) in if tc <> Value.Universal then raise (Parse_error !cur); if tag <> expected_tag then raise (Parse_error !cur); ( match pc with | Value.Primitive -> let n = match length_opt with | None -> assert false | Some n -> n in f (!cur + hdr_len) n; cur := !cur + hdr_len + n | Value.Constructed -> let sub_pos_end = match length_opt with | None -> pos_end | Some n -> !cur + hdr_len + n in let real_n = decode_homo_construction_poly f (!cur + hdr_len) sub_pos_end (length_opt = None) expected_tag ops s in ( match length_opt with | None -> () | Some n -> if n <> real_n then raise (Parse_error !cur) ); cur := !cur + hdr_len + real_n ); done; if indefinite then cur := !cur + 2; if not indefinite && !cur <> pos_end then raise (Parse_error !cur); !cur - pos let rec decode_ber_poly ?pos ?len ops s = let pos, pos_end = decode_region_poly ?pos ?len ops s in let (hdr_len, tc, pc, tag, length_opt) = try decode_ber_header_poly ~pos ~len:(pos_end - pos) ops s with | Header_too_short -> raise (Parse_error pos_end) in match tc with | Value.Universal -> let cur = pos + hdr_len in let ty_name = try type_of_tag tag with Not_found -> raise(Parse_error cur) in let len = match length_opt with | None -> pos_end - cur | Some n -> n in let content_len, value = decode_ber_contents_poly ~pos:cur ~len ~indefinite:(length_opt = None) ops s pc ty_name in ( match length_opt with | None -> () | Some n -> if content_len <> n then raise(Parse_error cur) ); (content_len + hdr_len, value) | _ -> let content_len = match length_opt with | None -> (decode_ber_length_poly ~pos ~len:(pos_end - pos) ops s) - hdr_len - 2 | Some n -> n in let box = Netstring_tstring.Tstring_polybox(ops,s) in let value = Value.Tagptr(tc, tag, pc, box, pos+hdr_len, content_len) in (content_len + hdr_len, value) and decode_ber_contents_poly ?pos ?len ?(indefinite=false) ops s pc ty = let open Netstring_tstring in let pos, pos_end = decode_region_poly ?pos ?len ops s in let len = pos_end - pos in if indefinite && pc=Value.Primitive then invalid_arg "Netasn1.decode_ber_contents: only constructed values \ permit indefinite length"; match ty with | Type_name.Null -> if pc <> Value.Primitive then raise(Parse_error pos); if len<>0 then raise(Parse_error pos); (0, Value.Null) | Type_name.Bool -> if pc <> Value.Primitive then raise(Parse_error pos); if len=0 then raise(Parse_error pos); let v = Value.Bool( ops.get s pos <> '\000' ) in (1, v) | Type_name.Integer -> if pc <> Value.Primitive then raise(Parse_error pos); if len=0 then raise(Parse_error pos); let u = ops.substring s pos len in (* FIXME: value check *) let v = Value.Integer u in (len, v) | Type_name.Enum -> if pc <> Value.Primitive then raise(Parse_error pos); if len=0 then raise(Parse_error pos); let u = ops.substring s pos len in (* FIXME: value check *) let v = Value.Enum u in (len, v) | Type_name.Real -> if pc <> Value.Primitive then raise(Parse_error pos); let u = ops.substring s pos len in (* FIXME: value check *) let v = Value.Real u in (len, v) | Type_name.OID -> if pc <> Value.Primitive then raise(Parse_error pos); let u = ops.substring s pos len in let r = try decode_rel_oid u with Not_found -> raise(Parse_error pos) in if Array.length r < 1 then raise(Parse_error pos); let x = if r.(0) < 40 then 0 else if r.(0) < 80 then 1 else 2 in let y = if x < 2 then r.(0) mod 40 else r.(0) - 80 in let oid = Array.append [| x; y |] (Array.sub r 1 (Array.length r - 1)) in let v = Value.OID oid in (len, v) | Type_name.ROID -> if pc <> Value.Primitive then raise(Parse_error pos); let u = ops.substring s pos len in let r = try decode_rel_oid u with Not_found -> raise(Parse_error pos) in let v = Value.ROID r in (len, v) | Type_name.Octetstring -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.Octetstring octets) | Type_name.ObjectDescriptor -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.ObjectDescriptor octets) | Type_name.UTF8String -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.UTF8String octets) | Type_name.NumericString -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.NumericString octets) | Type_name.PrintableString -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.PrintableString octets) | Type_name.TeletexString -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.TeletexString octets) | Type_name.VideotexString -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.VideotexString octets) | Type_name.IA5String -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.IA5String octets) | Type_name.GraphicString -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.GraphicString octets) | Type_name.VisibleString -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.VisibleString octets) | Type_name.GeneralString -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.GeneralString octets) | Type_name.UniversalString -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.UniversalString octets) | Type_name.CharString -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.CharString octets) | Type_name.BMPString -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.BMPString octets) | Type_name.UTCTime -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.UTCTime (Value.U octets)) | Type_name.GeneralizedTime -> let (len, octets) = decode_ber_octets_poly pos pos_end indefinite ops s pc in (len, Value.GeneralizedTime (Value.G octets)) | Type_name.Bitstring -> let (len, bitstring) = decode_ber_bits_poly pos pos_end indefinite ops s pc in (len, Value.Bitstring bitstring) | Type_name.Seq -> if pc <> Value.Constructed then raise(Parse_error pos); let (len, list) = decode_list_construction_poly pos pos_end indefinite ops s in (len, Value.Seq list) | Type_name.Set -> if pc <> Value.Constructed then raise(Parse_error pos); let (len, list) = decode_list_construction_poly pos pos_end indefinite ops s in (len, Value.Set list) | Type_name.External -> if pc <> Value.Constructed then raise(Parse_error pos); let (len, list) = decode_list_construction_poly pos pos_end indefinite ops s in (len, Value.External list) | Type_name.Embedded_PDV -> if pc <> Value.Constructed then raise(Parse_error pos); let (len, list) = decode_list_construction_poly pos pos_end indefinite ops s in (len, Value.Embedded_PDV list) and decode_ber_octets_poly pos pos_end indefinite ops s pc = let open Netstring_tstring in let len = pos_end - pos in match pc with | Value.Primitive -> (len, ops.substring s pos len) | Value.Constructed -> let buf = Netbuffer.create 500 in let f p l = Netbuffer.add_subtstring_poly buf ops s p l in let n = decode_homo_construction_poly f pos pos_end indefinite 4 ops s in (n, Netbuffer.contents buf) and decode_ber_bits_poly pos pos_end indefinite ops s pc = let open Netstring_tstring in let len = pos_end - pos in match pc with | Value.Primitive -> if len = 0 then raise(Parse_error pos); let c0 = ops.get s pos in if c0 >= '\008' || (len = 1 && c0 <> '\000') then raise(Parse_error pos); (len, ops.substring s pos len) | Value.Constructed -> let c0_prev = ref '\000' in let buf = Netbuffer.create 500 in Netbuffer.add_char buf '\000'; let f p l = if !c0_prev <> '\000' then raise(Parse_error pos); if l = 0 then raise(Parse_error pos); let c0 = ops.get s p in if c0 >= '\008' || (l = 1 && c0 <> '\000') then raise(Parse_error pos); c0_prev := c0; Netbuffer.add_subtstring_poly buf ops s (p+1) (l-1) in let n = decode_homo_construction_poly f pos pos_end indefinite 3 ops s in let bitstring = Netbuffer.to_bytes buf in Bytes.set bitstring 0 !c0_prev; (n, Bytes.unsafe_to_string bitstring) and decode_list_construction_poly pos pos_end indefinite ops s = let open Netstring_tstring in let acc = ref [] in let cur = ref pos in let at_end() = if indefinite then !cur+2 <= pos_end && ops.get s !cur = '\000' && ops.get s (!cur+1) = '\000' else !cur = pos_end in while not(at_end()) do assert(!cur < pos_end); let (ber_len, value) = decode_ber_poly ~pos:!cur ~len:(pos_end - !cur) ops s in acc := value :: !acc; cur := !cur + ber_len; done; if indefinite then cur := !cur + 2; if not indefinite && !cur <> pos_end then raise (Parse_error !cur); (!cur - pos, List.rev !acc) let decode_ber ?pos ?len s = decode_ber_poly ?pos ?len Netstring_tstring.string_ops s let decode_ber_tstring ?pos ?len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> decode_ber_poly ?pos ?len ops s ) } ts let decode_ber_contents ?pos ?len ?indefinite s v ty = let ops = Netstring_tstring.string_ops in decode_ber_contents_poly ?pos ?len ?indefinite ops s v ty let decode_ber_contents_tstring ?pos ?len ?indefinite ts v ty = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> decode_ber_contents_poly ?pos ?len ?indefinite ops s v ty ) } ts let decode_ber_length ?pos ?len s = let ops = Netstring_tstring.string_ops in decode_ber_length_poly ?pos ?len ops s let decode_ber_length_tstring ?pos ?len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> decode_ber_length_poly ?pos ?len ops s ) } ts let decode_ber_header ?pos ?len ?skip_length_check s = let ops = Netstring_tstring.string_ops in decode_ber_header_poly ?pos ?len ?skip_length_check ops s let decode_ber_header_tstring ?pos ?len ?skip_length_check ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> decode_ber_header_poly ?pos ?len ?skip_length_check ops s ) } ts let rec streamline_seq expected seq = let open Netstring_tstring in match expected, seq with | [], [] -> [] | [], _ -> failwith "Netasn1.streamline_seq [1]" | ((exp_tc, exp_tag, exp_ty)::expected1), (Value.ITag(act_tc, act_tag, act_v)::seq1) when exp_tc=act_tc && exp_tag=act_tag -> if Value.type_of_value act_v <> Some exp_ty then failwith "Netasn1.streamline_seq [2]"; Some act_v :: streamline_seq expected1 seq1 | ((exp_tc, exp_tag, exp_ty)::expected1), (Value.Tagptr(act_tc,act_tag,pc,box,pos,len)::seq1) when exp_tc=act_tc && exp_tag=act_tag -> let Tstring_polybox(ops,s) = box in let act_len, v = decode_ber_contents_poly ~pos ~len ops s pc exp_ty in if act_len <> len then failwith "Netasn1.streamline_seq [3]"; Some v :: streamline_seq expected1 seq1 | _, (Value.Tag _ :: _) -> failwith "Netasn1.streamline_seq [4]" | ((Value.Universal, exp_tag, exp_ty)::expected1), (v::seq1) when Value.type_of_value v = Some exp_ty -> Some v :: streamline_seq expected1 seq1 | (_ :: expected1), _ -> None :: streamline_seq expected1 seq let streamline_set typeinfo set = let open Netstring_tstring in let ht = Hashtbl.create 5 in List.iter (fun (tc,tag,ty) -> Hashtbl.replace ht (tc,tag) ty) typeinfo; List.map (function | Value.ITag(tc, tag, v) -> let ty = try Hashtbl.find ht (tc,tag) with Not_found -> failwith "Netasn1.streamline_set" in if Value.type_of_value v <> Some ty then failwith "Netasn1.streamline_set"; v | Value.Tagptr(tc, tag, pc, box, pos, len) -> let ty = try Hashtbl.find ht (tc,tag) with Not_found -> failwith "Netasn1.streamline_set" in let Tstring_polybox(ops,s) = box in let act_len, v = decode_ber_contents_poly ~pos ~len ops s pc ty in if act_len <> len then failwith "Netasn1.streamline_set"; v | v -> v ) set ocamlnet-4.1.6/src/netstring/netasn1.mli0000644000175000017500000005023613274252307016643 0ustar gerdgerd(* $Id$ *) (** ASN.1 support functions *) (** See below for a little intro into ASN.1: {!Netasn1.intro} *) open Netsys_types exception Out_of_range exception Parse_error of int (** Byte position in string *) exception Header_too_short module Type_name : sig type type_name = | Bool | Integer | Enum | Real | Bitstring | Octetstring | Null | Seq | Set | OID | ROID | ObjectDescriptor | External | Embedded_PDV | NumericString | PrintableString | TeletexString | VideotexString | VisibleString | IA5String | GraphicString | GeneralString | UniversalString | BMPString | UTF8String | CharString | UTCTime | GeneralizedTime end module Value : sig type pc = Primitive | Constructed type value = | Bool of bool (** Boolean (primitive) *) | Integer of int_value (** Integer (primitive) *) | Enum of int_value (** Enumeration (primitive) *) | Real of real_value (** Floating-point number, using either base 2 or base 10 (primitive) *) | Bitstring of bitstring_value (** Bit strings (primitive or constructed) *) | Octetstring of string (** Octet strings (primitive or constructed) *) | Null (** Null (primitive) *) | Seq of value list (** Sequences (records or arrays) (constructed) *) | Set of value list (** Sets (constructed) *) | Tagptr of tag_class * int * pc * Netstring_tstring.tstring_polybox * int * int (** Pointer to an undecoded value that was implicitly tagged. The [tag_class] can be [Application], [Context], or [Private]. *) | Tag of tag_class * int * pc * value (** Explicit tag (primitive or constructed depending on inner value) *) | ITag of tag_class * int * value (** Implicit tag (never returned by the decoder, but needed for encoding such tags) *) | OID of int array (* Object IDs (primitive) *) | ROID of int array (* Relative Object IDs (primitive) *) | ObjectDescriptor of string (** A placeholder with a comment (primitive) *) | External of value list (** Something complex I don't understand (constructed) *) | Embedded_PDV of value list (** Something complex I don't understand (constructed) *) | NumericString of string (** String made of digits and spaces (primitive or constructed) *) | PrintableString of string (** A small subset of ASCII (primitive or constructed) *) | TeletexString of string | VideotexString of string | VisibleString of string (** 7 bit ASCII w/o control characters (primitive or constructed) *) | IA5String of string (** 7 bit ASCII (primitive or constructed) *) | GraphicString of string (** ISO-2022-encoded string w/o control characters *) | GeneralString of string (** ISO-2022-encoded string *) | UniversalString of string (** Any ISO-10646-1 character string represented as UTF-32-BE (primitive or constructed). Roughly, ISO-10646-1 equals to Unicode. *) | BMPString of string (** Any ISO-10646-1 character string from only the basic multilingual plane, i.e. with code points <= 65535, represented as UTF-16-BE (primitive or constructed) *) | UTF8String of string (** Any ISO-10646-1 character string represented as UTF-8 (primitive or constructed) *) | CharString of string (** A complicated description of an arbitrary charset encoding (primitive or constructed) *) | UTCTime of time_value (** Like GeneralizedTime but less precise, and with 2-digit year *) | GeneralizedTime of time_value (** Calendar date with time of day, including timezone (primitive) *) and tag_class = | Universal | Application | Context | Private and int_value and real_value and bitstring_value and time_value type time_subtype = [ `U | `G ] val type_of_value : value -> Type_name.type_name option (** Returns the type, or [None] for [Tag], [ITag] and [Tagptr] *) (** {3 Integer} *) val get_int_repr : int_value -> string (** Get an integer as bytes *) val get_int_b256 : int_value -> int array (** Get an integer in base 256 notation, big endian. Negative values are represented using two's complement (i.e. the first array element is >= 128). The empty array means 0. *) val get_int : int_value -> int (** Get an integer as [int] if representable, or raise [Out_of_range] *) val get_int32 : int_value -> int32 (** Get an integer as [int32] if representable, or raise [Out_of_range] *) val get_int64 : int_value -> int64 (** Get an integer as [int64] if representable, or raise [Out_of_range] *) val int : int -> int_value (** Create an int *) val int32 : int32 -> int_value (** Create an int *) val int64 : int64 -> int_value (** Create an int *) val int_b256 : int array -> int_value (** Create an int from a base 256 number, big endian, signed *) (** {3 Real} *) (** Reals are not really supported ;-( *) val get_real_repr : real_value -> string (** Get the byte representation of the real *) (** {3 Bitstring} *) (** In some contexts it is usual that trailing zero bits are truncated. *) val get_bitstring_size : bitstring_value -> int (** Get the number of bits *) val get_bitstring_data : bitstring_value -> string (** Get the data. The last byte may be partial. The order of the bits in every byte: bit 7 (MSB) contains the first bit *) val get_bitstring_bits : ?size:int -> bitstring_value -> bool array (** Get the bitstring as bool array. If [size] is specified the array will have exactly this number of bits (by dropping exceeding data, or by adding [false] at the end) *) val get_bitstring_repr : bitstring_value -> string (** Get the representation *) val bitstring_of_bits : bool array -> bitstring_value (** Get the bitstring from a bool array *) val bitstring_of_string : string -> int -> bitstring_value (** Get the bitstring from a string and the total number of bits. The bits are taken from the beginning of the string (MSB first). If the string is shorter than the number of bits suggests, the remaining bits are assumed to be zero. If the string is longer than the number of bits suggests, the exceeding data is ignored. *) val truncate_trailing_zero_bits : bitstring_value -> bitstring_value (** Truncates the biggest trailing part that only consist of 0 bits *) (** {3 Time} *) (** Time values referring to the local time zone are not supported *) val get_time_subtype : time_value -> time_subtype (** Whether this is for UTCTime ([`U]) or GeneralizedTime ([`G]) *) val get_time_repr : time_value -> string (** Get the raw time string *) val get_time : time_value -> Netdate.t (** Get the time. Notes: - UTCTime years are two-digit years, and interpreted so that 0-49 is understood as 2000-2049, and 50-99 is understood as 1950-1999 (as required by X.509). - This function is restricted to the time formats occurring in DER (string terminates with "Z", i.e. UTC time zone) *) val utctime : Netdate.t -> time_value (** Create a time value for UTCTime. This function is restricted to years between 1950 and 2049. *) val gentime : digits:int -> Netdate.t -> time_value (** Create a time value for GeneralizedTime. [digits] is the number of fractional (subsecond) digits *) (** {3 Equality} *) val equal : value -> value -> bool (** Checks for equality. Notes: - [Tag] and [Tagptr] are considered different - [Tagptr] is checked by comparing the equality of the substring - [Set] is so far not compared as set, but as sequence (i.e. order matters) *) end val decode_ber : ?pos:int -> ?len:int -> string -> int * Value.value (** Decodes a BER-encoded ASN.1 value. Note that DER is a subset of BER, and can also be decoded. [pos] and [len] may select a substring for the decoder. By default, [pos=0], and [len] as large as necessary to reach to the end of the string. The function returns the number of interpreted bytes, and the value. It is not considered as an error if less than [len] bytes are consumed. The returned value represents implicitly tagged values as [Tagptr(class,tag,pc,pos,len)]. [pos] and [len] denote the substring containting the contents. Use {!Netasn1.decode_ber_contents} to further decode the value. You can use [ITag] to put the decoded value back into the tree. A number of values are not verified (i.e. nonsense values can be returned): - for all string types it is not checked whether the constraints are satisfied (e.g. whether an UTF8String really contains UTF-8). - [External], [Embedded_PDV] and [Real] are unchecked - Other values may first be checked on first access (e.g. [GeneralizedTime]). *) val decode_ber_tstring : ?pos:int -> ?len:int -> tstring -> int * Value.value (** Same for tagged strings *) val decode_ber_poly : ?pos:int -> ?len:int -> 's Netstring_tstring.tstring_ops -> 's -> int * Value.value (** polymorphic version *) val decode_ber_contents : ?pos:int -> ?len:int -> ?indefinite:bool -> string -> Value.pc -> Type_name.type_name -> int * Value.value (** Decodes the BER-encoded contents of a data field. The contents are assumed to have the type denoted by [type_name]. [pos] and [len] may select a substring for the decoder. By default, [pos=0], and [len] as large as necessary to reach to the end of the string. If [indefinite], the extent of the contents region is considered as indefinite, and the special end marker is required. This is only allowed when [pc = Constructed]. The function returns the number of interpreted bytes, and the value. It is not considered as an error if less than [len] bytes are consumed. You need to use this function to recursively decode tagged values. If you get a [Tagptr(class,tag,pc,s,pos,len)] value, it depends on the kind of the tag how to proceed: - For explicit tags just invoke {!Netasn1.decode_ber} again with the given [pos] and [len] parameters. - For implicit tags you need to know the type of the field. Now call {!Netasn1.decode_ber_contents} with the right type name. The BER encoding doesn't include whether the tag is implicit or explicit, so the decode cannot do by itself the right thing here. *) val decode_ber_contents_tstring : ?pos:int -> ?len:int -> ?indefinite:bool -> tstring -> Value.pc -> Type_name.type_name -> int * Value.value (** Same for tagged strings *) val decode_ber_contents_poly : ?pos:int -> ?len:int -> ?indefinite:bool -> 's Netstring_tstring.tstring_ops -> 's -> Value.pc -> Type_name.type_name -> int * Value.value (** Polymorphic version *) val decode_ber_length : ?pos:int -> ?len:int -> string -> int (** Like [decode_ber], but returns only the length. This function skips many consistency checks. *) val decode_ber_length_tstring : ?pos:int -> ?len:int -> tstring -> int (** Same for tagged strings *) val decode_ber_length_poly : ?pos:int -> ?len:int -> 's Netstring_tstring.tstring_ops -> 's -> int (** Polymorphic version *) val decode_ber_header : ?pos:int -> ?len:int -> ?skip_length_check:bool -> string -> (int * Value.tag_class * Value.pc * int * int option) (** [let (hdr_len, tc, pc, tag, len_opt) = decode_ber_header s]: Decodes only the header: - [hdr_len] will be the length of the header in bytes - [tc] is the tag class - [pc] whether primitive or constructed - [tag] is the numeric tag value - [len_opt] is the length field, or [None] if the header selects indefinite length If [skip_length_check] is set, the function does not check whether the string is long enough to hold the whole data part. If the string is a valid beginning of a header, the special exception [Header_too_short] is raised (instead of [Parse_error]). *) val decode_ber_header_tstring : ?pos:int -> ?len:int -> ?skip_length_check:bool -> tstring -> (int * Value.tag_class * Value.pc * int * int option) (** Same for tagged strings *) val decode_ber_header_poly : ?pos:int -> ?len:int -> ?skip_length_check:bool -> 's Netstring_tstring.tstring_ops -> 's -> (int * Value.tag_class * Value.pc * int * int option) (** Polymorphic version *) val streamline_seq : (Value.tag_class * int * Type_name.type_name) list -> Value.value list -> Value.value option list (** [streamline_seq expected seq]: This function can be called for a list of values [Value.Seq seq], and will compare the list [seq] with the [expected] list, and will mark missing elements in the sequence, and will recursively decode the occurring elements with the type information from [expected]. For example, if [expected] is {[ [Context,0,Integer; Context,1,Octetstring; Context,2,IA5String] ]} and the passed [seq] is just {[ [Tagptr(Context,1,...)] ]} the function assumes that the elements with tags 0 and 2 are optional and it assumes that the element with tag 1 is decoded as [Octetstring], leading to {[ None; Some(Octetstring ...); None ]} It is allowed to put [Universal] tags into the [expected] list. The tag number is ignored in this case (for simplicity). *) val streamline_set : (Value.tag_class * int * Type_name.type_name) list -> Value.value list -> Value.value list (** [streamline_set typeinfo set]: This function can be called for a list of values [Value.Set seq], and decodes the list with the type information from [typeinfo]. For example, if [typeinfo] is {[ [Context,0,Integer; Context,1,Octetstring; Context,2,IA5String] ]} and the passed [set] is just {[ [Tagptr(Context,1,...); Tagptr(Context 0,...)] ]} the function decodes the elements as {[ [ Octetstring ...; Integer ... ] ]} *) (** {1:intro The Abstract Syntax Notation 1 (ASN.1)} ASN.1 allows you to represent structured values as octet streams. The values can be composed from a wide range of base types (e.g. numbers and many different kinds of strings) and can be arranged as sequences (records and arrays), sets, and tagged values (a concept fairly close to OCaml variant types). There is a definition language allowing you to define types and values. This language is not covered here (and there is no IDL compiler). Look for ITU X.680 standard if you want to know more. We focus here on the octet representation, which is sufficient for parsing and printing ASN.1 values. {2 Encoding rules} There are three variants on the representation level: - BER: Basic Encoding Rules - CER: Canonical Encoding Rules - DER: Distinguished Encoding Rules BER describes the basic way how the octets are obtained, but leaves several details up to the sender of an ASN.1 message. CER and DER use stricter rules that are subsets of BER so that a given value can only be represented in a single way. CER targets at large messages, whereas DER is optimized for small messages. This module includes a generic decoder for all BER messages, and {!Netasn1_encode} supports DER encoding. The ASN.1 octet representations are described in ITU X.690. {2 The TLV representation} ASN.1 uses a type-length-value (TLV) style representation, i.e. there is a header containing type information and the length of the data, followed by the payload data. The data can be primitive (e.g. a number) or "constructed" (i.e. a composition of further values). For certain data types the user can choose whether to prefer a primitive representation or a construction from several part values (e.g. a very long string can be given as a sequence of string chunks). Because of this, there is a {!Netasn1.Value.pc} bit in the representation so that this choice is available at runtime. The type is given as a numeric tag (a small number), and a tag class ({!Netasn1.Value.tag_class}). There are four tag classes: - Universal: These tags are used for types defined by the ASN.1 standard, and should not be used for anything else. For example the type OctetString gets the universal tag 3. - Application: These tags are intended for marking newly defined types. E.g. if you have a definition [type filename = string] and you would like to have filenames specially tagged to distinguish them from other uses of strings, the runtime representation of filenames could get an application tag (e.g. the number 8). In ASN.1 syntax: {[ Filename ::= [APPLICATION 8] IA5String ]} - Context-specific: These tags are intended for marking variants, i.e. tags that are local to a specific use. An example in ASN.1 syntax: {[ CustomerRecord ::= SET { name [0] VisibleString, mailingAddress [1] VisibleString, accountNumber [2] INTEGER, balanceDue [3] INTEGER } ]} The numbers in brackets are the context-specific tags. - Private: These are reserved for site-specific extensions of standardized message formats. Conceptionally, universal and application tags identify types, whereas context-specific tags identify variants (local cases). Both concepts are not cleanly separated, though. If you e.g. define a set of values, and one value variant is a string and another variant is an integer, there is no strict need to use context-specific tags, because the tags for the type "string" and for the type "integer" are already different. In ASN.1 syntax: {[ Example ::= SET { x VisibleString, y INTEGER } ]} A VisibleString has universal tag 26, and an INTEGER has universal tag 3. Note that the bracket notation includes a keyword "UNIVERSAL", "APPLICATION", or "PRIVATE" for these three classes, and that a plain number indicates context-specific tags. Finally, there are two ways of applying tags: Explicit and implicit. Explicit tagging is used when the binary values should retain the complete type information: If a tag is applied to an existing value, another header with tag and length field is created, and the value is seen as the contents of this construction. In other words, tagging is an explicit construction like others (e.g. like a record). Implicit tagging means that the tag of the existing value is replaced by the new tag. As tags also encode the types, this means that type information is lost, and you need apriori knowledge about the possible tags to decode such values (e.g. that an application tag 8 always means an IA5String). {2 How to decode values} The function {!Netasn1.decode_ber} will happily decode any BER data and return a complex {!Netasn1.Value.value} unless implicit tagging is used. Implicit tags cannot be decoded in one go because the type information is missing. Instead of completely decoding such tags, only a marker [Tagptr(tag_class,tag,pc,data,pos,len)] is created. Here, [tag_class] and [tag] describe the tag. The value to which the tag is applied is not yet parsed, but only a "pointer" in form of the string [data], the position [pos] and the byte length [len] is returned. This range inside [data] represents the inner value. After determining the type of this value (by knowing which type is applicable for [tag] and [tag_class]), you can call {!Netasn1.decode_ber_contents} to decode the value. This function is different from {!Netasn1.decode_ber} because it doesn't start at the header of the BER representation but after the header. The type needs to be passed explicitly because it isn't retrieved from the header. *) ocamlnet-4.1.6/src/netstring/netasn1_encode.ml0000644000175000017500000001465113274252307020010 0ustar gerdgerd(* $Id$ *) (* TODO: - verify strings *) open Netasn1 exception Encode_error of string let tag_of_value = function | Value.Bool _ -> Value.Universal, 1 | Value.Integer _ -> Value.Universal, 2 | Value.Bitstring _ -> Value.Universal, 3 | Value.Octetstring _ -> Value.Universal, 4 | Value.Null -> Value.Universal, 5 | Value.OID _ -> Value.Universal, 6 | Value.ObjectDescriptor _ -> Value.Universal, 7 | Value.External _ -> Value.Universal, 8 | Value.Real _ -> Value.Universal, 9 | Value.Enum _ -> Value.Universal, 10 | Value.Embedded_PDV _ -> Value.Universal, 11 | Value.UTF8String _ -> Value.Universal, 12 | Value.ROID _ -> Value.Universal, 13 | Value.Seq _ -> Value.Universal, 16 | Value.Set _ -> Value.Universal, 17 | Value.NumericString _ -> Value.Universal, 18 | Value.PrintableString _ -> Value.Universal, 19 | Value.TeletexString _ -> Value.Universal, 20 | Value.VideotexString _ -> Value.Universal, 21 | Value.IA5String _ -> Value.Universal, 22 | Value.UTCTime _ -> Value.Universal, 23 | Value.GeneralizedTime _ -> Value.Universal, 24 | Value.GraphicString _ -> Value.Universal, 25 | Value.VisibleString _ -> Value.Universal, 26 | Value.GeneralString _ -> Value.Universal, 27 | Value.UniversalString _ -> Value.Universal, 28 | Value.CharString _ -> Value.Universal, 29 | Value.BMPString _ -> Value.Universal, 30 | Value.ITag(tc, tag, _) -> if tag < 0 then failwith "Netasn1_encode.tag_of_value"; tc, tag | Value.Tag(tc, tag, _, _) -> if tag < 0 then failwith "Netasn1_encode.tag_of_value"; tc, tag | Value.Tagptr(tc, tag, _, _, _, _) -> if tag < 0 then failwith "Netasn1_encode.tag_of_value"; tc, tag let encode_error s = raise(Encode_error s) let encode_base128 buf n = let rec encode n = if n < 128 then [ n ] else (n land 127) :: encode (n lsr 7) in if n < 0 then encode_error "bad input"; let l = List.rev(encode n) in let len = List.length l in let l = List.mapi (fun i k -> if i < len-1 then Char.chr(k lor 128) else Char.chr k ) l in List.iter (Netbuffer.add_char buf) l let rec encode_ber_contents buf v = match v with | Value.Null -> Value.Primitive | Value.Bool b -> Netbuffer.add_char buf (if b then '\xff' else '\x00'); Value.Primitive | Value.Integer n | Value.Enum n -> let s = Value.get_int_repr n in Netbuffer.add_string buf s; Value.Primitive | Value.Real n -> let s = Value.get_real_repr n in Netbuffer.add_string buf s; Value.Primitive | Value.OID oid -> if Array.length oid <= 2 then encode_error "bad OID in input"; let x = oid.(0) in let y = oid.(1) in if x < 0 || x > 2 || y < 0 || y > 39 then encode_error "bad OID in input"; encode_base128 buf (x * 40 + y); for k = 2 to Array.length oid - 1 do encode_base128 buf oid.(k) done; Value.Primitive | Value.ROID oid -> for k = 0 to Array.length oid - 1 do encode_base128 buf oid.(k) done; Value.Primitive | Value.Octetstring s | Value.ObjectDescriptor s | Value.UTF8String s | Value.NumericString s | Value.PrintableString s | Value.TeletexString s | Value.VideotexString s | Value.IA5String s | Value.GraphicString s | Value.VisibleString s | Value.GeneralString s | Value.UniversalString s | Value.CharString s | Value.BMPString s -> Netbuffer.add_string buf s; Value.Primitive | Value.UTCTime t -> if Value.get_time_subtype t <> `U then encode_error "wrong time format for UTCTime"; let s = Value.get_time_repr t in Netbuffer.add_string buf s; Value.Primitive | Value.GeneralizedTime t -> if Value.get_time_subtype t <> `G then encode_error "wrong time format for GeneralizedTime"; let s = Value.get_time_repr t in Netbuffer.add_string buf s; Value.Primitive | Value.Bitstring bs -> let s = Value.get_bitstring_repr bs in Netbuffer.add_string buf s; Value.Primitive | Value.Seq vals | Value.Set vals | Value.External vals | Value.Embedded_PDV vals -> List.iter (fun v -> ignore(encode_ber buf v) ) vals; Value.Constructed | Value.ITag(_,_,v) -> ( match v with | Value.ITag _ | Value.Tagptr _ -> encode_ber buf v | _ -> encode_ber_contents buf v ) | Value.Tag(_,_,_,v) -> encode_ber buf v | Value.Tagptr(_,_,pc,box,pos,len) -> let Netstring_tstring.Tstring_polybox(ops,s) = box in Netbuffer.add_subtstring_poly buf ops s pos len; pc and encode_ber buf v = let buf' = Netbuffer.create 80 in let pc = encode_ber_contents buf' v in let length = Netbuffer.length buf' in let tc, tag = tag_of_value v in let tc_bits = match tc with | Value.Universal -> 0 | Value.Application -> 1 | Value.Context -> 2 | Value.Private -> 3 in let pc_bit = match pc with | Value.Primitive -> 0 | Value.Constructed -> 1 in let octet0 = (tc_bits lsl 6) lor (pc_bit lsl 5) lor (if tag <= 30 then tag else 31) in Netbuffer.add_char buf (Char.chr octet0); if tag > 30 then encode_base128 buf tag; if length < 128 then Netbuffer.add_char buf (Char.chr length) else ( if length <= 0xff then ( Netbuffer.add_char buf '\x81'; Netbuffer.add_char buf (Char.chr length); ) else if length <= 0xffff then ( Netbuffer.add_char buf '\x82'; Netbuffer.add_char buf (Char.chr (length lsr 8)); Netbuffer.add_char buf (Char.chr (length land 0xff)); ) else ( let i = Value.int length in let s0 = Value.get_int_repr i in let s1 = (* integers are signed, but we need here unsigned ints: *) if s0.[0] = '\x00' then String.sub s0 1 (String.length s0 - 1) else s0 in Netbuffer.add_char buf (Char.chr (0x80 + String.length s1)); Netbuffer.add_string buf s1; ) ); Netbuffer.add_buffer buf buf'; pc ocamlnet-4.1.6/src/netstring/netasn1_encode.mli0000644000175000017500000000132013274252307020146 0ustar gerdgerd(* $Id$ *) (** ASN.1 encoder *) (** Note that the encoder does not check whether the value is well-formed, in particular whether the constrained string values are correct. *) val encode_ber : Netbuffer.t -> Netasn1.Value.value -> Netasn1.Value.pc (** Appends a BER encoding of the value to the buffer (including the header). Returns whether a primitive or constructed encoding was generated. *) val encode_ber_contents : Netbuffer.t -> Netasn1.Value.value -> Netasn1.Value.pc (** Appends a BER encoding of the value to the buffer (excluding the header). Returns whether a primitive or constructed encoding was generated. *) ocamlnet-4.1.6/src/netstring/netauth.ml0000644000175000017500000000777213274252307016600 0ustar gerdgerd(* $Id$ *) let xor_s s u = let s_len = String.length s in let u_len = String.length u in assert(s_len = u_len); let x = Bytes.create s_len in for k = 0 to s_len-1 do Bytes.set x k (Char.chr ((Char.code s.[k]) lxor (Char.code u.[k]))) done; Bytes.unsafe_to_string x let hmac ~h ~b ~l ~k ~message = if String.length k > b then failwith "Netauth.hmac: key too long"; let k_padded = k ^ String.make (b - String.length k) '\000' in let ipad = String.make b '\x36' in let opad = String.make b '\x5c' in h((xor_s k_padded opad) ^ (h ((xor_s k_padded ipad) ^ message))) let add_1_complement s1 s2 = (* Add two bitstrings s1 and s2 (in big-endian order) with one's complement addition *) let l1 = String.length s1 in let l2 = String.length s2 in if l1 <> l2 then invalid_arg "Netauth.add_1_complement"; let r = Bytes.make l1 '\000' in let carry = ref 0 in for k = l1-1 downto 0 do let i1 = Char.code s1.[k] in let i2 = Char.code s2.[k] in let sum = i1 + i2 + !carry in Bytes.set r k (Char.chr (sum land 0xff)); carry := if sum > 0xff then 1 else 0; done; if !carry > 0 then ( for k = l1-1 downto 0 do let i = Char.code (Bytes.get r k) in let sum = i + !carry in Bytes.set r k (Char.chr (sum land 0xff)); carry := if sum > 0xff then 1 else 0; done ); Bytes.unsafe_to_string r let rotate_right n s = (* Rotate the (big-endian) bitstring s to the right by n bits *) let l = String.length s in let b = 8 * l in (* bit length of s *) let n' = n mod b in let n' = if n' < 0 then b+n' else n' in let u = Bytes.create l in (* First byte-shift the string, then bit-shift the remaining 0-7 bits *) let bytes = n' lsr 3 in let bits = n' land 7 in Bytes.blit_string s 0 u bytes (l-bytes); if bytes > 0 then Bytes.blit_string s (l-bytes) u 0 bytes; let mask = match bits with | 0 -> 0 | 1 -> 1 | 2 -> 3 | 3 -> 7 | 4 -> 15 | 5 -> 31 | 6 -> 63 | 7 -> 127 | _ -> assert false in let carry = ref 0 in if bits > 0 && l > 0 then ( for k = 0 to l-1 do let x = Char.code (Bytes.get u k) in Bytes.set u k (Char.chr ((x lsr bits) lor (!carry lsl (8-bits)))); carry := x land mask; done; let u0 = Bytes.get u 0 in Bytes.set u 0 (Char.chr((Char.code u0) lor (!carry lsl (8-bits)))); ); Bytes.unsafe_to_string u let n_fold n s = (** n-fold the number given by the bitstring s. The length of the number is taken as the byte-length of s. n must be divisible by 8. *) if n=0 || n mod 8 <> 0 then invalid_arg "Netauth.n_fold"; let p = n / 8 in let buf = Buffer.create (String.length s) in let rec add_rot u len = if len > 0 && len mod p = 0 then () else ( Buffer.add_string buf u; add_rot (rotate_right 13 u) (len+String.length u) ) in add_rot s 0; let blen = Buffer.length buf in let s = ref (Buffer.sub buf 0 p) in for k = 1 to (blen / p) - 1 do s := add_1_complement !s (Buffer.sub buf (k*p) p) done; !s type key_type = [ `Kc | `Ke | `Ki ] let k_truncate k s = let b = k/8 in String.sub s 0 b let derive_key_rfc3961_simplified ~encrypt ~random_to_key ~block_size ~k ~usage ~key_type = if block_size < 40 then invalid_arg "Netauth.derive_key_rfc3961: bad block_size"; if k <= 0 || k mod 8 <> 0 then invalid_arg "Netauth.derive_key_rfc3961: bad k"; if usage < 0 || usage > 255 then invalid_arg "Netauth.derive_key_rfc3961: bad usage (only 0-255 allowed)"; let usage_s = String.make 3 '\000' ^ String.make 1 (Char.chr usage) ^ (match key_type with | `Kc -> "\x99" | `Ke -> "\xaa" | `Ki -> "\x55" ) in let usage_exp = n_fold block_size usage_s in let kbuf = Buffer.create 80 in let ki = ref (encrypt usage_exp) in Buffer.add_string kbuf !ki; while 8*(Buffer.length kbuf) < k do ki := encrypt !ki; Buffer.add_string kbuf !ki done; let derived_random = k_truncate k (Buffer.contents kbuf) in random_to_key derived_random ocamlnet-4.1.6/src/netstring/netauth.mli0000644000175000017500000000544313274252307016742 0ustar gerdgerd(* $Id$ *) (** Some primitives for authentication *) val hmac : h:(string->string) -> b:int -> l:int -> k:string -> message:string -> string (** The HMAC algorithm of RFC 2104. The function [h] is the hash function. [b] and [l] are properties of [h] (see the RFC or below). The string [k] is the key, up to [b] bytes. The [message] is authenticated. The key [k] should ideally have length [l]. If this cannot be ensured by other means, one should pass [k = h any_k]. Common values of [b] and [l]: - For [h=MD5]: [b=64], [l=16] - For [h=SHA-1]: [b=64], [l=20] See also {!Netsys_digests.hmac} for a better implementation. *) type key_type = [ `Kc | `Ke | `Ki ] (** Key types: - [`Kc] is used for computing checksums - [`Ke] is used for encrypting confidential messages - [`Ki] is used for computing integrity checksums for encrypted messages *) val derive_key_rfc3961_simplified : encrypt:(string -> string) -> random_to_key:(string -> string) -> block_size:int -> k:int -> usage:int -> key_type:key_type -> string (** Derives a special key from a base key, as described in RFC 3961. - [encrypt]: Encrypts the argument with the base key and the initial cipher state. - [random_to_key]: Converts a random string of size [k] to a key - [block_size]: The block size of the cipher underlying [encrypt]. It is ensured that [encrypt] is called with strings having exactly this many bits. (The [c] parameter in the RFC text.) Minimum: 40. - [k]: The input size for [random_to_key] in bits. Must be divisible by 8. - [usage]: The usage number (here restricted to 0-255, although the RFC would allow 32 bits). Examples for usage numbers can be found in RFC 4121 section 2. - [key_type]: Which key type to derive The output is a key as produced by [random_to_key]. *) (** {2 Bitstring operations} *) val xor_s : string -> string -> string (** Performs the bitwise XOR of these strings (which must have the same length) *) val add_1_complement : string -> string -> string (** The addition algorithm for 1's-complement numbers. The two numbers to add are given as bitstrings (big endian), and must have the same length *) val rotate_right : int -> string -> string (** Rotate the (big-endian) bitstring to the right by n bits. This also works for negative n (left rotation), and for n whose absolute value is greater or equal than the bit length of the string. *) val n_fold : int -> string -> string (** Blumenthal's n-fold algorithm for an n that is divisible by 8. (RFC 3961, section 5.1) *) ocamlnet-4.1.6/src/netstring/netaux.ml0000644000175000017500000000723113274252307016422 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) module KMP = struct type pattern = { len : int; p : string; fail : int array; rex : Netstring_str.regexp; } let rec delta pat state c = if pat.p.[state] = c then state + 1 else if state = 0 then 0 else delta pat pat.fail.(state - 1) c let make_pattern p = let l = String.length p in if l = 0 then invalid_arg "Netaux.KMP.make_pattern"; let rex = Netstring_str.regexp (Netstring_str.quote (String.make 1 p.[0])) in let pat = { len = l; p = p; fail = Array.make l 0; rex = rex } in for n = 0 to l - 2 do pat.fail.(n + 1) <- delta pat pat.fail.(n) p.[n] done; pat let run rex len p fail s endpos state pos = let rec run_loop state pos = if (state = len) || (pos = endpos) then (state,pos) else if p.[state] = (Bytes.get s pos) then run_loop (state+1) (pos+1) else if state = 0 then (* run_loop 0 (pos+1) *) run_regexp (pos+1) else let state' = fail.(state-1) in run_delta p.[state'] state' pos and run_delta c state pos = if c = Bytes.get s pos then run_loop (state+1) (pos+1) else if state = 0 then run_loop 0 (pos+1) else let state' = fail.(state-1) in run_delta p.[state'] state' pos and run_regexp pos = (* Does the same as [run_loop 0 pos], but uses regexps to skip all the * non-matching characters. Improves the speed of bytecode dramatically, * but does not cost very much for native code. *) let pos' = try (* Note: setting s.[endpos] <- p.[0] would be a working guard, * but this might lead to problems in multi-threaded programs. * So we don't do it here. Better fix Pcre someday... *) let p, _ = Netstring_str.search_forward_bytes rex s pos in (* FIXME: no ~len *) p with Not_found -> endpos in if pos' < endpos then run_loop 0 pos' else run_loop 0 endpos in run_loop state pos let find_pattern pat ?(pos=0) ?len s = let endpos = match len with None -> Bytes.length s | Some l -> pos+l in if pos < 0 || endpos > Bytes.length s || pos > endpos then invalid_arg "Netaux.KMP.find_pattern"; let (state,pos) = run pat.rex pat.len pat.p pat.fail s endpos 0 pos in pos - state end module ArrayAux = struct let int_blit_ref = ref (fun (src:int array) srcpos dest destpos len -> (* A specialised version of Array.blit for int arrays. * Faster than the polymorphic Array.blit for * various reasons. *) if (len < 0 || srcpos < 0 || srcpos+len > Array.length src || destpos < 0 || destpos+len > Array.length dest) then invalid_arg "Netaux.ArrayAux.int_blit"; if src != dest || destpos <= srcpos then ( for i = 0 to len-1 do Array.unsafe_set dest (destpos+i) (Array.unsafe_get src (srcpos+i)) done ) else ( for i = len-1 downto 0 do Array.unsafe_set dest (destpos+i) (Array.unsafe_get src (srcpos+i)) done ) ) let int_blit src srcpos dest destpos len = !int_blit_ref src srcpos dest destpos len let int_series_ref = ref (fun src srcpos dst dstpos len n -> if (len < 0 || srcpos < 0 || dstpos < 0 || srcpos+len > Array.length src || dstpos+len > Array.length dst) then invalid_arg "Netaux.ArrayAux.int_series"; let s = ref n in for i = 0 to len-1 do Array.unsafe_set dst (dstpos+i) !s; s := !s + Array.unsafe_get src (srcpos+i) done ) let int_series src srcpos dst dstpos len n = !int_series_ref src srcpos dst dstpos len n end ocamlnet-4.1.6/src/netstring/netaux.mli0000644000175000017500000000425013274252307016571 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) (** Internal auxiliary functions * * This is an internal module. *) (* Auxiliary stuff *) module KMP : sig (* An implementation of the Knuth-Morris-Pratt algorithm *) (* Credits go to Alain Frisch who suggested this algorithm *) type pattern val make_pattern : string -> pattern (* Prepares the passed pattern *) val find_pattern : pattern -> ?pos:int -> ?len:int -> Bytes.t -> int (* Searches the position where the pattern or a prefix of the pattern * occurs in the substring from position [pos] to [pos+len-1]. * Possible return values p: * - pos <= p <= pos+len-length(pattern): * The pattern occurs at position p in the string, i.e. * string.[p+k] = pattern.[k], for all 0 <= k < length(pattern). * Furthermore, the returned position p is the first such position. * - pos+len-length(pattern) < p < pos+len * The string ends with a prefix of the pattern, i.e. * string.[p+k] = pattern[k], for all 0 <= k < pos+len-p. * - p = pos+len * Neither does the pattern occur in the string, nor is the * (non-empty) suffix of the string a prefix of the pattern. * * Defaults: * ~pos = 0 * ~len = length(string)-pos = "until the end of the string" *) end module ArrayAux : sig val int_blit : int array -> int -> int array -> int -> int -> unit (** A specialisation of [Array.blit] for int arrays. * (Performance reasons.) *) val int_series : int array -> int -> int array -> int -> int -> int -> unit (** [int_series src srcpos dst dstpos len n]: * Computes for every [i], [0 <= i < len]: * [dst.(dstpos+i) = n + SUM(j=0..(i-1): src.(srcpos+j)) ] * * It is expected that [src == dst] implies [srcpos >= dstpos]. *) (**/**) val int_blit_ref : (int array -> int -> int array -> int -> int -> unit) ref (* Used by [Netaccel] to override the built-in implementation *) val int_series_ref : (int array -> int -> int array -> int -> int -> int -> unit) ref (* Used by [Netaccel] to override the built-in implementation *) end ocamlnet-4.1.6/src/netstring/netbuffer.ml0000644000175000017500000002442213274252307017077 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) open Netsys_types type t = { mutable buffer : Bytes.t; mutable buffer_length : int; (* = String.length buffer *) mutable length : int; create_length : int; } (* To help the garbage collector: * The 'buffer' has a minimum length of 31 bytes. This minimum can still * be stored in the minor heap. * The 'buffer' has a length which is always near a multiple of two. This * limits the number of different bucket sizes, and simplifies reallocation * of freed memory. *) (* Optimal string length: * Every string takes: 1 word for the header, enough words for the * contents + 1 Null byte (for C compatibility). * If the buffer grows, it is best to use a new string length such * that the number of words is exactly twice as large as for the previous * string. * n: length of the previous string in bytes * w: storage size of the previous string in words * n': length of the new string in bytes * w' = 2*w: storage size of the new string in words * * w = (n+1) / word_length + 1 * [it is assumed that (n+1) is always a multiple of word_length] * * n' = (2*w - 1) * word_length - 1 * * n' = [2 * ( [n+1] / word_length + 1) - 1] * word_length - 1 * = ... * = (2*n + 2) + word_length - 1 * = 2 * n + word_length + 1 * * n'+1 is again a multiple of word_length: * n'+1 = 2*n + 2 + word_length * = 2*(n+1) + word_length * = a multiple of word_length because n+1 is a multiple of word_length *) let word_length = Sys.word_size / 8 (* in bytes *) let create n = let bl = max n 31 in { buffer = Bytes.create bl; buffer_length = bl; length = 0; create_length = n } let reset b = let n = b.create_length in let bl = max n 31 in b.buffer <- Bytes.create bl; b.buffer_length <- bl; b.length <- 0 let contents b = Bytes.sub_string b.buffer 0 b.length let to_bytes b = Bytes.sub b.buffer 0 b.length let to_tstring_poly : type s . t -> s Netstring_tstring.tstring_kind -> s = fun b kind -> match kind with | Netstring_tstring.String_kind -> contents b | Netstring_tstring.Bytes_kind -> to_bytes b | Netstring_tstring.Memory_kind -> let m = Bigarray.Array1.create Bigarray.char Bigarray.c_layout b.length in Netsys_mem.blit_bytes_to_memory b.buffer 0 m 0 b.length; m let to_tstring : type s . t -> s Netstring_tstring.tstring_kind -> tstring = fun b kind -> let s = to_tstring_poly b kind in match kind with | Netstring_tstring.String_kind -> `String s | Netstring_tstring.Bytes_kind -> `Bytes s | Netstring_tstring.Memory_kind -> `Memory s let e_get() = invalid_arg "Netbuffer.get" let get b k = if k < 0 || k >= b.length then e_get(); Bytes.unsafe_get b.buffer k let nth = get let sub_invalid() = raise (Invalid_argument "Netbuffer.sub") let sub_bytes b k n = if k < 0 || n < 0 || k > b.length-n then sub_invalid(); Bytes.sub b.buffer k n let sub b k n = if k < 0 || n < 0 || k > b.length-n then sub_invalid(); Bytes.sub_string b.buffer k n let blit_to_bytes_invalid() = raise (Invalid_argument "Netbuffer.blit_to_bytes") let blit_to_bytes b srcpos dest destpos n = if srcpos < 0 || n < 0 || srcpos > b.length-n then blit_to_bytes_invalid(); Bytes.blit b.buffer srcpos dest destpos n let blit = blit_to_bytes let blit_to_string = blit_to_bytes let blit_to_memory b srcpos dest destpos n = if srcpos < 0 || n < 0 || srcpos > b.length-n then raise (Invalid_argument "Netbuffer.blit_to_memory"); Netsys_mem.blit_bytes_to_memory b.buffer srcpos dest destpos n let blit_to_tbuffer b srcpos dest destpos n = match dest with | `Bytes s | `String s -> blit_to_bytes b srcpos s destpos n | `Memory m -> blit_to_memory b srcpos m destpos n let unsafe_buffer b = b.buffer let length b = b.length let alloc_space b n = let rec new_size s = if s >= n then s else new_size(2*s + word_length + 1) in let size = min (new_size b.buffer_length) Sys.max_string_length in if size < n then failwith "Netbuffer: string too large"; let buffer' = Bytes.create size in Bytes.blit b.buffer 0 buffer' 0 b.length; b.buffer <- buffer'; b.buffer_length <- size let ensure_space b n = (* Ensure that there are n bytes space in b *) if n > b.buffer_length then alloc_space b n let add_internal blit b s k l = ensure_space b (l + b.length); blit s k b.buffer b.length l; b.length <- b.length + l let add_substring b s k l = if k < 0 || l < 0 || k > String.length s-l then invalid_arg "Netbuffer.add_substring"; add_internal Bytes.blit_string b s k l let add_sub_string = add_substring let add_string b s = add_substring b s 0 (String.length s) let add_subbytes b s k l = if k < 0 || l < 0 || k > Bytes.length s-l then invalid_arg "Netbuffer.add_subbytes"; add_internal Bytes.blit b s k l let add_bytes b s = add_subbytes b s 0 (Bytes.length s) let add_submemory b s k l = if k < 0 || l < 0 || k > Bigarray.Array1.dim s-l then invalid_arg "Netbuffer.add_submemory"; add_internal Netsys_mem.blit_memory_to_bytes b s k l let add_sub_memory = add_submemory let add_subtstring b ts k l = match ts with | `String s -> add_substring b s k l | `Bytes s -> add_subbytes b s k l | `Memory s -> add_submemory b s k l let add_tstring b ts = add_subtstring b ts 0 (Netsys_impl_util.tstring_length ts) let add_subtstring_poly b ops s k l = let open Netstring_tstring in add_internal ops.blit_to_bytes b s k l let add_tstring_poly b ops s = let open Netstring_tstring in add_subtstring_poly b ops s 0 (ops.length s) let add_buffer b1 b2 = add_internal Bytes.blit b1 b2.buffer 0 b2.length let add_char b c = let l = b.length in ensure_space b (l+1); Bytes.unsafe_set b.buffer l c; b.length <- l + 1 let add_char_2 b c1 c2 = let l = b.length in ensure_space b (l+2); Bytes.unsafe_set b.buffer l c1; Bytes.unsafe_set b.buffer (l+1) c2; b.length <- l + 2 let add_char_4 b c1 c2 c3 c4 = let l = b.length in ensure_space b (l+4); Bytes.unsafe_set b.buffer l c1; Bytes.unsafe_set b.buffer (l+1) c2; Bytes.unsafe_set b.buffer (l+2) c3; Bytes.unsafe_set b.buffer (l+3) c4; b.length <- l + 4 let space_for_additions ?len b = match len with Some l -> ensure_space b (b.length + l); l | None -> ensure_space b (b.length + 1); b.buffer_length - b.length let advance b n = let l = b.length + n in if n < 0 || l > b.buffer_length then invalid_arg "Netbuffer.advance"; b.length <- l let add_inplace ?len b f = let len' = space_for_additions ?len b in let n = f b.buffer b.length len' in advance b n; n let area_for_additions ?len b = let len' = space_for_additions ?len b in (b.buffer, b.length, len') let insert_internal name blit length b p s k l = if p < 0 || p > b.length || k < 0 || l < 0 || k > length s - l then invalid_arg ("Netbuffer." ^ name); ensure_space b (l + b.length); Bytes.unsafe_blit b.buffer p b.buffer (p+l) (b.length - p); blit s k b.buffer p l; b.length <- b.length + l let insert_substring = insert_internal "insert_substring" Bytes.blit_string String.length let insert_sub_string = insert_substring let insert_string b p s = insert_internal "insert_string" Bytes.blit_string String.length b p s 0 (String.length s) let insert_subbytes = insert_internal "insert_subbytes" Bytes.blit Bytes.length let insert_submemory = insert_internal "inser_submemory" Netsys_mem.blit_memory_to_bytes Bigarray.Array1.dim let insert_subtstring b p ts k l = match ts with | `String s -> insert_substring b p s k l | `Bytes s -> insert_subbytes b p s k l | `Memory s -> insert_submemory b p s k l let insert_char_invalid() = invalid_arg "Netbuffer.insert_char" let insert_char b p c = if p < 0 || p > b.length then insert_char_invalid(); ensure_space b (1 + b.length); Bytes.unsafe_blit b.buffer p b.buffer (p+1) (b.length - p); Bytes.set b.buffer p c; b.length <- b.length + 1 let e_set() = invalid_arg "Netbuffer.set" let set b k c = if k < 0 || k >= b.length then e_set(); Bytes.unsafe_set b.buffer k c let put_string_invalid() = invalid_arg "Netbuffer.put_string" let put_string b p s = if p < 0 || p > b.length then put_string_invalid(); let len = max b.length (p + String.length s) in ensure_space b len; String.unsafe_blit s 0 b.buffer p (String.length s); b.length <- len let blit_from_internal name blit length src srcpos b p n = if p < 0 || p > b.length || srcpos < 0 || n < 0 || srcpos > length src - n then invalid_arg ("Netbuffer." ^ name); let len = max b.length (p + n) in ensure_space b len; blit src srcpos b.buffer p n; b.length <- len let blit_from_string = blit_from_internal "blit_from_string" Bytes.blit_string String.length let blit_from_bytes = blit_from_internal "blit_from_bytes" Bytes.blit Bytes.length let blit_from_memory = blit_from_internal "blit_from_memory" Netsys_mem.blit_memory_to_bytes Bigarray.Array1.dim let blit_from_tstring ts p1 b p2 n = match ts with | `String s -> blit_from_string s p1 b p2 n | `Bytes s -> blit_from_bytes s p1 b p2 n | `Memory s -> blit_from_memory s p1 b p2 n let delete b k l = (* deletes l bytes at position k in b *) let n = b.buffer_length in if k+l <> n && k <> n then Bytes.blit b.buffer (k+l) b.buffer k (n-l-k); b.length <- b.length - l; () let try_shrinking b = (* If the buffer size decreases drastically, reallocate the buffer *) if b.length < (b.buffer_length / 2) then begin let rec new_size s = if s >= b.length then s else new_size(2*s + word_length + 1) in let size = new_size 31 in let buffer' = Bytes.create size in Bytes.blit b.buffer 0 buffer' 0 b.length; b.buffer <- buffer'; b.buffer_length <- size end let clear b = delete b 0 (b.length) let index_from_invalid() = raise (Invalid_argument "Netbuffer.index_from") let index_from b k c = if k > b.length then index_from_invalid(); let p = Bytes.index_from b.buffer k c in if p >= b.length then raise Not_found; p let print_buffer b = Format.printf "" b.length b.buffer_length ;; ocamlnet-4.1.6/src/netstring/netbuffer.mli0000644000175000017500000002112413274252307017244 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) (** A Netbuffer.t is a buffer that can grow and shrink dynamically. *) open Netsys_types type t val create : int -> t (** Creates a netbuffer which allocates initially this number of bytes. * The logical length is zero. *) val contents : t -> string (** Returns the contents of the buffer as fresh string. *) val to_bytes : t -> Bytes.t (** Returns the contents of the buffer as fresh string. *) val to_tstring_poly : t -> 's Netstring_tstring.tstring_kind -> 's (** Return the buffer in the format as selected by the arg *) val to_tstring : t -> _ Netstring_tstring.tstring_kind -> tstring (** Returns the buffer as tagged string, selecting the chosen representation *) val length : t -> int (** Returns the logical length of the buffer *) (** {2 Extracting strings} *) val get : t -> int -> char (** [get nb pos]: Get the character at [pos] *) val nth : t -> int -> char (** Alias for [get] *) val sub : t -> int -> int -> string (** [sub nb k n]: returns the n characters starting at position [n] from * netbuffer [nb] as fresh string *) val sub_bytes : t -> int -> int -> Bytes.t (** Same for bytes *) (** {2 Extraction with blit} *) val blit_to_bytes : t -> int -> Bytes.t -> int -> int -> unit (** [blit_to_bytes nb srcpos dest destpos len]: Copies the [len] bytes at * position [srcpos] from [nb] to the string [dest] at position [destpos]. *) val blit_to_string : t -> int -> Bytes.t -> int -> int -> unit DEPRECATED("Use blit_to_bytes instead.") val blit : t -> int -> Bytes.t -> int -> int -> unit (** Compatibility name for [blit_to_bytes] *) val blit_to_memory : t -> int -> Netsys_mem.memory -> int -> int -> unit (** [blit_to_memory nb srcpos dest destpos len]: Copies the [len] bytes at * position [srcpos] from [nb] to the membuffer [dest] at position [destpos]. *) val blit_to_tbuffer : t -> int -> tbuffer -> int -> int -> unit (** Blits to a tagged buffer *) (** {2 Appending strings} *) val add_string : t -> string -> unit (** [add_string nb s]: Adds a copy of the string [s] to the logical end of * the netbuffer [nb]. If necessary, [nb] grows. *) val add_bytes : t -> Bytes.t -> unit (** Same for bytes *) val add_tstring : t -> tstring -> unit (** Same for tagged string *) val add_tstring_poly : t -> 's Netstring_tstring.tstring_ops -> 's -> unit (** Polymorphic version *) val add_substring : t -> string -> int -> int -> unit (** [add_substring nb s k n]: Adds the substring of [s] starting at position * [k] with length [n] to the logical end of the netbuffer [nb]. If necessary, * [nb] grows. * * This is semantically the same as * [add_string nb (String.sub s k n)], but the extra copy is avoided. *) val add_subbytes : t -> Bytes.t -> int -> int -> unit (** Same for bytes *) val add_subtstring : t -> tstring -> int -> int -> unit (** Same for tagged string *) val add_sub_string : t -> string -> int -> int -> unit DEPRECATED("Use add_substring instead.") val add_submemory : t -> Netsys_mem.memory -> int -> int -> unit (** Same as [add_substring], but gets data from a memory buffer *) val add_sub_memory : t -> Netsys_mem.memory -> int -> int -> unit DEPRECATED("Use add_submemory instead.") val add_subtstring_poly : t -> 's Netstring_tstring.tstring_ops -> 's -> int -> int -> unit (** Polymorphic version *) val add_char : t -> char -> unit (** [add_char nb c]: Adds a single char at the end of the buffer *) val add_char_2 : t -> char -> char -> unit (** [add_char_2 nb c1 c2]: Adds two chars at the end of the buffer *) val add_char_4 : t -> char -> char -> char -> char -> unit (** [add_char_4 nb c1 c2 c3 c4]: Adds four chars at the end of the buffer *) val add_inplace : ?len:int -> t -> (Bytes.t -> int -> int -> int) -> int (** [add_inplace nb f]: Calls the function [f] to add bytes to the * netbuffer [nb]. The arguments of [f] are the buffer, the position * in the buffer, and the maximum length. The function [f] must return * the actual number of added bytes; this number is also returned by * [add_inplace]. * * Example: let n = add_inplace nb (Pervasives.input ch) * * The argument [len] is the number of bytes to add (second argument of * [f]). It defaults to the number of free bytes in the buffer after space * for at least one byte has been allocated. *) val add_buffer : t -> t -> unit (** [add_buffer nb1 nb2]: Adds the contents of [nb2] to the end of [nb1] *) val area_for_additions : ?len:int -> t -> (Bytes.t * int * int) val advance : t -> int -> unit (** These two functions work together, so that the effect of [add_inplace] can be obtained in two steps. First, the user calls {[ let (s,pos,len) = area_for_additions nb ]} to get the area where to put new data of length [n], with [n <= len]. After this the data is made valid by {[ advance n ]} *) (** {2 Inserting strings} *) val insert_string : t -> int -> string -> unit (** [insert_string nb p s]: Inserts the value of string [s] at position * [p] into the netbuffer [nb] *) val insert_substring : t -> int -> string -> int -> int -> unit (** [insert_string nb p s k n]: Inserts a substring of string [s] at position * [p] into the netbuffer [nb]. The substring is denoted by position [k] * and has length [n] *) val insert_sub_string : t -> int -> string -> int -> int -> unit DEPRECATED("Use insert_substring instead.") val insert_subbytes : t -> int -> Bytes.t -> int -> int -> unit (** Same for bytes *) val insert_subtstring : t -> int -> tstring -> int -> int -> unit (** Same for tagged string *) val insert_submemory : t -> int -> memory -> int -> int -> unit (** Same for memory *) val insert_char : t -> int -> char -> unit (** [insert_char nb p c]: Inserts character [c] at position [p] into * the netbuffer [nb] *) (** {2 Overwriting strings} *) val set : t -> int -> char -> unit (** [set nb pos c]: Sets the character at [pos] to [c] *) val put_string : t -> int -> string -> unit (** [put_string nb pos s]: Copies the string [s] to the position [pos] of netbuffer [nb] *) val blit_from_string : string -> int -> t -> int -> int -> unit (** [blit_from_string src srcpos dest destpos len]: Copies the [len] bytes * at position [srcpos] from the string [src] to the netbuffer [dest] at * position [destpos]. * * It is possible to copy the string beyond the end of the buffer. The * buffer is automatically enlarged in this case. *) val blit_from_bytes : Bytes.t -> int -> t -> int -> int -> unit (** Same for bytes *) val blit_from_memory : memory -> int -> t -> int -> int -> unit (** Same for memory *) val blit_from_tstring : tstring -> int -> t -> int -> int -> unit (** Same for tagged string *) (** {2 Deleting} *) val delete : t -> int -> int -> unit (** [delete nb k n]: Deletes the [n] bytes at position [k] of netbuffer * [nb] in-place. * * The netbuffer does not shrink, however, i.e. the free space is not * given back to the memory manager. *) val clear : t -> unit (** Deletes all contents from the buffer. As [delete], the netbuffer does * not shrink. *) val reset : t -> unit (** Empty the buffer, deallocate the internal string, and replace it with a new string of length [n] that was allocated by {!Netbuffer.create} [n]. *) val try_shrinking : t -> unit (** [try_shrinking nb]: If the length of the buffer is less than half of * the allocated space, the netbuffer is reallocated in order to save * memory. *) (** {2 Searching} *) val index_from : t -> int -> char -> int (** [index_from nb k c]: Searches the character [c] in the netbuffer beginning * at position [k]. If found, the position of the left-most occurence is * returned. Otherwise, [Not_found] is raised. *) (** {2 Miscelleneous} *) val unsafe_buffer : t -> Bytes.t (** {b Warning! This is a low-level function!} * Returns the current string that internally holds the buffer. * The byte positions 0 to length - 1 actually store the contents of * the buffer. You can directly read and modify the buffer. Note that * there is no protection if you read or write positions beyond the * length of the buffer. *) val print_buffer : t -> unit (** For the toploop *) (* MISSING: searching substrings *) ocamlnet-4.1.6/src/netstring/netchannels.ml0000644000175000017500000015454713274252307017435 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) open Netsys_types open Netstring_tstring exception Closed_channel exception Buffer_underrun exception Command_failure of Unix.process_status let () = Netexn.register_printer (Command_failure(Unix.WEXITED 0)) (fun e -> match e with | Command_failure ps -> let ps_str = match ps with | Unix.WEXITED n -> "WEXITED " ^ string_of_int n | Unix.WSIGNALED n -> "WSIGNALED " ^ string_of_int n | Unix.WSTOPPED n -> "WSTOPPED " ^ string_of_int n in "Netchannels.Command_failure(" ^ ps_str ^ ")" | _ -> assert false ) let () = Netsys_signal.init() class type rec_in_channel = object method input : Bytes.t -> int -> int -> int method close_in : unit -> unit end class type raw_in_channel = object inherit rec_in_channel method pos_in : int (* number of read characters *) end type input_result = [ `Data of int | `Separator of string ] class type enhanced_raw_in_channel = object inherit raw_in_channel method private enhanced_input_line : unit -> string method private enhanced_input : Bytes.t -> int -> int -> input_result end class type rec_out_channel = object method output : Bytes.t -> int -> int -> int method close_out : unit -> unit method flush : unit -> unit end class type raw_out_channel = object inherit rec_out_channel method pos_out : int (* number of written characters *) end class type raw_io_channel = object inherit raw_in_channel inherit raw_out_channel end class type compl_in_channel = object (* Classic operations: *) method really_input : Bytes.t -> int -> int -> unit method really_input_string : int -> string method input_char : unit -> char method input_line : unit -> string method input_byte : unit -> int end class type in_obj_channel = object inherit raw_in_channel inherit compl_in_channel end class type compl_out_channel = object (* Classic operations: *) method really_output : Bytes.t -> int -> int -> unit method really_output_string : string -> int -> int -> unit method output_char : char -> unit method output_bytes : Bytes.t -> unit method output_string : string -> unit method output_byte : int -> unit method output_buffer : Buffer.t -> unit method output_channel : ?len:int -> in_obj_channel -> unit (* ~len: optionally limit the number of bytes *) end class type out_obj_channel = object inherit raw_out_channel inherit compl_out_channel end class type io_obj_channel = object inherit in_obj_channel inherit out_obj_channel end class type trans_out_obj_channel = object inherit out_obj_channel method commit_work : unit -> unit method rollback_work : unit -> unit end ;; (* error_behavior: currently not used. This was a proposal to control * error handling, but it is not clear whether it is really * useful or not. * I do not delete these types because they remind us of this * possibility. Maybe we find an outstanding example for them, and * want to have them back. *) type error_behavior = [ `Close | `Fun of (unit -> unit) | `None ] type extended_error_behavior = [ `Close | `Rollback | `Fun of (unit -> unit) | `None ] type close_mode = [ `Commit | `Rollback ];; (* Delegation *) class rec_in_channel_delegation ?(close=true) (ch:rec_in_channel) = object(self) method input = ch#input method close_in() = if close then ch#close_in() end class raw_in_channel_delegation ?(close=true) (ch:raw_in_channel) = object(self) method input = ch#input method close_in() = if close then ch#close_in() method pos_in = ch#pos_in end class in_obj_channel_delegation ?(close=true) (ch:in_obj_channel) = object(self) method input = ch#input method close_in() = if close then ch#close_in() method pos_in = ch#pos_in method really_input = ch#really_input method really_input_string = ch#really_input_string method input_char = ch#input_char method input_line = ch#input_line method input_byte = ch#input_byte end class rec_out_channel_delegation ?(close=true) (ch:rec_out_channel) = object(self) method output = ch#output method close_out() = if close then ch#close_out() method flush = ch#flush end class raw_out_channel_delegation ?(close=true) (ch:raw_out_channel) = object(self) method output = ch#output method close_out() = if close then ch#close_out() method flush = ch#flush method pos_out = ch#pos_out end class out_obj_channel_delegation ?(close=true) (ch:out_obj_channel) = object(self) method output = ch#output method close_out() = if close then ch#close_out() method flush = ch#flush method pos_out = ch#pos_out method really_output = ch#really_output method really_output_string = ch#really_output_string method output_char = ch#output_char method output_string = ch#output_string method output_bytes = ch#output_bytes method output_byte = ch#output_byte method output_buffer = ch#output_buffer method output_channel = ch#output_channel end (****************************** input ******************************) class input_channel ?(onclose=fun () -> ()) ch (* : in_obj_channel *) = object (self) val ch = ch val mutable closed = false method private complain_closed() = raise Closed_channel method input buf pos len = if closed then self # complain_closed(); try if len=0 then raise Sys_blocked_io; let n = Pervasives.input ch buf pos len in if n=0 then raise End_of_file else n with Sys_blocked_io -> 0 method really_input buf pos len = if closed then self # complain_closed(); Pervasives.really_input ch buf pos len method really_input_string len = if closed then self # complain_closed(); #ifdef HAVE_BYTES Pervasives.really_input_string ch len #else let buf = String.create len in Pervasives.really_input ch buf 0 len; buf #endif method input_char () = if closed then self # complain_closed(); Pervasives.input_char ch method input_line () = if closed then self # complain_closed(); Pervasives.input_line ch method input_byte () = if closed then self # complain_closed(); Pervasives.input_byte ch method close_in () = if not closed then ( Pervasives.close_in ch; closed <- true; onclose() ) method pos_in = if closed then self # complain_closed(); Pervasives.pos_in ch end ;; let input_channel = new input_channel class input_command cmd = let ch = Unix.open_process_in cmd in object (self) inherit input_channel ch as super method close_in() = if not closed then ( let p = Unix.close_process_in ch in closed <- true; if p <> Unix.WEXITED 0 then raise (Command_failure p); ) end ;; let input_command = new input_command class ['t] input_generic name ops ?(pos = 0) ?len (s:'t) : in_obj_channel = object (self) val mutable str = s val mutable str_len = match len with None -> ops.length s | Some l -> pos + l val mutable str_pos = pos val mutable closed = false initializer if str_pos < 0 || str_pos > ops.length str || str_len < 0 || str_len > ops.length s then invalid_arg ("new Netchannels." ^ name) method private complain_closed() = raise Closed_channel method input buf pos len = if closed then self # complain_closed(); if pos < 0 || len < 0 || pos+len > Bytes.length buf then invalid_arg "input"; let n = min len (str_len - str_pos) in ops.blit_to_bytes str str_pos buf pos n; str_pos <- str_pos + n; if n=0 && len>0 then raise End_of_file else n method really_input buf pos len = if closed then self # complain_closed(); if pos < 0 || len < 0 || pos+len > Bytes.length buf then invalid_arg "really_input"; let n = self # input buf pos len in if n <> len then raise End_of_file; () method really_input_string len = if closed then self # complain_closed(); if len < 0 then invalid_arg "really_input_string"; let buf = Bytes.create len in let n = self # input buf 0 len in if n <> len then raise End_of_file; Bytes.to_string buf method input_char() = if closed then self # complain_closed(); if str_pos >= str_len then raise End_of_file; let c = ops.get str str_pos in str_pos <- str_pos + 1; c method input_line() = if closed then self # complain_closed(); try let k = ops.index_from str str_pos '\n' in (* CHECK: Are the different end of line conventions important here? *) let line = ops.substring str str_pos (k - str_pos) in str_pos <- k+1; line with Not_found -> if str_pos >= str_len then raise End_of_file; (* Implicitly add linefeed at the end of the file: *) let line = ops.substring str str_pos (str_len - str_pos) in str_pos <- str_len; line method input_byte() = Char.code (self # input_char()) method close_in() = (* str <- ""; *) closed <- true; method pos_in = if closed then self # complain_closed(); str_pos end ;; class input_string = [string] input_generic "input_string" Netstring_tstring.string_ops let input_string = new input_string class input_bytes = [Bytes.t] input_generic "input_bytes" Netstring_tstring.bytes_ops let input_bytes = new input_bytes class input_memory = [memory] input_generic "input_memory" Netstring_tstring.memory_ops let input_memory = new input_memory let input_tstring ?pos ?len ts = match ts with | `String s -> input_string ?pos ?len s | `Bytes s -> input_bytes ?pos ?len s | `Memory s -> input_memory ?pos ?len s class type nb_in_obj_channel = object inherit in_obj_channel method shutdown : unit -> unit end class input_netbuffer ?(keep_data=false) b : nb_in_obj_channel = object (self) val mutable b = b val mutable offset = 0 val mutable eof = false val mutable closed = false val mutable ch_pos = 0 method private complain_closed() = raise Closed_channel method private input_into : type t . (int -> int -> t) -> int -> t = fun f len -> let n = min len (Netbuffer.length b - offset) in if n = 0 && len>0 then begin if eof then raise End_of_file else raise Buffer_underrun end else begin let result = f offset n in if keep_data then offset <- offset + n else Netbuffer.delete b 0 n; ch_pos <- ch_pos + n; result end method input buf pos len = if closed then self # complain_closed(); if pos < 0 || len < 0 || pos > Bytes.length buf - len then invalid_arg "input"; self # input_into (fun b_offs n -> Netbuffer.blit b b_offs buf pos n; n ) len method really_input buf pos len = if closed then self # complain_closed(); if pos < 0 || len < 0 || pos+len > Bytes.length buf then invalid_arg "really_input"; let n = self # input buf pos len in if n <> len then raise End_of_file; () method really_input_string len = if closed then self # complain_closed(); if len < 0 then invalid_arg "really_input_string"; self # input_into (fun b_offs n -> if n <> len then raise End_of_file; Netbuffer.sub b b_offs n ) len method input_char() = if closed then self # complain_closed(); let s = Bytes.create 1 in match self # input s 0 1 with | 1 -> Bytes.get s 0 | _ -> assert false method input_line() = if closed then self # complain_closed(); try let k = Netbuffer.index_from b offset '\n' in (* CHECK: Are the different end of line conventions important here? *) let line = Netbuffer.sub b offset (k - offset) in if keep_data then offset <- offset + k + 1 else Netbuffer.delete b 0 (k+1); ch_pos <- ch_pos + k + 1; line with Not_found -> if eof then begin let n = Netbuffer.length b - offset in if n=0 then raise End_of_file; (* Implicitly add linefeed at the end of the file: *) let line = Netbuffer.sub b offset n in if keep_data then offset <- offset + n else Netbuffer.clear b; ch_pos <- ch_pos + n; line end else raise Buffer_underrun method input_byte() = Char.code (self # input_char()) method close_in() = closed <- true; method pos_in = if closed then self # complain_closed(); ch_pos method shutdown() = eof <- true end ;; let create_input_netbuffer ?keep_data b = let ch = new input_netbuffer ?keep_data b in (ch :> in_obj_channel), (ch # shutdown) ;; let lexbuf_of_in_obj_channel (objch : in_obj_channel) : Lexing.lexbuf = let fill_buffer buf len = try let n = objch # input buf 0 len in if n=0 then failwith "Netchannels.lexbuf_of_in_obj_channel: No data (non-blocking I/O?)"; n with End_of_file -> 0 in Lexing.from_function fill_buffer ;; let bytes_of_in_obj_channel (objch : in_obj_channel) : Bytes.t = (* There are similarities to copy_channel below. *) (* The following algorithm uses only up to 2 * N memory, not 3 * N * as with the Buffer module. *) let slen = 1024 in let l = ref [] in let k = ref 0 in try while true do let s = Bytes.create slen in let n = objch # input s 0 slen in if n = 0 then failwith "Netchannels.bytes_of_in_obj_channel: No data (non-blocking I/O?)"; k := !k + n; if n < slen then l := (Bytes.sub s 0 n) :: !l else l := s :: !l; done; assert false with End_of_file -> let s = Bytes.create !k in while !l <> [] do match !l with u :: l' -> let n = Bytes.length u in k := !k - n; Bytes.blit u 0 s !k n; l := l' | [] -> assert false done; assert (!k = 0); s ;; let string_of_in_obj_channel objch = Bytes.unsafe_to_string (bytes_of_in_obj_channel objch) let lines_of_in_obj_channel ch = let acc = ref [] in try while true do acc := ch#input_line() :: !acc done; assert false with | End_of_file -> List.rev !acc ;; let with_in_obj_channel ch f = try let result = f ch in ( try ch # close_in() with Closed_channel -> ()); result with e -> ( try ch # close_in() with Closed_channel -> ()); raise e ;; class virtual augment_raw_in_channel = object (self) method virtual input : Bytes.t -> int -> int -> int method virtual close_in : unit -> unit method virtual pos_in : int method really_input s pos len = let rec read_rest n = if n < len then let m = self # input s (pos+n) (len-n) in if m = 0 then raise Sys_blocked_io; read_rest (n+m) else () in read_rest 0 method really_input_string len = let b = Bytes.create len in self#really_input b 0 len; Bytes.unsafe_to_string b method input_char () = let s = Bytes.create 1 in self # really_input s 0 1; Bytes.get s 0 method input_byte () = let s = Bytes.create 1 in self # really_input s 0 1; Char.code (Bytes.get s 0) method input_line () = let s = Bytes.create 1 in let b = Buffer.create 80 in let m = self # input s 0 1 in if m = 0 then raise Sys_blocked_io; while Bytes.get s 0 <> '\n' do Buffer.add_char b (Bytes.get s 0); try let m = self # input s 0 1 in if m = 0 then raise Sys_blocked_io; with End_of_file -> Bytes.set s 0 '\n' done; Buffer.contents b end ;; class lift_raw_in_channel r = object(self) inherit augment_raw_in_channel method input s p l = r # input s p l method close_in () = r # close_in() method pos_in = r # pos_in end;; class lift_rec_in_channel ?(start_pos_in = 0) (r : rec_in_channel) = object(self) inherit augment_raw_in_channel val mutable closed = false val mutable pos_in = start_pos_in method input s p l = if closed then raise Closed_channel; let n = r # input s p l in pos_in <- pos_in + n; n method close_in () = if not closed then ( closed <- true; r # close_in() ) method pos_in = if closed then raise Closed_channel; pos_in end;; type eol_status = EOL_not_found | EOL_partially_found of int (* Position *) | EOL_found of int * int (* Position, length *) exception Pass_through class buffered_raw_in_channel ?(eol = [ "\n" ]) ?(buffer_size = 4096) ?(pass_through = max_int) (ch : raw_in_channel) : enhanced_raw_in_channel = object (self) val out = ch val bufsize = buffer_size val buf = Bytes.create buffer_size val mutable bufpos = 0 val mutable buflen = 0 val mutable eof = false val mutable closed = false initializer if List.exists(fun s -> s = "") eol then invalid_arg "Netchannels.buffered_raw_in_channel"; if List.exists(fun s -> String.length s > buffer_size) eol then invalid_arg "Netchannels.buffered_raw_in_channel"; method input s pos len = if closed then raise Closed_channel; try if len > 0 then ( if bufpos = buflen then ( if len >= pass_through then raise Pass_through else self # refill(); ); let n = min len (buflen - bufpos) in Bytes.blit buf bufpos s pos n; bufpos <- bufpos + n; n ) else 0 with Pass_through -> ch # input s pos len method private refill() = let d = bufpos in if d > 0 && d < buflen then ( Bytes.blit buf d buf 0 (buflen-d) ); bufpos <- 0; buflen <- buflen - d; try assert(bufsize > buflen); (* otherwise problems... *) let n = ch # input buf buflen (bufsize-buflen) in (* or End_of_file *) if n = 0 then raise Sys_blocked_io; buflen <- buflen+n; with End_of_file as exn -> eof <- true; raise exn method close_in () = if not closed then ( ch # close_in(); closed <- true ) method pos_in = (ch # pos_in) - (buflen - bufpos) method private find_eol() = (* Try all strings from [eol] in turn. For every string we may * have three results: * - Not found * - Partially found * - Found * The eol delimiter is only found if there are no partial * results, and at least one positive result. The longest * string is taken. *) let find_this_eol eol = (* Try to find the eol string [eol] in [buf] starting at * [bufpos] up to [buflen]. Return [eol_status]. *) let eol0 = eol.[0] in try let k = Bytes.index_from buf bufpos eol0 in (* or Not_found *) if k>=buflen then raise Not_found; let k' = min buflen (k+String.length eol) in let s = Bytes.sub_string buf k (k' - k) in if s = eol then EOL_found(k, String.length eol) else if not eof && String.sub eol 0 (String.length s) = s then EOL_partially_found k else EOL_not_found with Not_found -> EOL_not_found in let rec find_best_eol best eol_result = match eol_result with EOL_not_found :: eol_result' -> find_best_eol best eol_result' | EOL_partially_found pos as r :: eol_result' -> ( match best with EOL_partially_found pos' -> if pos < pos' then find_best_eol r eol_result' else find_best_eol best eol_result' | _ -> find_best_eol r eol_result' ) | EOL_found(pos,len) as r :: eol_result' -> ( match best with EOL_found(pos',len') -> if pos < pos' || (pos = pos' && len > len') then find_best_eol r eol_result' else find_best_eol best eol_result' | EOL_partially_found _ -> find_best_eol best eol_result' | EOL_not_found -> find_best_eol r eol_result' ) | [] -> best in let eol_results = List.map find_this_eol eol in find_best_eol EOL_not_found eol_results method private enhanced_input s pos len : input_result = if closed then raise Closed_channel; if len > 0 then ( if bufpos = buflen then ( self # refill(); (* may raise End_of_file *) ); let result = ref None in while !result = None do let best = self # find_eol() in match best with EOL_not_found -> let n = min len (buflen - bufpos) in Bytes.blit buf bufpos s pos n; bufpos <- bufpos + n; result := Some(`Data n) | EOL_found(p,l) -> if p = bufpos then ( bufpos <- bufpos + l; result := Some(`Separator(Bytes.sub_string buf p l)) ) else ( let n = min len (p - bufpos) in Bytes.blit buf bufpos s pos n; bufpos <- bufpos + n; result := Some(`Data n) ) | EOL_partially_found p -> if p = bufpos then ( try self # refill() with End_of_file -> () (* ... and continue! *) ) else ( let n = min len (p - bufpos) in Bytes.blit buf bufpos s pos n; bufpos <- bufpos + n; result := Some(`Data n) ) done; match !result with None -> assert false | Some r -> r ) else `Data 0 method private enhanced_input_line() = if closed then raise Closed_channel; let b = Netbuffer.create 80 in let eol_found = ref false in if bufpos = buflen then ( self # refill(); (* may raise End_of_file *) ); while not !eol_found do let best = self # find_eol() in try match best with EOL_not_found -> Netbuffer.add_subbytes b buf bufpos (buflen-bufpos); bufpos <- buflen; self # refill(); (* may raise End_of_file *) | EOL_partially_found pos -> Netbuffer.add_subbytes b buf bufpos (pos-bufpos); bufpos <- pos; self # refill(); (* may raise End_of_file *) | EOL_found(pos,len) -> Netbuffer.add_subbytes b buf bufpos (pos-bufpos); bufpos <- pos+len; eol_found := true with End_of_file -> bufpos <- 0; buflen <- 0; eof <- true; eol_found := true done; Netbuffer.contents b end ;; class lift_raw_in_channel_buf ?eol ?buffer_size ?pass_through r = object(self) inherit buffered_raw_in_channel ?eol ?buffer_size ?pass_through r inherit augment_raw_in_channel method input_line () = self # enhanced_input_line() end;; type lift_in_arg = [ `Rec of rec_in_channel | `Raw of raw_in_channel ] let lift_in ?(eol = ["\n"]) ?(buffered=true) ?buffer_size ?pass_through (x : lift_in_arg) = match x with `Rec r when not buffered -> if eol <> ["\n"] then invalid_arg "Netchannels.lift_in"; new lift_rec_in_channel r | `Rec r when buffered -> let r' = new lift_rec_in_channel r in new lift_raw_in_channel_buf ~eol ?buffer_size ?pass_through (r' :> raw_in_channel) | `Raw r when not buffered -> if eol <> ["\n"] then invalid_arg "Netchannels.lift_in"; new lift_raw_in_channel r | `Raw r when buffered -> new lift_raw_in_channel_buf ~eol ?buffer_size ?pass_through r ;; (****************************** output ******************************) exception No_end_of_file let copy_channel ?(buf = Bytes.create 1024) ?len (src_ch : in_obj_channel) (dest_ch : out_obj_channel) = (* Copies contents from src_ch to dest_ch. Returns [true] if at EOF. *) let slen = Bytes.length buf in let k = ref 0 in try while true do let m = min slen (match len with Some x -> x - !k | None -> max_int) in if m <= 0 then raise No_end_of_file; let n = src_ch # input buf 0 m in if n = 0 then raise Sys_blocked_io; dest_ch # really_output buf 0 n; k := !k + n done; assert false with End_of_file -> true | No_end_of_file -> false ;; class output_channel ?(onclose = fun () -> ()) ch (* : out_obj_channel *) = let errflag = ref false in let monitored f arg = try let r = f arg in errflag := false; r with | error -> errflag := true; raise error in object (self) val ch = ch val onclose = onclose val mutable closed = false method private complain_closed() = raise Closed_channel method output buf pos len = if closed then self # complain_closed(); (* Pervasives.output does not support non-blocking I/O directly. * Work around it: *) let p0 = Pervasives.pos_out ch in try Pervasives.output ch buf pos len; errflag := false; len with | Sys_blocked_io -> let p1 = Pervasives.pos_out ch in errflag := false; p1 - p0 | error -> errflag := true; raise error method really_output buf pos len = if closed then self # complain_closed(); monitored (Pervasives.output ch buf pos) len method really_output_string buf pos len = if closed then self # complain_closed(); #ifdef HAVE_BYTES monitored (Pervasives.output_substring ch buf pos) len #else monitored (Pervasives.output ch buf pos) len #endif method output_char c = if closed then self # complain_closed(); monitored (Pervasives.output_char ch) c method output_string s = if closed then self # complain_closed(); monitored (Pervasives.output_string ch) s method output_bytes s = if closed then self # complain_closed(); #ifdef HAVE_BYTES monitored (Pervasives.output_bytes ch) s #else monitored (Pervasives.output_string ch) s #endif method output_byte b = if closed then self # complain_closed(); monitored (Pervasives.output_byte ch) b method output_buffer b = if closed then self # complain_closed(); monitored(Buffer.output_buffer ch) b method output_channel ?len ch = if closed then self # complain_closed(); ignore (monitored (copy_channel ?len ch) (self : #out_obj_channel :> out_obj_channel)) method flush() = if closed then self # complain_closed(); monitored Pervasives.flush ch method close_out() = if not closed then ( ( try (* if !errflag is set, we know that the immediately preceding operation raised an exception, and we are now likely in the exception handler *) if !errflag then Pervasives.close_out_noerr ch else Pervasives.close_out ch; closed <- true; with | error -> let bt = Printexc.get_backtrace() in Netlog.logf `Err "Netchannels.output_channel: \ Suppressed error in close_out: %s - backtrace: %s" (Netexn.to_string error) bt; Pervasives.close_out_noerr ch; closed <- true; ); onclose() ) method pos_out = if closed then self # complain_closed(); Pervasives.pos_out ch end ;; class output_command ?onclose cmd = let ch = Unix.open_process_out cmd in object (self) inherit output_channel ?onclose ch as super method close_out() = if not closed then ( let p = Unix.close_process_out ch in closed <- true; onclose(); if p <> Unix.WEXITED 0 then raise (Command_failure p); (* Keep this *) ) end ;; class output_buffer ?(onclose = fun () -> ()) buffer : out_obj_channel = object(self) val buffer = buffer val onclose = onclose val mutable closed = false method private complain_closed() = raise Closed_channel method output buf pos len = if closed then self # complain_closed(); #ifdef HAVE_BYTES Buffer.add_subbytes buffer buf pos len; #else Buffer.add_substring buffer buf pos len; #endif len method really_output buf pos len = if closed then self # complain_closed(); #ifdef HAVE_BYTES Buffer.add_subbytes buffer buf pos len; #else Buffer.add_substring buffer buf pos len; #endif method really_output_string buf pos len = if closed then self # complain_closed(); Buffer.add_substring buffer buf pos len; method output_char c = if closed then self # complain_closed(); Buffer.add_char buffer c method output_string s = if closed then self # complain_closed(); Buffer.add_string buffer s method output_bytes s = if closed then self # complain_closed(); #ifdef HAVE_BYTES Buffer.add_bytes buffer s #else Buffer.add_string buffer s #endif method output_byte b = if closed then self # complain_closed(); Buffer.add_char buffer (Char.chr b) method output_buffer b = if closed then self # complain_closed(); Buffer.add_buffer buffer b method output_channel ?len ch = if closed then self # complain_closed(); ignore(copy_channel ?len ch (self : #out_obj_channel :> out_obj_channel)) method flush() = if closed then self # complain_closed(); () method close_out() = if not closed then ( closed <- true; onclose() ) method pos_out = if closed then self # complain_closed(); Buffer.length buffer end ;; class output_netbuffer ?(onclose = fun () -> ()) buffer : out_obj_channel = object(self) val buffer = buffer val onclose = onclose val mutable closed = false val mutable ch_pos = 0 method private complain_closed() = raise Closed_channel method output buf pos len = if closed then self # complain_closed(); Netbuffer.add_subbytes buffer buf pos len; ch_pos <- ch_pos + len; len method really_output buf pos len = if closed then self # complain_closed(); Netbuffer.add_subbytes buffer buf pos len; ch_pos <- ch_pos + len; method really_output_string buf pos len = if closed then self # complain_closed(); Netbuffer.add_substring buffer buf pos len; ch_pos <- ch_pos + len; method output_char c = if closed then self # complain_closed(); Netbuffer.add_string buffer (String.make 1 c); ch_pos <- ch_pos + 1; method output_string s = if closed then self # complain_closed(); Netbuffer.add_string buffer s; ch_pos <- ch_pos + String.length s method output_bytes s = if closed then self # complain_closed(); Netbuffer.add_bytes buffer s; ch_pos <- ch_pos + Bytes.length s method output_byte b = if closed then self # complain_closed(); Netbuffer.add_string buffer (String.make 1 (Char.chr b)); ch_pos <- ch_pos + 1; method output_buffer b = if closed then self # complain_closed(); Netbuffer.add_string buffer (Buffer.contents b); ch_pos <- ch_pos + Buffer.length b; method output_channel ?len ch = if closed then self # complain_closed(); ignore(copy_channel ?len ch (self : #out_obj_channel :> out_obj_channel)) method flush() = if closed then self # complain_closed(); () method close_out() = if not closed then ( closed <- true; onclose() ) method pos_out = if closed then self # complain_closed(); ch_pos (* We cannot return Netbuffer.length b as [pos_out] (like in the class * [output_buffer]) because the user of this class is allowed to delete * data from the netbuffer. So we manually count how many bytes are * ever appended to the netbuffer. * This behavior is especially needed by [pipe_channel] below. *) end ;; class output_null ?(onclose = fun () -> ()) () : out_obj_channel = object(self) val mutable closed = false val mutable pos = 0 method private complain_closed() = raise Closed_channel method output s start len = if closed then self # complain_closed(); pos <- pos + len; len method really_output s start len = if closed then self # complain_closed(); pos <- pos + len method really_output_string s start len = if closed then self # complain_closed(); pos <- pos + len method output_char _ = if closed then self # complain_closed(); pos <- pos + 1 method output_string s = if closed then self # complain_closed(); pos <- pos + String.length s method output_bytes s = if closed then self # complain_closed(); pos <- pos + Bytes.length s method output_byte _ = if closed then self # complain_closed(); pos <- pos + 1 method output_buffer b = if closed then self # complain_closed(); pos <- pos + Buffer.length b method output_channel ?len ch = if closed then self # complain_closed(); ignore(copy_channel ?len ch (self : #out_obj_channel :> out_obj_channel)) method flush() = if closed then self # complain_closed(); method close_out() = closed <- true method pos_out = if closed then self # complain_closed(); pos end ;; let with_out_obj_channel ch f = try let result = f ch in (* we _have_ to flush here because close_out often does no longer report exceptions *) ( try ch # flush() with Closed_channel -> ()); ( try ch # close_out() with Closed_channel -> ()); result with e -> ( try ch # close_out() with Closed_channel -> ()); raise e ;; class virtual augment_raw_out_channel = object (self) method virtual output : Bytes.t -> int -> int -> int method virtual close_out : unit -> unit method virtual flush : unit -> unit method virtual pos_out : int method really_output s pos len = let rec print_rest n = if n < len then let m = self # output s (pos+n) (len-n) in if m=0 then raise Sys_blocked_io; print_rest (n+m) else () in print_rest 0 method really_output_string s pos len = self # really_output (Bytes.unsafe_of_string s) pos len method output_char c = ignore(self # output (Bytes.make 1 c) 0 1) method output_byte n = ignore(self # output (Bytes.make 1 (Char.chr n)) 0 1) method output_string s = self # really_output_string s 0 (String.length s) method output_bytes s = self # really_output s 0 (Bytes.length s) method output_buffer b = self # output_string (Buffer.contents b) method output_channel ?len ch = ignore(copy_channel ?len ch (self : #out_obj_channel :> out_obj_channel)) end ;; class lift_raw_out_channel (r : raw_out_channel) = object(self) inherit augment_raw_out_channel method output s p l = r # output s p l method flush () = r # flush() method close_out () = r # close_out() method pos_out = r # pos_out end;; class lift_rec_out_channel ?(start_pos_out = 0) (r : rec_out_channel) = object(self) inherit augment_raw_out_channel val mutable closed = false val mutable pos_out = start_pos_out method output s p l = if closed then raise Closed_channel; let n = r # output s p l in pos_out <- pos_out + n; n method flush() = if closed then raise Closed_channel; r # flush(); method close_out () = if not closed then ( closed <- true; r # close_out() ) method pos_out = if closed then raise Closed_channel; pos_out end;; class buffered_raw_out_channel ?(buffer_size = 4096) ?(pass_through = max_int) (ch : raw_out_channel) : raw_out_channel = object (self) val out = ch val bufsize = buffer_size val buf = Bytes.create buffer_size val mutable bufpos = 0 val mutable closed = false method output s pos len = if closed then raise Closed_channel; if bufpos=0 && len >= pass_through then ch # output s pos len else let n = min len (bufsize - bufpos) in Bytes.blit s pos buf bufpos n; bufpos <- bufpos + n; if bufpos = bufsize then self # flush(); n method flush() = let k = ref 0 in while !k < bufpos do k := !k + (ch # output buf !k (bufpos - !k)) done; bufpos <- 0; ch # flush() method close_out() = if not closed then ( ( try self # flush() with | error -> let bt = Printexc.get_backtrace() in Netlog.logf `Err "Netchannels.buffered_raw_out_channel: \ Suppressed error in close_out: %s - backtrace: %s" (Netexn.to_string error) bt; ); ch # close_out(); closed <- true ) method pos_out = (ch # pos_out) + bufpos end ;; type lift_out_arg = [ `Rec of rec_out_channel | `Raw of raw_out_channel ] let lift_out ?(buffered=true) ?buffer_size ?pass_through (x : lift_out_arg) = match x with `Rec r when not buffered -> new lift_rec_out_channel r | `Rec r when buffered -> let r' = new lift_rec_out_channel r in let r'' = new buffered_raw_out_channel ?buffer_size ?pass_through (r' :> raw_out_channel) in new lift_raw_out_channel r'' | `Raw r when not buffered -> new lift_raw_out_channel r | `Raw r when buffered -> let r' = new buffered_raw_out_channel ?buffer_size ?pass_through r in new lift_raw_out_channel r' ;; (************************* raw channels *******************************) let norestart _ _ _ f arg = try f arg with | Unix.Unix_error(Unix.EAGAIN,_,_) | Unix.Unix_error(Unix.EWOULDBLOCK,_,_) | Netsys_types.EAGAIN_RD | Netsys_types.EAGAIN_WR -> 0 let shutdown_fd mode fd_style fd = try ignore (Netsys.restart_wait mode fd_style fd (fun () -> Netsys.gshutdown fd_style fd Unix.SHUTDOWN_ALL; 0 ) () ) with | Netsys.Shutdown_not_supported -> () | Unix.Unix_error(Unix.EPERM, _, _) -> () class input_descr_prelim ?(blocking=true) ?(start_pos_in = 0) ?fd_style fd = let fd_style = match fd_style with | None -> Netsys.get_fd_style fd | Some st -> st in let wrapper = if blocking then Netsys.restart_wait else norestart in object (self) val fd_in = fd val mutable pos_in = start_pos_in val mutable closed_in = false method private complain_closed() = raise Closed_channel method input buf pos len = if closed_in then self # complain_closed(); wrapper `R fd_style fd (fun () -> let n = Netsys.gread fd_style fd_in buf pos len in pos_in <- pos_in + n; if n=0 && len>0 then raise End_of_file; n ) () method close_in () = if not closed_in then ( (* The gshutdown call only exists because of TLS: *) shutdown_fd `R fd_style fd; Netsys.gclose fd_style fd_in; closed_in <- true ) method pos_in = if closed_in then self # complain_closed(); pos_in end ;; class input_descr ?blocking ?start_pos_in ?fd_style fd : raw_in_channel = input_descr_prelim ?blocking ?start_pos_in ?fd_style fd ;; class output_descr_prelim ?(blocking=true) ?(start_pos_out = 0) ?fd_style fd = let fd_style = match fd_style with | None -> Netsys.get_fd_style fd | Some st -> st in let wrapper = if blocking then Netsys.restart_wait else norestart in object (self) val fd_out = fd val mutable pos_out = start_pos_out val mutable closed_out = false method private complain_closed() = raise Closed_channel method output buf pos len = if closed_out then self # complain_closed(); wrapper `W fd_style fd (fun () -> let n = Netsys.gwrite fd_style fd_out buf pos len in pos_out <- pos_out + n; n ) () method close_out () = if not closed_out then ( (* FIXME. We block here even when non-blocking semantics is requested. We do this because most programmers would be surprised to get EAGAIN when closing a channel. Actually, this only affects Win32 output threads and TLS. *) shutdown_fd `W fd_style fd; Netsys.gclose fd_style fd_out; closed_out <- true ) method pos_out = if closed_out then self # complain_closed(); pos_out method flush () = if closed_out then self # complain_closed() end ;; class output_descr ?blocking ?start_pos_out ?fd_style fd : raw_out_channel = output_descr_prelim ?blocking ?start_pos_out ?fd_style fd ;; class socket_descr ?blocking ?(start_pos_in = 0) ?(start_pos_out = 0) ?fd_style fd : raw_io_channel = let fd_style = match fd_style with | None -> Netsys.get_fd_style fd | Some st -> st in let () = match fd_style with | `Recv_send _ | `Recv_send_implied | `W32_pipe | `TLS _ -> () | _ -> failwith "Netchannels.socket_descr: This type of descriptor is \ unsupported" in object (self) inherit input_descr_prelim ?blocking ~start_pos_in ~fd_style fd inherit output_descr_prelim ?blocking ~start_pos_out ~fd_style fd method private gen_close cmd = shutdown_fd `W fd_style fd; if cmd = Unix.SHUTDOWN_ALL then Netsys.gclose fd_style fd method close_in () = if not closed_in then ( closed_in <- true; if closed_out then self # gen_close Unix.SHUTDOWN_ALL else self # gen_close Unix.SHUTDOWN_RECEIVE ) method close_out () = if not closed_out then ( closed_out <- true; if closed_in then self # gen_close Unix.SHUTDOWN_ALL else self # gen_close Unix.SHUTDOWN_SEND ) end ;; (************************** transactional *****************************) class buffered_trans_channel ?(close_mode = (`Commit : close_mode)) (ch : out_obj_channel) : trans_out_obj_channel = let closed = ref false in let transbuf = ref(Buffer.create 50) in let trans = ref(new output_buffer !transbuf) in let reset() = transbuf := Buffer.create 50; trans := new output_buffer !transbuf in object (self) val out = ch val close_mode = close_mode method output = !trans # output method really_output = !trans # really_output method really_output_string = !trans # really_output_string method output_char = !trans # output_char method output_string = !trans # output_string method output_bytes = !trans # output_bytes method output_byte = !trans # output_byte method output_buffer = !trans # output_buffer method output_channel = !trans # output_channel method flush = !trans # flush method close_out() = if not !closed then ( ( try ( match close_mode with `Commit -> self # commit_work() | `Rollback -> self # rollback_work() ) with | error -> let bt = Printexc.get_backtrace() in Netlog.logf `Err "Netchannels.buffered_trans_channel: \ Suppressed error in close_out: %s - backtrace: %s" (Netexn.to_string error) bt; ); !trans # close_out(); out # close_out(); closed := true ) method pos_out = out # pos_out + !trans # pos_out method commit_work() = try (* in any way avoid that the contents of transbuf are printed twice *) let b = !transbuf in reset(); out # output_buffer b; out # flush(); with err -> self # rollback_work(); (* reset anyway *) raise err method rollback_work() = reset() end ;; let make_temporary_file ?(mode = 0o600) ?(limit = 1000) ?(tmp_directory = Netsys_tmp.tmp_directory() ) ?(tmp_prefix = "netstring") () = (* Returns (filename, in_channel, out_channel). *) let rec try_creation n = try let fn = Filename.concat tmp_directory (Netsys_tmp.tmp_prefix tmp_prefix ^ "-" ^ (string_of_int n)) in let fd_in = Unix.openfile fn [ Unix.O_RDWR; Unix.O_CREAT; Unix.O_EXCL ] mode in let fd_out = Unix.openfile fn [ Unix.O_RDWR ] mode in (* For security reasons check that fd_in and fd_out are the same file: *) let stat_in = Unix.fstat fd_in in let stat_out = Unix.fstat fd_out in if stat_in.Unix.st_dev <> stat_out.Unix.st_dev || stat_in.Unix.st_rdev <> stat_out.Unix.st_rdev || stat_in.Unix.st_ino <> stat_out.Unix.st_ino then raise(Sys_error("File has been replaced (security alert)")); let ch_in = Unix.in_channel_of_descr fd_in in let ch_out = Unix.out_channel_of_descr fd_out in fn, ch_in, ch_out with Unix.Unix_error(Unix.EEXIST,_,_) -> (* This does not look very intelligent, but it is the only chance * to limit the number of trials. * Note that we get EACCES if the directory is not writeable. *) if n > limit then failwith ("Netchannels: Cannot create temporary file - too many files in this temp directory: " ^ tmp_directory); try_creation (n+1) | Unix.Unix_error(e,_,_) -> raise (Sys_error("Cannot create a temporary file in the directory " ^ tmp_directory ^ ": " ^ Unix.error_message e)) in try_creation 0 ;; class tempfile_trans_channel ?(close_mode = (`Commit : close_mode)) ?tmp_directory ?tmp_prefix (ch : out_obj_channel) : trans_out_obj_channel = let _transname, _transch_in, _transch_out = make_temporary_file ?tmp_directory ?tmp_prefix () in let closed = ref false in object (self) val transch_out = _transch_out val mutable transch_in = _transch_in val trans = new output_channel _transch_out val mutable out = ch val close_mode = close_mode val mutable need_clear = false initializer try Sys.remove _transname; (* Remove the file immediately. This requires "Unix semantics" of the * underlying file system, because we don't remove the file but only * the entry in the directory. So we can read and write the file and * allocate disk space, but the file is private from now on. (It's * not fully private, because another process can obtain a descriptor * between creation of the file and removal of the entry. We should * keep that in mind if privacy really matters.) * The disk space will be freed when the descriptor is closed. *) with err -> close_in _transch_in; close_out _transch_out; raise err method output = if need_clear then self#clear(); trans # output method really_output = if need_clear then self#clear(); trans # really_output method really_output_string = if need_clear then self#clear(); trans # really_output_string method output_char = if need_clear then self#clear(); trans # output_char method output_string = if need_clear then self#clear(); trans # output_string method output_bytes = if need_clear then self#clear(); trans # output_bytes method output_byte = if need_clear then self#clear(); trans # output_byte method output_buffer = if need_clear then self#clear(); trans # output_buffer method output_channel = if need_clear then self#clear(); trans #output_channel method flush = if need_clear then self#clear(); trans # flush method close_out() = if not !closed then ( if need_clear then self#clear(); ( try ( match close_mode with `Commit -> self # commit_work() | `Rollback -> self # rollback_work() ) with | error -> let bt = Printexc.get_backtrace() in Netlog.logf `Err "Netchannels.tempfile_trans_channel: \ Suppressed error in close_out: %s - backtrace: %s" (Netexn.to_string error) bt; ); Pervasives.close_in transch_in; trans # close_out(); (* closes transch_out *) out # close_out(); closed := true ) method pos_out = if need_clear then self#clear(); out # pos_out + trans # pos_out method commit_work() = need_clear <- true; let len = trans # pos_out in trans # flush(); Pervasives.seek_in transch_in 0; let trans' = new input_channel transch_in in ( try out # output_channel ~len trans'; out # flush(); with err -> self # rollback_work(); raise err ); self # clear() method rollback_work() = self # clear() method private clear() = (* delete the contents of the file *) (* First empty the file and reset the output channel: *) Pervasives.seek_out transch_out 0; Unix.ftruncate (Unix.descr_of_out_channel transch_out) 0; (* Renew the input channel. We create a new channel to avoid problems * with the internal buffer of the channel. * (Problem: transch_in has an internal buffer, and the buffer contains * old data now. So we drop the channel and create a new channel for the * same file descriptor. Note that we cannot set the file offset with * seek_in because neither the old nor the new channel is properly * synchronized with the file. So we fall back to lseek.) *) let fd = Unix.descr_of_in_channel transch_in in ignore(Unix.lseek fd 0 Unix.SEEK_END); (* set the offset *) transch_in <- Unix.in_channel_of_descr fd; (* renew channel *) (* Now check that everything worked: *) assert(pos_in transch_in = 0); assert(in_channel_length transch_in = 0); (* Note: the old transch_in will be automatically finalized, but the * underlying file descriptor will not be closed in this case *) need_clear <- false end ;; let id_conv incoming incoming_eof outgoing = (* Copies everything from [incoming] to [outgoing] *) let len = Netbuffer.length incoming in ignore (Netbuffer.add_inplace ~len outgoing (fun s_outgoing pos len' -> assert (len = len'); Netbuffer.blit incoming 0 s_outgoing pos len'; Netbuffer.clear incoming; len' )) ;; let call_input refill f arg = (* Try to satisfy the request: *) try f arg with Buffer_underrun -> (* Not enough data in the outgoing buffer. *) refill(); f arg ;; class pipe ?(conv = id_conv) ?(buffer_size = 1024) () : io_obj_channel = let _incoming = Netbuffer.create buffer_size in let _outgoing = Netbuffer.create buffer_size in object(self) (* The properties as "incoming buffer" [output_super] are simply inherited * from [output_netbuffer]. The "outgoing buffer" [input_super] invocations * are delegated to [input_netbuffer]. Inheritance does not work because * there is no way to make the public method [shutdown] private again. *) inherit output_netbuffer _incoming as output_super val conv = conv val incoming = _incoming val outgoing = _outgoing val input_super = new input_netbuffer _outgoing val mutable incoming_eof = false val mutable pos_in = 0 (* We must count positions ourselves. Can't use input_super#pos_in * because conv may manipulate the buffer. *) val mutable output_closed = false (* Input methods: *) method private refill() = conv incoming incoming_eof outgoing; if incoming_eof then input_super # shutdown() method input str pos len = let n = call_input self#refill (input_super#input str pos) len in pos_in <- pos_in + n; n method input_line() = let p = input_super # pos_in in let line = call_input self#refill (input_super#input_line) () in let p' = input_super # pos_in in pos_in <- pos_in + (p' - p); line method really_input str pos len = call_input self#refill (input_super#really_input str pos) len; pos_in <- pos_in + len method really_input_string len = let buf = Bytes.create len in call_input self#refill (input_super#really_input buf 0) len; pos_in <- pos_in + len; Bytes.unsafe_to_string buf method input_char() = let c = call_input self#refill (input_super#input_char) () in pos_in <- pos_in + 1; c method input_byte() = let b = call_input self#refill (input_super#input_byte) () in pos_in <- pos_in + 1; b method close_in() = (* [close_in] implies [close_out]: *) if not output_closed then ( output_super # close_out(); output_closed <- true; ); input_super # close_in() method pos_in = pos_in (* [close_out] also shuts down the input side of the pipe. *) method close_out () = if not output_closed then ( output_super # close_out(); output_closed <- true; ); incoming_eof <- true end class output_filter (p : io_obj_channel) (out : out_obj_channel) : out_obj_channel = object(self) val p = p val mutable p_closed = false (* output side of p is closed *) val out = out val buf = Bytes.create 1024 (* for copy_channel *) method output s pos len = if p_closed then raise Closed_channel; let n = p # output s pos len in self # transfer(); n method really_output s pos len = if p_closed then raise Closed_channel; p # really_output s pos len; self # transfer(); method really_output_string s pos len = if p_closed then raise Closed_channel; p # really_output_string s pos len; self # transfer(); method output_char c = if p_closed then raise Closed_channel; p # output_char c; self # transfer(); method output_string s = if p_closed then raise Closed_channel; p # output_string s; self # transfer(); method output_bytes s = if p_closed then raise Closed_channel; p # output_bytes s; self # transfer(); method output_byte b = if p_closed then raise Closed_channel; p # output_byte b; self # transfer(); method output_buffer b = if p_closed then raise Closed_channel; p # output_buffer b; self # transfer(); method output_channel ?len ch = (* To avoid large intermediate buffers, the channel is copied * chunk by chunk *) if p_closed then raise Closed_channel; let len_to_do = ref (match len with None -> -1 | Some l -> max 0 l) in let buf = buf in while !len_to_do <> 0 do let n = if !len_to_do < 0 then 1024 else min !len_to_do 1024 in if copy_channel ~buf ~len:n ch (p :> out_obj_channel) then (* EOF *) len_to_do := 0 else if !len_to_do >= 0 then (len_to_do := !len_to_do - n; assert(!len_to_do >= 0)); self # transfer(); done method flush() = p # flush(); self # transfer(); out # flush() method close_out() = if not p_closed then ( p # close_out(); p_closed <- true; ( try self # transfer() with | error -> (* We report the error. However, we prevent that another, immediately following [close_out] reports the same error again. This is done by setting p_closed. *) raise error ) ) method pos_out = p # pos_out method private transfer() = (* Copy as much as possible from [p] to [out] *) try (* Call [copy_channel] directly (and not the method [output_channel]) * because we can pass the copy buffer ~buf *) ignore(copy_channel ~buf (p :> in_obj_channel) out); out # flush(); with Buffer_underrun -> () end let rec filter_input refill f arg = (* Try to satisfy the request: *) try f arg with Buffer_underrun -> (* Not enough data in the outgoing buffer. *) refill(); filter_input refill f arg ;; class input_filter (inp : in_obj_channel) (p : io_obj_channel) : in_obj_channel = object(self) val inp = inp val p = p val buf = Bytes.create 1024 (* for copy_channel *) method private refill() = (* Copy some data from [inp] to [p] *) (* Call [copy_channel] directly (and not the method [output_channel]) * because we can pass the copy buffer ~buf *) let eof = copy_channel ~len:(Bytes.length buf) ~buf inp (p :> out_obj_channel) in if eof then p # close_out(); method input str pos = filter_input self#refill (p#input str pos) method input_line = filter_input self#refill (p#input_line) method really_input str pos = filter_input self#refill (p#really_input str pos) method really_input_string = filter_input self#refill p#really_input_string method input_char = filter_input self#refill (p#input_char) method input_byte = filter_input self#refill (p#input_byte) method close_in() = p#close_in(); method pos_in = p#pos_in end ocamlnet-4.1.6/src/netstring/netchannels.mli0000644000175000017500000011675313274252307017603 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) (** Object-oriented I/O: Basic types and classes * * {b Contents} * * - {!Netchannels.types} * - {!Netchannels.input} * - {!Netchannels.output} * - {!Netchannels.delegation} * - {!Netchannels.lifting} * - {!Netchannels.descriptors} * - {!Netchannels.transactional} * - {!Netchannels.filters} * {ul {- {!Netchannels.filters_notes}}} * * The tutorial has been moved to {!Netchannels_tut}. *) open Netsys_types (** {1:types Types} *) (* ***************************** Types ******************************** *) (** There are three levels of class types for channels: * - [rec_in_channel] and [rec_out_channel]: Primitive, but standardized level * - [raw_in_channel] and [raw_out_channel]: Unix level * - [in_obj_channel] and [out_obj_channel]: Application level * * The "rec" level has been recently introduced to improve interoperability * with other libraries (e.g. camomile). The idea is to standardize the * real core methods of I/O, so they have the same meaning in all libraries. * Read * "{{:http://www.ocaml-programming.de/rec/IO-Classes.html}Basic I/O class types}" * for more. * * The "raw" level represents the level of Unix file descriptors. * * The application level is what should be used in programs. In addition * to the "raw" level one can find a number of convenience methods, * e.g. [input_line] to read a line from the channel. The downside is that * these methods usually work only for blocking I/O. * * One can lower the level by coercion, e.g. to turn an [in_obj_channel] * into a [rec_in_channel], apply the function * * [(fun ch -> (ch : in_obj_channel :> rec_in_channel))] * * To higher the level, apply [lift_in] or [lift_out], defined below. *) (** {b Interface changes:} Since ocamlnet-0.98, the semantics of * the methods [input] and [output] has slightly changed. When the end * of the channel is reached, [input] raises now [End_of_file]. In previous * releases of ocamlnet, the value 0 was returned. When the channel cannot * process data, but is in non-blocking mode, both methods now return the * value 0. In previous releases of ocamlnet, the behaviour was not * defined. * * {b Ocamlnet-3.0} changed the behavior of [close_out]. Errors are no longer * reported - instead, the exception is logged to {!Netlog}. For a stricter * error handling, it is suggested to call [flush] first. Also, [close_in] * and [close_out] no longer raise [Closed_channel] when the channel is * already closed. Read more about this in the section * {!Netchannels.rec_out_channel.close_error}. *) exception Closed_channel (** Raised when channel operations are called when the channel is closed *) exception Buffer_underrun (** Raised by input methods if the internal buffer of the channel is too * empty to read even one byte of data. * This exception is only used by certain implementations of channel * classes. *) exception Command_failure of Unix.process_status (** Raised by [close_in] or [close_out] if the channel is connected with * another process, and the execution of that process fails. *) (** Recommended input class type for library interoperability. *) class type rec_in_channel = object (** Description * * This class type is defined in * "{{:http://www.ocaml-programming.de/rec/IO-Classes.html}Basic I/O class types}" * as collaborative effort of several library creators. *) method input : Bytes.t -> int -> int -> int (** Reads octets from the channel and puts them into the string. The * first [int] argument is the position of the substring, and the second * [int] argument is the length of the substring where the data are * stored. The method returns the number of octets actually read and * stored. * * When the end of the channel is reached and there is no further octet * to read, the exception [End_of_file] will be raised. {b This has * been changed in ocamlnet-0.97! In previous releases the number 0 * was returned at the end of the channel.} * * When the channel is non-blocking, and there are currently no bytes * to read, the number 0 will be returned. {b This has * been changed in ocamlnet-0.97! In previous releases this behaviour * was undefined.} * * When the channel is closed, the exception [Closed_channel] will be * raised if an ocamlnet implementation is used. For implementations * of other libraries there is no standard for this case. *) method close_in : unit -> unit (** Closes the channel for input. * * When the channel is already closed, this is a no-op. * * Error policy: Exceptions are only raised in cases of serious * corruption, e.g. if the underlying descriptor is invalid. *) end (** Basic Unix-level class type for input channels as used by ocamlnet. In addition * to the recommended standard, ocamlnet always support a position counter *) class type raw_in_channel = object inherit rec_in_channel method pos_in : int (** Returns the current channel position. This position can be expected * to be consistent with the returned number of bytes of [input], i.e. * when [input] returns [n], the position is advanced by [n]. * * As seek operations are outside the scope of [Netchannels], * implementations may or may not take seek operations into account. *) end (** Recommended output class type for library interoperability. *) class type rec_out_channel = object (** Description * * This class type is defined in * "{{:http://www.ocaml-programming.de/rec/IO-Classes.html}Basic I/O class types}" * as collaborative effort of several library creators. *) method output : Bytes.t -> int -> int -> int (** Takes octets from the string and writes them into the channel. The * first [int] argument is the position of the substring, and the second * [int] argument is the length of the substring where the data can * be found. The method returns the number of octets actually written. * * The implementation may choose to collect written octets in a buffer * before they actually delivered to the underlying resource. * * When the channel is non-blocking, and there are currently no bytes * to write, the number 0 will be returned. {b This has * been changed in ocamlnet-0.97! In previous releases this behaviour * was undefined.} * * When the channel is closed, the exception [Closed_channel] will be * raised if an ocamlnet implementation is used. For implementations * of other libraries there is no standard for this case. *) method flush : unit -> unit (** If there is a write buffer, it will be flushed. Otherwise, nothing * happens. *) method close_out : unit -> unit (** Flushes the buffer, if any, and closes the channel for output. * * When the channel is already closed, this is a no-op. *) (** {2:close_error How to close channels in case of errors} The [close_out] method has actually two tasks: First, it writes out all remaining data (like [flush]), and second, it releases OS resources (e.g. closes file descriptors). There is the question what has to happen when the write part fails - is the resource released anyway or not? We choose here a pragmatic approach under the assumption that an OS error at close time is usually unrecoverable, and it is more important to release the OS resource. Also, we assume that the user is wise enough to call [flush] first if it is essential to know write errors at close time. Under these assumptions: - The [flush] method fully reports any errors when writing out the remaining data. - When [flush] raises an error exception, it should discard any data in the buffer. This is not obligatory, however, but considered good practice, and is subject to discussion. - The [close_out] method usually does not report errors by raising exceptions, but only by logging them via {!Netlog}. The OS resource is released in any case. As before, this behavior is not obligatory, but considered as good practice, and subject to discussion. This ensures that the following code snippet reports all errors, but also releases OS resources: {[ try ch # flush(); ch # close_out(); with error -> ch # close_out(); raise error ]} There are some cases where data can be first written when it is known that the channel is closed. These data would not be written by a preceding [flush]. In such cases: - The best way to deal with it is to define another method, e.g. called [write_eof], that marks the data as logically being complete, so a following [flush] can do the complete shutdown cycle of the channel. - At least, however, one should allow then that a double [close_out] releases the descriptor: the first [close_out] will report the error condition as exception, but discard all data in the channel. The second [close_out] finally releases the OS resource. In any way, hard errors indicating bugs of the program logic (like invalid file descriptors) should always be immediately reported. *) end (** Basic Unix-level class type for output channels as used by ocamlnet. In addition * to the recommended standard, ocamlnet always support a position counter *) class type raw_out_channel = object inherit rec_out_channel method pos_out : int (** Returns the current channel position. This position can be expected * to be consistent with the returned number of bytes of [output], i.e. * when [output] returns [n], the position is advanced by [n]. * * As seek operations are outside the scope of [Netchannels], * implementations may or may not take seek operations into account. *) end (** A channel supporting both input and output. The input and output * aspects are strictly separated *) class type raw_io_channel = object inherit raw_in_channel inherit raw_out_channel end (** Further methods usually supported by ocamlnet channel implementations. * These methods are only reasonable when the channel is of blocking type, * i.e. waits for input when not enough data are available to perform an * operation. Implementations may choose to fail when they detect the * channel is non-blocking. *) class type compl_in_channel = object method really_input : Bytes.t -> int -> int -> unit (** Reads exactly as many octets from the channel as the second [int] * argument specifies. The octets are placed at the position denoted * by the first [int] argument into the string. * * When the end of the channel is reached before the passed number of * octets are read, the exception [End_of_file] is raised. *) method really_input_string : int -> string (** [really_input_string ic len] reads [len] characters from channel [ic] and returns them in a new string. Raise [End_of_file] if the end of file is reached before [len] characters have been read. *) method input_char : unit -> char (** Reads exactly one character from the channel, or raises [End_of_file] *) method input_line : unit -> string (** Reads the next line from the channel. When the channel is already * at the end before [input_line] is called, the exception [End_of_file] * is raised. *) method input_byte : unit -> int (** Reads exactly one octet from the channel and returns its code, * or raises [End_of_file] *) end (** The application-level input channel supports raw and complemented methods *) class type in_obj_channel = object inherit raw_in_channel inherit compl_in_channel end (** Further methods usually supported by ocamlnet channel implementations. * These methods are only reasonable when the channel is of blocking type, * i.e. waits for output readiness when the underlying resource currently * cannot process enough data. Implementations may choose to fail when they * detect the channel is non-blocking. *) class type compl_out_channel = object method really_output : Bytes.t -> int -> int -> unit (** Writes exactly as many octets to the channel as the second [int] * argument specifies. The octets are taken from the string position * denoted by the first [int] argument. *) method really_output_string : string -> int -> int -> unit (** Same for strings *) method output_char : char -> unit (** Writes exactly one character *) method output_bytes : Bytes.t -> unit (** Writes exactly the passed string *) method output_string : string -> unit (** Writes exactly the passed string *) method output_byte : int -> unit (** Writes exactly one byte passed as integer code *) method output_buffer : Buffer.t -> unit (** Writes exactly the contents of the buffer *) method output_channel : ?len:int -> in_obj_channel -> unit (** Writes the contents of an [in_obj_channel] until the end of the * input channel is reached. * * @param len If passed, at most this number of octets are read from * the input channel and written to this channel. *) end (** The application-level output channel supports raw and complemented methods *) class type out_obj_channel = object inherit raw_out_channel inherit compl_out_channel end (** A channel supporting both input and output. The input and output * aspects are strictly separated *) class type io_obj_channel = object inherit in_obj_channel inherit out_obj_channel end (** A transactional output channel has a buffer for uncommitted data. * This means that all data written to this channel is collected in the * buffer until either [commit_work] or [rollback_work] is called. * * When the channel is closed, the buffer may optionally be committed. * This is implementation-defined. * * The method [flush] does not have any effect on the transaction * buffer. *) class type trans_out_obj_channel = object inherit out_obj_channel method commit_work : unit -> unit (** Flushes the transaction buffer, and writes its contents to the * underlying resource. *) method rollback_work : unit -> unit (** Empties the transaction buffer *) end (* ***************************** Input channels *********************** *) (** {1:input Input channels} *) class input_channel : ?onclose:(unit -> unit) -> in_channel -> in_obj_channel (** Creates an input channel from an [in_channel], which must be open. * * The method [pos_in] reflects the real position in the channel as * returned by [Pervasives.pos_in]. This works for both seekable and * non-seekable channels. * * The method [close_in] also closes the underlying [in_channel]. * * The function [onclose] is called after the [in_channel] has been closed. *) val input_channel : ?onclose:(unit -> unit) -> in_channel -> in_obj_channel (** Same as function *) class input_command : string -> in_obj_channel (** Runs the command with [/bin/sh], and reads the data the command prints * to stdout. * * The method [pos_in] returns the number of read octets. * * When [close_in] is invoked, the subprocess is [wait]ed for. If the * process exits with code 0, the method returns normally. Otherwise, * the exception [Command_failure] is raised. *) val input_command : string -> in_obj_channel (** Same as function *) class input_string : ?pos:int -> ?len:int -> string -> in_obj_channel (** Creates an input channel from a (constant) string. * * The method [pos_in] reflects the real position in the string, i.e. * a character read at position [k] can be found at [s.[k]] in the string * [s]. * * @param pos The data of the channel begins at this position of the string. * Default: 0 * @param len The data of the channel consists of this number of bytes. * Default: until the end of the string *) val input_string : ?pos:int -> ?len:int -> string -> in_obj_channel (** Same as function *) class input_bytes : ?pos:int -> ?len:int -> Bytes.t -> in_obj_channel (** Same for constant bytes *) val input_bytes : ?pos:int -> ?len:int -> Bytes.t -> in_obj_channel (** Same as function *) class input_memory : ?pos:int -> ?len:int -> memory -> in_obj_channel (** Same for constant memory *) val input_memory : ?pos:int -> ?len:int -> memory -> in_obj_channel (** Same as function *) val input_tstring : ?pos:int -> ?len:int -> tstring -> in_obj_channel (** Same for tagged strings (only as function) *) val create_input_netbuffer : ?keep_data:bool -> Netbuffer.t -> in_obj_channel * (* shutdown: *) (unit -> unit) (** Creates an input channel and a shutdown function for a netbuffer. * This is a destructive * implementation: Every time data is read, the octets are taken from the * beginning of the netbuffer, and they are deleted from the netbuffer * (recall that a netbuffer works like a queue of characters). * * Conversely, the user of this class may add new data to the netbuffer * at any time. When the shutdown function is called, the EOF condition * is recorded, and no further data must be added. * * If the netbuffer becomes empty, the input methods raise [Buffer_underrun] * when the EOF condition has not yet been set, and they raise * [End_of_file] when the EOF condition has been recorded. * * [keep_data]: do not delete read data from the buffer *) val lexbuf_of_in_obj_channel : in_obj_channel -> Lexing.lexbuf (** Creates a lexical buffer from an input channel. The input channel * is not closed when the end is reached * * This function does not work for non-blocking channels. *) val string_of_in_obj_channel : in_obj_channel -> string (** Reads from the input channel until EOF and returns the characters * as string. The input channel is not closed. * * This function does not work for non-blocking channels. *) val bytes_of_in_obj_channel : in_obj_channel -> Bytes.t (** Same for bytes *) val lines_of_in_obj_channel : in_obj_channel -> string list (** Reads from the input channel until EOF and returns the lines * as string list. The input channel is not closed. * * This function does not work for non-blocking channels. *) val with_in_obj_channel : (#in_obj_channel as 'a) -> ('a -> 'b) -> 'b (** [with_in_obj_channel ch f]: * Computes [f ch] and closes [ch]. If an exception happens, the channel is * closed, too. *) (* *************************** Output channels ************************ *) (** {1:output Output channels} *) class output_channel : ?onclose:(unit -> unit) -> (* default: fun _ -> () *) out_channel -> out_obj_channel (** Creates an output channel writing into an [out_channel]. * * The method [pos_out] reflects the real position in the channel as * returned by [Pervasives.pos_out]. This works for both seekable and * non-seekable channels. * * The method [close_out] also closes the underlying [out_channel]. * There is some implicit logic to either use [close_out] or [close_out_noerr] * depending on whether the immediately preceding operation already reported * an error. * * @param onclose this function is called when the [close_out] method is * invoked, just after the underlying [out_channel] has been closed. *) class output_command : ?onclose:(unit -> unit) -> (* default: fun _ -> () *) string -> out_obj_channel (** Runs the command with [/bin/sh], and data written to the channel is * piped to stdin of the command. * * The method [pos_out] returns the number of written octets. * * When [close_out] is invoked, the subprocess is [wait]ed for. If the * process exits with code 0, the method returns normally. Otherwise, * the exception [Command_failure] is raised. (The channel is closed * even if this exception is raised.) * * @param onclose this function is called when the [close_out] method is * invoked, just after the underlying descriptor has been closed. *) class output_buffer : ?onclose:(unit -> unit) -> (* default: fun _ -> () *) Buffer.t -> out_obj_channel (** This output channel writes the data into the passed buffer. * * The method [pos_out] returns the number of written octets. * * @param onclose this function is called when the [close_out] method is * invoked, just after the underlying descriptor has been closed. *) class output_netbuffer : ?onclose:(unit -> unit) -> (* default: fun _ -> () *) Netbuffer.t -> out_obj_channel (** This output channel writes the data into the passed netbuffer. * * The method [pos_out] returns the number of written octets. * * @param onclose this function is called when the [close_out] method is * invoked, just after the underlying descriptor has been closed. *) class output_null : ?onclose:(unit -> unit) -> (* default: fun _ -> () *) unit -> out_obj_channel (** This output channel discards all written data. * * The method [pos_out] returns the number of discarded bytes. * * @param onclose this function is called when the [close_out] method is * invoked, just after the underlying descriptor has been closed. *) val with_out_obj_channel : (#out_obj_channel as 'a) -> ('a -> 'b) -> 'b (** [with_out_obj_channel ch f]: * Computes [f ch] and closes [ch]. If an exception happens, the channel is * closed, too. *) (* ********************* Delegation *********************************** *) (** {1:delegation Delegation classes} *) (** Delegation classes just forward method calls to an parameter * object, i.e. when method [m] of the delegation class is called, * the definition of [m] is just to call the method with the same * name [m] of the parameter object. This is very useful in order * to redefine methods individually. * * For example, to redefine the method [pos_in] of an [in_obj_channel], * use * {[ * class my_channel = object(self) * inherit in_obj_channel_delegation ... * method pos_in = ... * end * ]} * * As a special feature, the following delegation classes can suppress * the delegation of [close_in] or [close_out], whatever applies. * Just pass [close:false] to get this effect, e.g. * {[ * class input_channel_don't_close c = * in_obj_channel_delegation ~close:false (new input_channel c) * ]} * This class does not close [c : in_channel] when the [close_in] * method is called. *) class rec_in_channel_delegation : ?close:bool -> rec_in_channel -> rec_in_channel class raw_in_channel_delegation : ?close:bool -> raw_in_channel -> raw_in_channel class in_obj_channel_delegation : ?close:bool -> in_obj_channel -> in_obj_channel class rec_out_channel_delegation : ?close:bool -> rec_out_channel -> rec_out_channel class raw_out_channel_delegation : ?close:bool -> raw_out_channel -> raw_out_channel class out_obj_channel_delegation : ?close:bool -> out_obj_channel -> out_obj_channel (* ********************* Raw channels ********************************* *) (** {1:lifting Lifting channels} *) (** The following classes and functions add missing methods to reach * a higher level in the hierarchy of channel class types. For most * uses, the [lift_in] and [lift_out] functions work best. *) val lift_in : ?eol:string list -> ?buffered:bool -> ?buffer_size:int -> ?pass_through:int -> [ `Rec of rec_in_channel | `Raw of raw_in_channel ] -> in_obj_channel (** Turns a [rec_in_channel] or [raw_in_channel], depending on the passed * variant, into a full [in_obj_channel] object. (This is a convenience * function, you can also use the classes below directly.) If you * want to define a class for the lifted object, use * {[ * class lifted_ch ... = * in_obj_channel_delegation (lift_in ...) * ]} * * @param eol The accepted end-of-line delimiters. The method * [input_line] recognizes any of the passed strings as EOL * delimiters. When more than one delimiter matches, the longest * is taken. Defaults to [ ["\n"] ]. The default cannot be * changed when [buffered=false] (would raise [Invalid_argument]). * The delimiter strings must neither be empty, nor longer than * [buffer_size]. * @param buffered Whether a buffer is added, by default {b true} * @param buffer_size The size of the buffer, if any, by default 4096 * @param pass_through If the read request has at least this size, * and the buffer is currently empty, the buffer will be bypassed. * Defaults to [max_int], i.e. it is off. *) val lift_out : ?buffered:bool -> ?buffer_size:int -> ?pass_through:int -> [ `Rec of rec_out_channel | `Raw of raw_out_channel ] -> out_obj_channel (** Turns a [rec_out_channel] or [raw_out_channel], depending on the passed * variant, into a full [out_obj_channel] object. (This is a convenience * function, you can also use the classes below directly.) If you * want to define a class for the lifted object, use * {[ * class lifted_ch ... = * out_obj_channel_delegation (lift_out ...) * ]} * * @param buffered Whether a buffer is added, by default {b true} * @param buffer_size The size of the buffer, if any, by default 4096 * @param pass_through If the write request has at least this size, * and the buffer is currently empty, the buffer will be bypassed. * Defaults to [max_int], i.e. it is off. *) (** This class implements the methods from [compl_in_channel] by calling * the methods of [raw_in_channel]. There is no additional buffering. * The performance of the method [input_line] is very bad (consider * to override it, e.g. by [enhanced_input_line] as defined below). *) class virtual augment_raw_in_channel : object inherit compl_in_channel method virtual input : Bytes.t -> int -> int -> int (** As in [raw_in_channel] *) method virtual close_in : unit -> unit (** As in [raw_in_channel] *) method virtual pos_in : int (** As in [raw_in_channel] *) end class lift_rec_in_channel : ?start_pos_in:int -> rec_in_channel -> in_obj_channel (** This class implements [pos_in] and the methods from [compl_in_channel] * by calling the methods of [rec_in_channel]. * There is no additional buffering. * * The performance of the method [input_line] is very bad (consider * to override it, e.g. by [enhanced_input_line] as defined below). * * The method [pos_in] is implemented by counting the number of octets * read by the [input] method. * * @param start_pos_in The initial value of the counter for [pos_in]. * Defaults to 0. *) (** This class implements the methods from [compl_out_channel] by calling * the methods of [raw_out_channel]. There is no additional buffering. *) class virtual augment_raw_out_channel : object inherit compl_out_channel method virtual output : Bytes.t -> int -> int -> int (** As in [raw_out_channel] *) method virtual close_out : unit -> unit (** As in [raw_out_channel] *) method virtual flush : unit -> unit (** As in [raw_out_channel] *) method virtual pos_out : int (** As in [raw_out_channel] *) end class lift_raw_out_channel : raw_out_channel -> out_obj_channel (** This class implements the methods from [compl_out_channel] by calling * the methods of [raw_out_channel]. There is no additional buffering. *) class lift_rec_out_channel : ?start_pos_out:int -> rec_out_channel -> out_obj_channel (** This class implements [pos_out] and the methods from [compl_out_channel] * by calling the methods of [rec_out_channel]. * There is no additional buffering. * * The method [pos_out] is implemented by counting the number of octets * read by the [output] method. * * @param start_pos_out The initial value of the counter for [pos_out]. * Defaults to 0. *) type input_result = [ `Data of int | `Separator of string ] (** This type is for the method [enhanced_input] of [enhanced_raw_in_channel]. * - [`Data n] means that [n] bytes have been copied to the target string * - [`Separator s] means that no bytes have been copied, but that an * end-of-line separator [s] has been found *) (** Defines private methods reading text line by line *) class type enhanced_raw_in_channel = object inherit raw_in_channel method private enhanced_input_line : unit -> string (** An improved implementation of [input_line] that uses the buffer *) method private enhanced_input : Bytes.t -> int -> int -> input_result (** Works similar to [input], but distinguishes between normal data * and end-of-line separators. The latter are returned as * [`Separator s]. When normal data is found, it is copied to the * string, and [`Data n] is returned to indicate that [n] bytes * were copied. *) end class buffered_raw_in_channel : ?eol:string list -> ?buffer_size:int -> (* default: 4096 *) ?pass_through:int -> raw_in_channel -> enhanced_raw_in_channel (** This class adds a buffer to the underlying [raw_in_channel]. * As additional feature, the method [enhanced_input_line] is a fast * version of [input_line] that profits from the buffer. * * @param eol The accepted end-of-line delimiters. The method * [enhanced_input_line] recognizes any of the passed strings as EOL * delimiters. When more than one delimiter matches, the longest * is taken. Defaults to [ ["\n"] ]. Note that [input_line] * always only recognizes ["\n"] as EOL character, this cannot * be changed. * The delimiter strings must neither be empty, nor longer than * [buffer_size]. * @param buffer_size The size of the buffer, by default 4096. * @param pass_through If the read request has at least this size, * and the buffer is currently empty, the buffer will be bypassed. * Defaults to [max_int], i.e. it is off. *) class buffered_raw_out_channel : ?buffer_size:int -> (* default: 4096 *) ?pass_through:int -> raw_out_channel -> raw_out_channel (** This class adds a buffer to the underlying [raw_out_channel]. * * @param buffer_size The size of the buffer, by default 4096. * @param pass_through If the write request has at least this size, * and the buffer is currently empty, the buffer will be bypassed. * Defaults to [max_int], i.e. it is off. *) (* ********************** Channels over descriptors ******************* *) (** {1:descriptors Channels over descriptors} *) class input_descr : ?blocking:bool -> ?start_pos_in:int -> ?fd_style:Netsys.fd_style -> Unix.file_descr -> raw_in_channel (** Creates a [raw_in_channel] for the passed file descriptor, which must * be open for reading. * * The [pos_in] method returns logical positions, i.e. it counts the number * of read octets. It is not tried to determine the real file position. * * The method [close_in] also closes the file descriptor. * * This class also supports Win32 proxy descriptors referring to an input * channel. * * @param blocking Whether the channel waits for data if it is not * possible to read from the (non-blocking) descriptor. Defaults to [true]. * @param start_pos_in The position to which [pos_in] is initialized when * the channel is created, by default 0 * @param fd_style The descriptor style. If omitted, it is automatically * determined if possible. *) class output_descr : ?blocking:bool -> ?start_pos_out:int -> ?fd_style:Netsys.fd_style -> Unix.file_descr -> raw_out_channel (** Creates a [raw_out_channel] for the passed file descriptor, which must * be open for writing. * * The [pos_out] method returns logical positions, i.e. it counts the number * of written octets. It is not tried to determine the real file position. * * The method [close_out] also closes the file descriptor. * * This class also supports Win32 proxy descriptors referring to an output * channel. * * @param blocking Whether the channel waits until it can output if it is not * possible to write to the (non-blocking) descriptor. Defaults to [true]. * @param start_pos_out The position to which [pos_out] is initialized when * the channel is created, by default 0 * @param fd_style The descriptor style. If omitted, it is automatically * determined if possible. *) class socket_descr : ?blocking:bool -> ?start_pos_in:int -> ?start_pos_out:int -> ?fd_style:Netsys.fd_style -> Unix.file_descr -> raw_io_channel (** Creates a [raw_io_channel] for the passed socket descriptor, which must * be open for reading and writing, and not yet shut down in either * direction. The [raw_io_channel] is used to represent a bidirectional * channel: [close_out] shuts the socket down for sending, [close_in] * shuts the socket down for reading, and when both directions are down, * the descriptor is closed. * * The [pos_in] and [pos_out] methods returns logical positions. * * This class supports sockets and Win32 named pipes. Note, however, * that for Win32 named pipes it is not possible to shut down only one * direction of the bidirectional data channel. * * @param blocking See {!input_descr} and {!output_descr} * @param start_pos_in The position to which [pos_in] is initialized when * the channel is created, by default 0 * @param start_pos_out The position to which [pos_out] is initialized when * the channel is created, by default 0 * @param fd_style The descriptor style. If omitted, it is automatically * determined if possible. *) (* ********************* Transactional output channels **************** *) (** {1:transactional Transactional channels} *) type close_mode = [ `Commit | `Rollback ] (** Whether a [close_out] implies a commit or rollback operation *) class buffered_trans_channel : ?close_mode:close_mode -> out_obj_channel -> trans_out_obj_channel (** A transactional output channel with a transaction buffer implemented * in memory * * @param close_mode Specifies the semantics of [close_out], by default * [`Commit] *) val make_temporary_file : ?mode:int -> ?limit:int -> ?tmp_directory:string -> ?tmp_prefix:string -> unit -> (string * in_channel * out_channel) (** Creates a temporary file in the directory [tmp_directory] with a name * prefix [tmp_prefix] and a unique suffix. The function returns * the triple (name, inch, outch) containing the file [name], * the file opened as in_channel [inch] and as out_channel [outch]. * * @param tmp_directory Defaults to {!Netsys_tmp.tmp_directory()} * @param tmp_prefix By default ["netstring"]. This needs not to be * unique, but just descriptive. * @param mode The creation mask of the file; defaults to 0o600, i.e. the * file is private for the current user * @param limit Limits the number of trials to find the unique suffix. * Defaults to 1000. *) class tempfile_trans_channel : ?close_mode:close_mode -> ?tmp_directory:string -> ?tmp_prefix:string -> out_obj_channel -> trans_out_obj_channel (** A transactional output channel with a transaction buffer implemented * as temporary file * * @param close_mode Specifies the semantics of [close_out], by default * [`Commit] * @param tmp_directory See [make_temporary_file] * @param tmp_prefix See [make_temporary_file] *) (* ************************ Pipes and filters ************************* *) (** {1:filters Pipes and Filters} *) (** Note that this has nothing to do with "pipes" on the Unix level. * It is, however, the same idea: Connecting two I/O resources with an * intermediate buffer. *) class pipe : ?conv:(Netbuffer.t -> bool -> Netbuffer.t -> unit) -> ?buffer_size:int -> unit -> io_obj_channel (** A [pipe] has two internal buffers (realized by Netbuffer). The * output methods of the class write to the incoming buffer. When * new data are appended to the incoming buffer, the conversion function * [conv] is called; the arguments are the incoming buffer and the outgoing * buffer. The conversion function must convert the data available in the * incoming buffer and append the result to the outgoing buffer. Finally, * the input methods of the class return the data found in the outgoing * buffer. * * The conversion function is called as follows: * [conv incoming_buffer at_eof outgoing_buffer] * * The conversion function is allowed to do nothing if the incoming data * are not complete enough to be converted. It is also allowed to convert * only the beginning of the incoming buffer. * * If the outgoing buffer is empty, the input methods will raise * [Buffer_underrun]. * * If [close_out] is invoked, the end of the data stream will be recorded. * In this case, the conversion function is called with [at_eof = true], * and it is expected that this function converts the whole data found * in the incoming buffer. * * [close_in] implies [close_out]. * * The conversion function may raise exceptions. The exceptions will * fall through to the caller of the input methods. (The output methods * and [close_in], [close_out] never fail because of such exceptions.) * * The default conversion function copies everything from the incoming * buffer to the outgoing buffer without modification. *) class output_filter : io_obj_channel -> out_obj_channel -> out_obj_channel (** An [output_filter] filters the data written to it through the * [io_obj_channel] (usually a [pipe]), and writes the filtered data * to the passed [out_obj_channel]. * * If the filter is closed, the [io_obj_channel] will be closed, too, * but not the destination [out_obj_channel] (so you can still append * further data). *) class input_filter : in_obj_channel -> io_obj_channel -> in_obj_channel (** An [input_filter] filters the data read from it through the * [io_obj_channel] (usually a [pipe] after the data have been * retrieved from the passed [in_obj_channel]. * * An [input_filter] object never generates [Buffer_underrun] exceptions. * However, if the passed [in_obj_channel] or [io_obj_channel] raises such * an exception, the exception will fall through the calling chain. * * If the filter is closed, the [io_obj_channel] will be closed, too, * but not the source [in_obj_channel] (so you can still read further * data from it). *) (** {2:filters_notes Notes, Examples} *) (** If you have the choice, prefer [output_filter] over [input_filter]. * The latter is slower. * * The primary application of filters is to encode or decode a channel * on the fly. For example, the following lines write a BASE64-encoded file: * * {[let ch = new output_channel (open_out "file.b64") in * let encoder = new Netencoding.Base64.encoding_pipe ~linelength:76 () in * let ch' = new output_filter encoder ch in * ... (* write to ch' *) * ch' # close_out(); * ch # close_out(); (* you must close both channels! *) * ]} * * All bytes written to [ch'] are BASE64-encoded and the encoded bytes are * written to [ch]. * * There are also pipes to decode BASE64, and to encode and decode the * "Quoted printable" format. Encoding and decoding work even if the * data is delivered in disadvantageous chunks, because the data is * "re-chunked" if needed. For example, BASE64 would require that data * arrive in multiples of three bytes, and to cope with that, the BASE64 pipe * only processes the prefix of the input buffer that is a multiple of three, * and defers the encoding of the extra bytes till the next opportunity. *) ocamlnet-4.1.6/src/netstring/netchannels_crypto.ml0000644000175000017500000002351613274252307021024 0ustar gerdgerd(* $Id$ *) class type tls_channel = object inherit Netchannels.raw_io_channel method tls_endpoint : Netsys_crypto_types.tls_endpoint end class type crypto_out_filter = object inherit Netchannels.out_obj_channel method supports_aead : bool method mac : unit -> string end class type crypto_in_filter = object inherit Netchannels.in_obj_channel method supports_aead : bool method mac : unit -> string end (************************** TLS *****************************) class tls_layer ?(start_pos_in=0) ?(start_pos_out=0) ?resume ~role ~rd ~wr ~peer_name config = let sbuf = Bytes.create 65536 in let recv buf = try let buf_len = min (Bigarray.Array1.dim buf) (Bytes.length sbuf) in let n = rd # input sbuf 0 buf_len in if n = 0 then raise(Unix.Unix_error(Unix.EAGAIN, "", "")); Netsys_mem.blit_bytes_to_memory sbuf 0 buf 0 n; n with | Sys_blocked_io -> raise(Unix.Unix_error(Unix.EAGAIN, "", "")) | End_of_file -> 0 in let send buf size = try let send_len = min size (Bytes.length sbuf) in Netsys_mem.blit_memory_to_bytes buf 0 sbuf 0 send_len; let n = ref 0 in while !n < send_len do let p = wr # output sbuf !n (send_len - !n) in n := !n + p done; wr # flush(); send_len with | Sys_blocked_io -> raise(Unix.Unix_error(Unix.EAGAIN, "", "")) in let endpoint = let module Config = (val config : Netsys_crypto_types.TLS_CONFIG) in let module P = Config.TLS in let ep = match resume with | None -> P.create_endpoint ~role ~recv ~send ~peer_name Config.config | Some data -> if role <> `Client then failwith "Netchannels.tls_layer: can only resume clients"; P.resume_client ~recv ~send ~peer_name Config.config data in let module Endpoint = struct module TLS = P let endpoint = ep end in (module Endpoint : Netsys_crypto_types.TLS_ENDPOINT) in ( object(self) val mutable in_closed = false val mutable out_closed = false val mutable pos_in = start_pos_in val mutable pos_out = start_pos_out method input buf pos len = if in_closed then raise Netchannels.Closed_channel; try if len=0 then raise Sys_blocked_io; let n = Netsys_tls.recv endpoint buf pos len in pos_in <- pos_in + n; if n=0 then raise End_of_file else n with | Sys_blocked_io -> 0 | Netsys_types.EAGAIN_RD -> 0 | Netsys_types.EAGAIN_WR -> 0 | Unix.Unix_error(Unix.EINTR,_,_) -> 0 method close_in () = if not in_closed then ( in_closed <- true; if out_closed then ( Netsys_tls.shutdown endpoint Unix.SHUTDOWN_ALL; wr # close_out(); rd # close_in(); ) ) method pos_in = pos_in method output buf pos len = if out_closed then raise Netchannels.Closed_channel; try if len=0 then raise Sys_blocked_io; let n = Netsys_tls.send endpoint buf pos len in pos_out <- pos_out + n; n with | Sys_blocked_io -> 0 | Netsys_types.EAGAIN_RD -> 0 | Netsys_types.EAGAIN_WR -> 0 | Unix.Unix_error(Unix.EINTR,_,_) -> 0 method flush () = if out_closed then raise Netchannels.Closed_channel; Netsys_tls.handshake endpoint method close_out() = if not out_closed then ( out_closed <- true; if in_closed then ( Netsys_tls.shutdown endpoint Unix.SHUTDOWN_ALL; wr # close_out(); rd # close_in(); ) else Netsys_tls.shutdown endpoint Unix.SHUTDOWN_SEND ) method pos_out = pos_out method tls_endpoint = endpoint end ) class tls_endpoint ?(start_pos_in=0) ?(start_pos_out=0) ?resume ~role ~peer_name fd config = let endpoint = Netsys_tls.create_file_endpoint ?resume ~role ~rd:fd ~wr:fd ~peer_name config in let fd_style = `TLS endpoint in ( object (self) inherit Netchannels.socket_descr ~fd_style fd as super method flush() = Netsys_tls.handshake (Netsys_tls.endpoint endpoint); super # flush() method tls_endpoint = (Netsys_tls.endpoint endpoint) end ) (*************** SYMM CRYPTO ************) let process_out proc ctx ch = let buf, free_buf = Netsys_mem.pool_alloc_memory2 Netsys_mem.small_pool in let out_buf, free_out_buf = Netsys_mem.pool_alloc_memory2 Netsys_mem.small_pool in let str_buf = Bytes.create (Bigarray.Array1.dim out_buf) in let buf_pos = ref 0 in let buf_len = Bigarray.Array1.dim buf in let closed = ref false in let pos_out = ref 0 in ( object(self) inherit Netchannels.augment_raw_out_channel method output s pos len = if !closed then raise Netchannels.Closed_channel; let n = min len (buf_len - !buf_pos) in Netsys_mem.blit_bytes_to_memory s pos buf !buf_pos n; buf_pos := !buf_pos + n; if !buf_pos = buf_len then self#flush(); pos_out := !pos_out + n; n method flush() = if !closed then raise Netchannels.Closed_channel; if !buf_pos > 0 then ( let buf1 = Bigarray.Array1.sub buf 0 !buf_pos in let consumed, generated = proc ~last:false buf1 out_buf in Netsys_mem.blit_memory_to_bytes out_buf 0 str_buf 0 generated; ch # really_output str_buf 0 generated; let remaining = buf_len - consumed in if remaining > 0 then Bigarray.Array1.blit (Bigarray.Array1.sub buf consumed remaining) (Bigarray.Array1.sub buf 0 remaining); buf_pos := remaining; ) method private final_flush() = (* tricky: call [proc ~last:true] at least once. Call it again if there is not enough space in out_buf (the encrypted msg can get longer), which is indicated by not consuming all data *) if !closed then raise Netchannels.Closed_channel; while !buf_pos >= 0 do let buf_sub = Bigarray.Array1.sub buf 0 !buf_pos in let consumed, generated = proc ~last:true buf_sub out_buf in Netsys_mem.blit_memory_to_bytes out_buf 0 str_buf 0 generated; ch # really_output str_buf 0 generated; let remaining = !buf_pos - consumed in if remaining > 0 then Bigarray.Array1.blit (Bigarray.Array1.sub buf consumed remaining) (Bigarray.Array1.sub buf 0 remaining); buf_pos := remaining; if !buf_pos = 0 then buf_pos := (-1) done; buf_pos := 0; () method close_out() = if not !closed then ( self # final_flush(); closed := true; free_buf(); free_out_buf(); ch # close_out() ) method pos_out = !pos_out method supports_aead = ctx # supports_aead method mac() = ctx # mac() end ) let encrypt_out ctx ch = let proc = ctx # encrypt in process_out proc ctx ch let decrypt_out ctx ch = let proc = ctx # decrypt in process_out proc ctx ch let process_in proc ctx ch = let buf, free_buf = Netsys_mem.pool_alloc_memory2 Netsys_mem.small_pool in let in_buf, free_in_buf = Netsys_mem.pool_alloc_memory2 Netsys_mem.small_pool in let str_buf = Bytes.create (Bigarray.Array1.dim in_buf) in let buf_pos = ref 0 in let buf_len = ref 0 in let in_buf_len = ref 0 in let closed = ref false in let eof = ref false in let pos_in = ref 0 in ( object(self) inherit Netchannels.augment_raw_in_channel method input s pos len = if !closed then raise Netchannels.Closed_channel; if !buf_pos = !buf_len && not !eof then ( try let l = Bigarray.Array1.dim in_buf - !in_buf_len in let n = ch # input str_buf 0 l in Netsys_mem.blit_bytes_to_memory str_buf 0 in_buf !in_buf_len n; in_buf_len := !in_buf_len + n; let consumed, generated = proc ~last:false (Bigarray.Array1.sub in_buf 0 !in_buf_len) buf in buf_pos := 0; buf_len := generated; let remaining = !in_buf_len - consumed in if remaining > 0 then Bigarray.Array1.blit (Bigarray.Array1.sub in_buf consumed remaining) (Bigarray.Array1.sub in_buf 0 remaining); in_buf_len := remaining; with | End_of_file -> eof := true; buf_pos := 0; buf_len := 0; while !in_buf_len >= 0 do let consumed, generated = proc ~last:true (Bigarray.Array1.sub in_buf 0 !in_buf_len) buf in buf_len := generated; in_buf_len := !in_buf_len - consumed; if !in_buf_len = 0 then in_buf_len := (-1) done; in_buf_len := 0; ); let n = min len (!buf_len - !buf_pos) in if !eof && n=0 && len>0 then raise End_of_file; Netsys_mem.blit_memory_to_bytes buf !buf_pos s pos n; buf_pos := !buf_pos + n; pos_in := !pos_in + n; n method close_in() = if not !closed then ( closed := true; free_buf(); free_in_buf(); ch # close_in() ) method pos_in = !pos_in method supports_aead = ctx # supports_aead method mac() = ctx # mac() end ) let encrypt_in ctx ch = let proc = ctx # encrypt in process_in proc ctx ch let decrypt_in ctx ch = let proc = ctx # decrypt in process_in proc ctx ch ocamlnet-4.1.6/src/netstring/netchannels_crypto.mli0000644000175000017500000000577413274252307021203 0ustar gerdgerd(* $Id$ *) (** Crypto extensions for {!Netchannels} *) (** {1:tls TLS} *) (** A TLS channel is a layer on top of a bidirectional channel that adds the TLS protocol. *) class type tls_channel = object inherit Netchannels.raw_io_channel method tls_endpoint : Netsys_crypto_types.tls_endpoint end class tls_layer : ?start_pos_in:int -> ?start_pos_out:int -> ?resume:string -> role:[ `Client | `Server ] -> rd:Netchannels.raw_in_channel -> wr:Netchannels.raw_out_channel -> peer_name:string option -> Netsys_crypto_types.tls_config -> tls_channel (** Adds TLS security to an already established connection, here made available as separate channels for input and output. The TLS handshake is done on the first I/O activity (call [flush] to enforce it). [resume]: see {!Netsys_tls.create_file_endpoint}. *) class tls_endpoint : ?start_pos_in:int -> ?start_pos_out:int -> ?resume:string -> role:[ `Client | `Server ] -> peer_name:string option -> Unix.file_descr -> Netsys_crypto_types.tls_config -> tls_channel (** This class is slightly more efficient than [tls_layer], and to preferred if you have direct access to the file descriptors. *) (** {1:symmetric Symmetric Cryptography} *) (** Encrypt or decrypt data while writing to a channel *) class type crypto_out_filter = object inherit Netchannels.out_obj_channel method supports_aead : bool (** Whether the cipher supports authentication, and will provide a MAC *) method mac : unit -> string (** Get the MAC of the processed data *) end (** Encrypt or decrypt data while reading from a channel *) class type crypto_in_filter = object inherit Netchannels.in_obj_channel method supports_aead : bool (** Whether the cipher supports authentication, and will provide a MAC *) method mac : unit -> string (** Get the MAC of the processed data *) end val encrypt_out : Netsys_ciphers.cipher_ctx -> Netchannels.out_obj_channel -> crypto_out_filter (** [let ch2 = encrypt_out ctx ch1]: Writing to [ch2] encrypts the data and writes the ciphertext to [ch1]. Closing [ch2] will flush data and close [ch1]. *) val encrypt_in : Netsys_ciphers.cipher_ctx -> Netchannels.in_obj_channel -> crypto_in_filter (** [let ch2 = encrypt_in ctx ch1]: Reading from [ch2] encrypts the data from [ch1]. Closing [ch2] will close [ch1]. *) val decrypt_out : Netsys_ciphers.cipher_ctx -> Netchannels.out_obj_channel -> crypto_out_filter (** [let ch2 = decrypt_out ctx ch1]: Writing to [ch2] decrypts the data and writes the plaintext to [ch1]. Closing [ch2] will flush data and close [ch1]. *) val decrypt_in : Netsys_ciphers.cipher_ctx -> Netchannels.in_obj_channel -> crypto_in_filter (** [let ch2 = decrypt_in ctx ch1]: Reading from [ch2] decrypts the data from [ch1]. Closing [ch2] will close [ch1]. *) ocamlnet-4.1.6/src/netstring/netchannels_tut.txt0000644000175000017500000005734313274252307020534 0ustar gerdgerd{1:tutorial Netchannels Tutorial} [Netchannels] is one of the basic modules of this library, because it provides some very basic abstractions needed for many other functions of the library. The key abstractions [Netchannels] defines are the types [in_obj_channel] and [out_obj_channel]. Both are class types providing sequential access to byte streams, one for input, one for output. They are comparable to the types [in_channel] and [out_channel] of the standard library that allow access to files. However, there is one fundamental difference: [in_channel] and [out_channel] are restricted to resources that are available through file descriptors, whereas [in_obj_channel] and [out_obj_channel] are just class types, and by providing implementations for them any kind of resources can be accessed. {2 Motivation} In some respect, [Netchannels] fixes a deficiency of the standard library. Look at the module [Printf] which defines six variants of the [printf] function: {[ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a val printf : ('a, out_channel, unit) format -> 'a val eprintf : ('a, out_channel, unit) format -> 'a val sprintf : ('a, unit, string) format -> 'a val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a val kprintf : (string -> string) -> ('a, unit, string) format -> 'a ]} It is possible to write into six different kinds of print targets. The basic problem of this style is that the provider of a service function like [printf] must define it for every commonly used print target. The other solution is that the provider defines only one version of the service function, but that the caller of the function arranges the polymorphism. A [Netchannels]-aware [Printf] would have only one variant of [printf]: {[ val printf : out_obj_channel -> ('a, out_obj_channel, unit) format -> 'a ]} The caller would create the right [out_obj_channel] object for the real print target: {[ let file_ch = new output_file (file : out_channel) in printf file_ch ... ]} (printing into files), or: {[ let buffer_ch = new output_buffer (buf : Buffer.t) in printf buffer_ch ... ]} (printing into buffers). Of course, this is only a hypothetical example. The point is that this library defines many parsers and printers, and that it is really a simplification for both the library and the user of the library to have this object encapsulation of I/O resources. {2 Programming with [in_obj_channel] } For example, let us program a function reading a data source line by line, and returning the sum of all lines which must be integer numbers. The argument [ch] is an open {!Netchannels.in_obj_channel}, and the return value is the sum: {[ let sum_up (ch : in_obj_channel) = let sum = ref 0 in try while true do let line = ch # input_line() in sum := !sum + int_of_string line done; assert false with End_of_file -> !sum ]} The interesting point is that the data source can be anything: a channel, a string, or any other class that implements the class type [in_obj_channel]. This expression opens the file ["data"] and returns the sum of this file: {[ let ch = new input_channel (open_in "data") in sum_up ch ]} The class {!Netchannels.input_channel} is an implementation of the type [in_obj_channel] where every method of the class simply calls the corresponding function of the module [Pervasives]. (By the way, it would be a good idea to close the channel afterwards: [ch#close_in()]. We will discuss that below.) This expression sums up the contents of a constant string: {[ let s = "1\n2\n3\n4" in let ch = new input_string s in sum_up ch ]} The class {!Netchannels.input_string} is an implementation of the type [in_obj_channel] that reads from a string that is treated like a channel. The effect of using the [Netchannels] module is that the same implementation [sum_up] can be used to read from multiple data sources, as it is sufficient to call the function with different implementations of [in_obj_channel]. {2 The details of [in_obj_channel] } The properties of any class that implements [in_obj_channel] can be summarized as follows: - After the object has been created ([new]), the netchannel is open. The netchannel remains open until it is explicitly closed (method [close_in : unit -> unit]). When you call a method of a closed netchannel, the exception [Closed_channel] is raised (even if you try to close the channel again). - The methods {[ really_input : string -> int -> int -> unit input_char : unit -> char input_byte : unit -> int input_line : unit -> string ]} work like their counterparts of the standard library. In particular, the end of file condition is signaled by rasising [End_of_file]. - The method {[ input : string -> int -> int -> int ]} works like its counterpart of the standard library, except that the end of the file is also signaled by [End_of_file], and not by the return value 0. - The method [pos_in : int] returns the current byte position of the channel in a way that is logically consistent with the input methods: After reading [n] bytes, the method must return a position that is increased by [n]. Usually the position is zero after the object has been created, but this is not specified. Positions are available even for file descriptors that are not seekable. - There is intentionally no [seek_in] method. Seekable channels are currently out of scope, as netstring focuses on non-seekable channels. {2 Programming with [out_obj_channel] } The following function outputs the numbers of an [int list] sequentially on the passed netchannel: {[ let print_int_list (ch : out_obj_channel) l = List.iter (fun n -> ch # output_string (string_of_int n); ch # output_char '\n'; ) l; ch # flush() ]} The following statements write the output into a file: {[ let ch = new output_channel (open_out "data") in print_int_list ch [1;2;3] ]} And these statements write the output into a buffer: {[ let b = Buffer.create 16 in let ch = new output_buffer b in print_int_list ch [1;2;3] ]} Again, the caller of the function [print_int_list] determines the type of the output destination, and you do not need several functions for several types of destination. {2 The details of [out_obj_channel] } The properties of any class that implements [out_obj_channel] can be summarized as follows: - After the object has been created ([new]), the netchannel is open. The netchannel remains open until it is explicitly closed (method [close_out : unit -> unit]). When you call a method of a closed netchannel, the exception [Closed_channel] is raised (even if you try to close the channel again). - The methods {[ output : string -> int -> int -> int really_output : string -> int -> int -> unit output_char : char -> unit output_byte : int -> unit output_string : string -> unit ]} work like their counterparts of the standard library. There is usually an output buffer, but this is not specified. By calling [flush : unit -> unit], the contents of the output buffer are forced to be written to the destination. - The method {[ output_buffer : Buffer.t -> unit ]} works like [Buffer.output_channel], i.e. the contents of the buffer are printed to the channel. - The method {[ output_channel : ?len:int -> in_obj_channel -> unit ]} reads data from the argument [in_obj_channel] and prints them to the output channel. By default, the input channel is read until the EOF position. If the [len] argument is passed, at most this number of bytes are copied from the input channel to the output channel. The input channel remains open in all cases. - The method [pos_out : int] returns byte positions that are logically consistent: After writing [n] bytes, the method must return a position that is increased by [n]. Usually the position is zero after the object has been created, but this is not specified. Positions are available even for file descriptors that are not seekable. - There is intentionally no [seek_out] method. Seekable channels are currently out of scope, as netstring focuses on non-seekable channels. {2 How to close channels} As channels may use file descriptors for their implementation, it is very important that all open channels are closed after they have been used; otherwise the operating system will certainly get out of file descriptors. The simple way, {[ let ch = new args ... in ... do something ... ch # close_in() or close_out() ]} is dangerous because an exception may be raised between channel creation and the [close_*] invocation. An elegant solution is to use [with_in_obj_channel] and [with_out_obj_channel], as in: {[ with_in_obj_channel (* or with_out_obj_channel *) (new ...) (fun ch -> ... do something ... ) ]} This programming idiom ensures that the channel is always closed after usage, even in the case of exceptions. Complete examples: {[ let sum = with_in_obj_channel (new input_channel (open_in "data")) sum_up ;; ]} {[ with_out_obj_channel (new output_channel (open_out "data")) (fun ch -> print_int_list ch ["1";"2";"3"]) ;; ]} {2 Examples: HTML Parsing and Printing} In the Netstring library there are lots of parsers and printers that accept netchannels as data sources and destinations, respectively. One of them is the {!Nethtml} module providing an HTML parser and printer. A few code snippets how to call them, just to get used to netchannels: {[ let html_document = with_in_obj_channel (new input_channel (open_in "myfile.html")) Nethtml.parse ;; with_out_obj_channel (new output_channel (open_out "otherfile.html")) (fun ch -> Nethtml.write ch html_document) ;; ]} {2 Transactional Output Channels} Sometimes you do not want that generated output is directly sent to the underlying file descriptor, but rather buffered until you know that everything worked fine. Imagine you program a network service, and you want to return the result only when the computations are successful, and an error message otherwise. One way to achieve this effect is to manually program a buffer: {[ let network_service ch = try let b = Buffer.create 16 in let ch' = new output_buffer b in ... computations, write results into ch' ... ch' # close_out; ch # output_buffer b with error -> ... write error message to ch ... ]} There is a better way to do this, as there are transactional output channels. This type of netchannels provide a buffer for all written data like the above example, and only if data is explicitly committed it is copied to the real destination. Alternatively, you can also rollback the channel, i.e. delete the internal buffer. The signature of the type [trans_out_obj_channel] is: {[ class type trans_out_obj_channel = object inherit out_obj_channel method commit_work : unit -> unit method rollback_work : unit -> unit end ]} They have the same methods as [out_obj_channel] plus [commit_work] and [rollback_work]. There are two implementations, one of them keeping the buffer in memory, and the other using a temporary file: {[ let ch' = new buffered_trans_channel ch ]} And: {[ let ch' = new tempfile_trans_channel ch ]} In the latter case, there are optional arguments specifiying where the temporary file is created. Now the network service would look like: {[ let network_service transaction_provider ch = try let ch' = transaction_provider ch in ... computations, write results into ch' ... ch' # commit_work(); ch' # close_out() (* implies ch # close_out() *) with error -> ch' # rollback_work(); ... write error message to ch' ... ch' # commit_work(); ch' # close_out() (* implies ch # close_out() *) ]} You can program this function without specifying which of the two implementations is used. Just call this function as {[ network_service (new buffered_trans_channel) ch ]} or {[ network_service (new tempfile_trans_channel) ch ]} to determine the type of transaction buffer. Some details: - The method [commit_work] copies all uncommitted data to the underlying channel, and flushes all buffers. - When [rollback_work] is called the uncommitted data are deleted. - The method [flush] does not have any effect. - The reported position adds the committed and the uncommitted amounts of data. This means that [rollback_work] resets the position to the value of the last [commit_work] call. - When the transactional channel is closed, the underlying channel is closed, too. By default, the uncommitted data is deleted, but the current implementations can optionally commit data in this case. {2 Pipes and Filters} The class [pipe] is an [in_obj_channel] and an [out_obj_channel] at the same time (i.e. the class has the type [io_obj_channel]). A pipe has two endpoints, one for reading and one for writing (similar in concept to the pipes provided by the operating system, but note that our pipes have nothing to do with the OS pipes). Of course, you cannot read and write at the same time, so there must be an internal buffer storing the data that have been written but not yet read. How can such a construction be useful? Imagine you have two routines that run alternately, and one is capable of writing into netchannels, and the other can read from a netchannel. Pipes are the missing communication link in this situation, because the writer routine can output into the pipe, and the reader routine can read from the buffer of the pipe. In the following example, the writer outputs numbers from 1 to 100, and the reader sums them up: {[ let pipe = new pipe() ;; let k = ref 1 ;; let writer() = if !k <= 100 then ( pipe # output_string (string_of_int !k); incr k; if !k > 100 then pipe # close_out() else pipe # output_char '\n'; ) ;; let sum = ref 0 ;; let reader() = let line = pipe # input_line() in sum := !sum + int_of_string line ;; try while true do writer(); reader() done with End_of_file -> () ;; ]} The [writer] function prints the numbers into the pipe, and the [reader] function reads them in. By closing only the output end Of the pipe the [writer] signals the end of the stream, and the [input_line] method raises the exception [End_of_file]. Of course, this example is very simple. What does happen when more is printed into the pipe than read? The internal buffer grows. What does happen when more is tried to read from the pipe than available? The input methods signal this by raising the special exception [Buffer_underrun]. Unfortunately, handling this exception can be very complicated, as the reader must be able to deal with partial reads. This could be solved by using the {!Netstream} module. A netstream is another extension of [in_obj_channel] that allows one to look ahead, i.e. you can look at the bytes that will be read next, and use this information to decide whether enough data are available or not. Netstreams are explained in another chapter of this manual. Pipes have another feature that makes them useful even for "normal" programming. You can specify a conversion function that is called when data is to be transferred from the writing end to the reading end of the pipe. The module {!Netencoding.Base64} defines such a pipe that converts data: The class [encoding_pipe] automatically encodes all bytes written into it by the Base64 scheme: {[ let pipe = new Netencoding.Base64.encoding_pipe() ;; pipe # output_string "Hello World"; pipe # close_out() ;; let s = pipe # input_line() ;; ]} [s] has now the value ["SGVsbG8gV29ybGQ="], the encoded form of the input. This kind of pipe has the same interface as the basic pipe class, and the same problems to use it. Fortunately, the Netstring library has another facility simplifying the usage of pipes, namely {b filters}. There are two kinds of filters: The class {!Netchannels.output_filter} redirects data written to an [out_obj_channel] through a pipe, and the class {!Netchannels.input_filter} arranges that data read from an [in_obj_channel] flows through a pipe. An example makes that clearer. Imagine you have a function [write_results] that writes the results of a computation into an [out_obj_channel]. Normally, this channel is simply a file: {[ with_out_obj_channel (new output_channel (open_out "results")) write_results ]} Now you want that the file is Base64-encoded. This can be arranged by calling [write_results] differently: {[ let pipe = new Netencoding.Base64.encoding_pipe() in with_out_obj_channel (new output_channel (open_out "results")) (fun ch -> let ch' = new output_filter pipe ch in write_results ch'; ch' # close_out() ) ]} Now any invocation of an output method for [ch'] actually prints into the filter, which redirects the data through the [pipe], thus encoding them, and finally passing the encoded data to the underlying channel [ch]. Note that you must close [ch'] to ensure that all data are filtered, it is not sufficient to flush output. It is important to understand why filters must be closed to work properly. The problem is that the Base64 encoding converts triples of three bytes into quadruples of four bytes. Because not every string to convert is a multiple of three, there are special rules how to handle the exceeding one or two bytes at the end. The pipe must know the end of the input data in order to apply these rules correctly. If you only flush the filter, the exceeding bytes would simply remain in the internal buffer, because it is possible that more bytes follow. By closing the filter, you indicate that the definite end is reached, and the special rules for trailing data must be performed. \- Many conversions have similar problems, and because of this it is a good advice to always close output filters after usage. There is not only the class [output_filter] but also [input_filter]. This class can be used to perform conversions while reading from a file. Note that you often do not need to close input filters, because input channels can signal the end by raising [End_of_file], so the mentioned problems usually do not occur. There are a number of predefined conversion pipes: - {!Netencoding.Base64.encoding_pipe}: Performs Base64 encoding - {!Netencoding.Base64.decoding_pipe}: Performs Base64 decoding - {!Netencoding.QuotedPrintable.encoding_pipe}: Performs QuotedPrintable encoding - {!Netencoding.QuotedPrintable.decoding_pipe}: Performs QuotedPrintable decoding - {!Netconversion.conversion_pipe}: Converts the character encoding form charset A to charset B {2 Defining Classes for Object Channels} As subtyping and inheritance are orthogonal in O'Caml, you can simply create your own netchannels by defining classes that match the [in_obj_channel] or [out_obj_channel] types. E.g. {[ class my_in_channel : in_obj_channel = object (self) method input s pos len = ... method close_in() = ... method pos_in = ... method really_input s pos len = ... method input_char() = ... method input_line() = ... method input_byte() = ... end ]} Of course, this is non-trivial, especially for the [in_obj_channel] case. Fortunately, the Netchannels module includes a "construction kit" that allows one to define a channel class from only a few methods. A closer look at [in_obj_channel] and [out_obj_channel] shows that some methods can be derived from more fundamental methods. The following class types include only the fundamental methods: {[ class type raw_in_channel = object method input : string -> int -> int -> int method close_in : unit -> unit method pos_in : int end ]} {[ class type raw_out_channel = object method output : string -> int -> int -> int method close_out : unit -> unit method pos_out : int method flush : unit -> unit end ]} In order to define a new class, it is sufficient to define this raw version of the class, and to lift it to the full functionality. For example, to define [my_in_channel]: {[ class my_raw_in_channel : raw_in_channel = object (self) method input s pos len = ... method close_in() = ... method pos_in = ... end class my_in_channel = in_obj_channel_delegation (lift_in (`Raw(new my_raw_in_channel))) ]} The function {!Netchannels.lift_in} can lift several forms of incomplete channel objects to the full class type [in_obj_channel]. There is also the corresponding function {!Netchannels.lift_out}. Note that lifting adds by default another internal buffer to the channel that must be explicitly turned off when it is not wanted. The rationale for this buffer is that it avoids some cases with extremely poor performance which might be surprising for many users. The class [in_obj_channel_delegation] is just an auxiliary construction to turn the [in_obj_channel] {i object} returned by [lift_in] again into a class. {2 Some FAQ} {ul {- {i Netchannels add further layers on top of the built-in channels or file descriptors. Does this make them slow?} Of course, Netchannels are slower than the underlying built-in I/O facilities. There is at least one, but often even more than one method call until the data is transferred to or from the final I/O target. This costs time, and it is a good idea to reduce the number of method calls for maximum speed. Especially the character- or byte-based method calls should be avoided, it is better to collect data and pass them in larger chunks. This reduces the number of method calls that are needed to transfer a block of data. However, some classes implement buffers themselves, and data are only transferred when the buffers are full (or empty). The overhead for the extra method calls is small for these classes. The classes that implement their own buffers are the transactional channels, the pipes, and all the classes with "buffer" in their name. Netchannels are often stacked, i.e. one netchannel object transfers data to an underlying object, and this object passes the data to further objects. Often buffers are involved, and data are copied between buffers several times. Of course, these copies can reduce the speed, too.} {- {i Why do Netchannels not support seeking?} Netchannels were invented to support the implementation of network protocols. Network endpoints are not seekable.} {- {i What about [printf] and [scanf]?} In principle, methods for [printf] and [scanf] could be added to [out_obj_channel] and [in_obj_channel], respectively, as recent versions of O'Caml added the necessary language means (polymorphic methods, [kprintf], [kscanf]). However, polymorphic methods work only well when the type of the channel object is always annotated (e.g. as [(ch : out_obj_channel) # printf ...]), so this is not that much better than [ch # output_string (sprintf ...)].} {- {i Can I pass an [in_obj_channel] to an ocamllex-generated lexer?} Yes, just call {!Netchannels.lexbuf_of_in_obj_channel} to turn the [in_obj_channel] into a [lexbuf].} {- {i Do Netchannels support non-blocking I/O?} Yes and no. Yes, because you can open a descriptor in non-blocking mode, and create a netchannel from it. When the program would block, the [input] and [output] methods return 0 to indicate this. However, the non-raw methods cannot cope with these situations.} {- {i Do Netchannels support multiplexed I/O?} No, there is no equivalent to [Unix.select] on the level of netchannels.} {- {i Can I use Netchannels in multi-threaded programs?} Yes. However, shared netchannels are not locked, and strange things can happen when netchannels are used by several threads at the same time.} {- {i Can I use pipes to communicate between threads?} This could be made work, but it is currently not the case. A multithreading-aware wrapper around pipes could do the job.} {- {i Pipes call external programs to do their job, don't they?} No, they do not call external programs, nor do they need any parallel execution threads. Pipes are just a tricky way of organizing buffers.} {- {i How do I define my own conversion pipe?} Look at the sources [netencoding.ml], it includes several examples of conversion pipes.} } ocamlnet-4.1.6/src/netstring/netcompression.ml0000644000175000017500000000175413274252307020172 0ustar gerdgerd(* $Id$ *) type algo = { iana_name : string; encoder : (unit -> Netchannels.io_obj_channel) option; decoder : (unit -> Netchannels.io_obj_channel) option; } let registry = Hashtbl.create 5 let register ~iana_name ?encoder ?decoder () = let algo = { iana_name = iana_name; encoder = encoder; decoder = decoder } in Hashtbl.replace registry iana_name algo let lookup_encoder ~iana_name = let algo = Hashtbl.find registry iana_name in match algo.encoder with | None -> raise Not_found | Some f -> f let lookup_decoder ~iana_name = let algo = Hashtbl.find registry iana_name in match algo.decoder with | None -> raise Not_found | Some f -> f let all_encoders() = Hashtbl.fold (fun name algo acc -> if algo.encoder <> None then name :: acc else acc ) registry [] let all_decoders() = Hashtbl.fold (fun name algo acc -> if algo.decoder <> None then name :: acc else acc ) registry [] ocamlnet-4.1.6/src/netstring/netcompression.mli0000644000175000017500000000170113274252307020333 0ustar gerdgerd(* $Id$ *) (** Registry for compression algorithms *) (** This registry is initially empty. The {!Netgzip} module can be used to register the [gzip] algorithm, just run {[ Netgzip.init() ]} to get this effect. *) val register : iana_name:string -> ?encoder:(unit -> Netchannels.io_obj_channel) -> ?decoder:(unit -> Netchannels.io_obj_channel) -> unit -> unit (** Registers a compression algorithm. The algorithm is given as a pair of functions returning {!Netchannels.io_obj_channel}. *) val lookup_encoder : iana_name:string -> unit -> Netchannels.io_obj_channel (** Returns the encoder, or raises [Not_found] *) val lookup_decoder : iana_name:string -> unit -> Netchannels.io_obj_channel (** Returns the decoder, or raises [Not_found] *) val all_encoders : unit -> string list val all_decoders : unit -> string list (** The iana names of all encoders and decoders, resp. *) ocamlnet-4.1.6/src/netstring/netconst.mli0000644000175000017500000000013213274252307017115 0ustar gerdgerd(* $Id$ *) val ocamlnet_version : string (* Returns the version string of Ocamlnet *) ocamlnet-4.1.6/src/netstring/netconst.mlp0000644000175000017500000000006213274252307017126 0ustar gerdgerd(* $Id$ *) let ocamlnet_version = "@VERSION@" ;; ocamlnet-4.1.6/src/netstring/netconversion.ml0000644000175000017500000036031613274252307020020 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- *) open Netsys_types open Netaux.ArrayAux exception Malformed_code exception Cannot_represent of int let multibyte_limit = (* 6 *) 50;; (* The longest multibyte character of all supported encodings, * and the longest substitution string. *) let big_slice = (* 3 *) 250;; (* The typical length of slices *) (* Seems to be a good source: ftp://dkuug.dk/i18n/charmaps *) type encoding = [ `Enc_utf8 (* UTF-8 *) | `Enc_utf8_opt_bom | `Enc_java | `Enc_utf16 (* UTF-16 with unspecified endianess (restricted usage) *) | `Enc_utf16_le (* UTF-16 little endian *) | `Enc_utf16_be (* UTF-16 big endian *) | `Enc_utf32 (* UTF-32 with unspecified endianess (restricted usage) *) | `Enc_utf32_le (* UTF-32 little endian *) | `Enc_utf32_be (* UTF-32 big endian *) | `Enc_usascii (* US-ASCII (only 7 bit) *) | `Enc_iso88591 (* ISO-8859-1 *) | `Enc_iso88592 (* ISO-8859-2 *) | `Enc_iso88593 (* ISO-8859-3 *) | `Enc_iso88594 (* ISO-8859-4 *) | `Enc_iso88595 (* ISO-8859-5 *) | `Enc_iso88596 (* ISO-8859-6 *) | `Enc_iso88597 (* ISO-8859-7 *) | `Enc_iso88598 (* ISO-8859-8 *) | `Enc_iso88599 (* ISO-8859-9 *) | `Enc_iso885910 (* ISO-8859-10 *) | `Enc_iso885911 (* ISO-8859-11 *) | `Enc_iso885913 (* ISO-8859-13 *) | `Enc_iso885914 (* ISO-8859-14 *) | `Enc_iso885915 (* ISO-8859-15 *) | `Enc_iso885916 (* ISO-8859-16 *) | `Enc_koi8r (* KOI8-R *) (* http://koi8.pp.ru *) (*| `Enc_koi8u (* KOI8-U *) (* http://www.net.ua/KOI8-U/index.html *)*) | `Enc_jis0201 (* JIS-X-0201 *) (* | `Enc_jis0201_roman (* JIS-X-0201 only roman half *) | `Enc_jis0201_kana (* JIS-X-0201 katakana half remapped to 0x21..XXX *) | `Enc_jis0208_94x94 (* JIS-X-0208 in ISO-2022-style two byte encoding *) | `Enc_jis0212_94x94 (* JIS-X-0212 in ISO-2022-style two byte encoding *) *) | `Enc_eucjp (* EUC-JP *) | `Enc_euckr (* EUC-KR *) (* | `Enc_iso2022 of iso2022_state | `Enc_iso2022jp of iso2022jp_state *) (* Older standards: *) | `Enc_asn1_iso646 (* only the language-neutral subset *) | `Enc_asn1_T61 (* ITU T.61 ("Teletex") *) | `Enc_asn1_printable (* Microsoft: *) | `Enc_windows1250 (* WINDOWS-1250 *) | `Enc_windows1251 (* WINDOWS-1251 *) | `Enc_windows1252 (* WINDOWS-1252 *) | `Enc_windows1253 (* WINDOWS-1253 *) | `Enc_windows1254 (* WINDOWS-1254 *) | `Enc_windows1255 (* WINDOWS-1255 *) | `Enc_windows1256 (* WINDOWS-1256 *) | `Enc_windows1257 (* WINDOWS-1257 *) | `Enc_windows1258 (* WINDOWS-1258 *) (* IBM, ASCII-based: *) | `Enc_cp437 | `Enc_cp737 | `Enc_cp775 | `Enc_cp850 | `Enc_cp852 | `Enc_cp855 | `Enc_cp856 | `Enc_cp857 | `Enc_cp860 | `Enc_cp861 | `Enc_cp862 | `Enc_cp863 | `Enc_cp864 | `Enc_cp865 | `Enc_cp866 (* Russian *) | `Enc_cp869 | `Enc_cp874 | `Enc_cp1006 (* IBM, EBCDIC-based: *) | `Enc_cp037 (* EBCDIC USA Canada *) (* 273: EBCDIC Germany, Austria, * 277: Denmark, Norway, * 278: Finland, Sweden, * 280: Italy, * 284: Spain, Latin America, * 285: United Kingdom, * 297: France, * 871: Iceland, *) | `Enc_cp424 | `Enc_cp500 (* EBCDIC International *) | `Enc_cp875 (* EBCDIC Modern Greek *) | `Enc_cp1026 (* EBCDIC Turkish *) | `Enc_cp1047 (* EBCDIC Latin1, OS 390 System Services *) (* Adobe: *) | `Enc_adobe_standard_encoding | `Enc_adobe_symbol_encoding | `Enc_adobe_zapf_dingbats_encoding (* Apple: *) | `Enc_macroman (* Encoding subset: *) | `Enc_subset of (encoding * (int -> bool)) | `Enc_empty ] ;; type charset = [ `Set_unicode (* The full Unicode repertoire *) | `Set_usascii (* US-ASCII (only 7 bit) *) | `Set_iso88591 (* ISO-8859-1 *) | `Set_iso88592 (* ISO-8859-2 *) | `Set_iso88593 (* ISO-8859-3 *) | `Set_iso88594 (* ISO-8859-4 *) | `Set_iso88595 (* ISO-8859-5 *) | `Set_iso88596 (* ISO-8859-6 *) | `Set_iso88597 (* ISO-8859-7 *) | `Set_iso88598 (* ISO-8859-8 *) | `Set_iso88599 (* ISO-8859-9 *) | `Set_iso885910 (* ISO-8859-10 *) | `Set_iso885911 (* ISO-8859-11 *) | `Set_iso885913 (* ISO-8859-13 *) | `Set_iso885914 (* ISO-8859-14 *) | `Set_iso885915 (* ISO-8859-15 *) | `Set_iso885916 (* ISO-8859-16 *) | `Set_koi8r (* KOI8-R *) | `Set_jis0201 (* JIS-X-0201 *) | `Set_jis0208 (* JIS-X-0208 *) | `Set_jis0212 (* JIS-X-0212 *) | `Set_ks1001 (* KS-X-1001 *) | `Set_asn1_iso646 | `Set_asn1_T61 | `Set_asn1_printable (* Microsoft: *) | `Set_windows1250 (* WINDOWS-1250 *) | `Set_windows1251 (* WINDOWS-1251 *) | `Set_windows1252 (* WINDOWS-1252 *) | `Set_windows1253 (* WINDOWS-1253 *) | `Set_windows1254 (* WINDOWS-1254 *) | `Set_windows1255 (* WINDOWS-1255 *) | `Set_windows1256 (* WINDOWS-1256 *) | `Set_windows1257 (* WINDOWS-1257 *) | `Set_windows1258 (* WINDOWS-1258 *) (* IBM, ASCII-based: *) | `Set_cp437 | `Set_cp737 | `Set_cp775 | `Set_cp850 | `Set_cp852 | `Set_cp855 | `Set_cp856 | `Set_cp857 | `Set_cp860 | `Set_cp861 | `Set_cp862 | `Set_cp863 | `Set_cp864 | `Set_cp865 | `Set_cp866 | `Set_cp869 | `Set_cp874 | `Set_cp1006 (* IBM, EBCDIC-based: *) | `Set_cp037 | `Set_cp424 | `Set_cp500 | `Set_cp875 | `Set_cp1026 | `Set_cp1047 (* Adobe: *) | `Set_adobe_standard_encoding | `Set_adobe_symbol_encoding | `Set_adobe_zapf_dingbats_encoding (* Apple: *) | `Set_macroman ] ;; let ascii_compat_encodings = [ `Enc_utf8; `Enc_utf8_opt_bom; `Enc_java; `Enc_usascii; `Enc_iso88591; `Enc_iso88592; `Enc_iso88593; `Enc_iso88594; `Enc_iso88595; `Enc_iso88596; `Enc_iso88597; `Enc_iso88598; `Enc_iso88599; `Enc_iso885910; `Enc_iso885911; `Enc_iso885913; `Enc_iso885914; `Enc_iso885915; `Enc_iso885916; `Enc_koi8r; `Enc_windows1250; `Enc_windows1251; `Enc_windows1252; `Enc_windows1253; `Enc_windows1254; `Enc_windows1255; `Enc_windows1256; `Enc_windows1257; `Enc_windows1258; `Enc_cp437; `Enc_cp737; `Enc_cp775; `Enc_cp850; `Enc_cp852; `Enc_cp855; `Enc_cp856; `Enc_cp857; `Enc_cp860; `Enc_cp861; `Enc_cp862; `Enc_cp863; `Enc_cp864; `Enc_cp865; `Enc_cp866; `Enc_cp869; `Enc_cp874; `Enc_cp1006; `Enc_eucjp; `Enc_euckr; `Enc_macroman; ] ;; let rec is_ascii_compatible = function | `Enc_subset(e,_) -> is_ascii_compatible e | e -> List.mem e ascii_compat_encodings ;; let rec is_single_byte = function `Enc_utf8 | `Enc_utf8_opt_bom | `Enc_java | `Enc_utf16 | `Enc_utf16_le | `Enc_utf16_be | `Enc_utf32 | `Enc_utf32_le | `Enc_utf32_be -> false | `Enc_eucjp -> false | `Enc_euckr -> false | `Enc_subset(e,_) -> is_single_byte e | _ -> true ;; let punct_re = Netstring_str.regexp "[-_.]";; let ibm_re = Netstring_str.regexp "^IBM\\([0-9]+\\)$";; let year_re = Netstring_str.regexp ":[0-9][0-9][0-9][0-9]$";; let norm_enc_name e = (* Removes some punctuation characters from e; uppercase; * converts "IBM#" to "CP#"; drops ":YEAR" suffixes *) let e1 = STRING_UPPERCASE e in let e2 = Netstring_str.global_replace punct_re "" e1 in let e3 = Netstring_str.global_replace year_re "" e2 in match Netstring_str.string_match ibm_re e3 0 with Some r -> "CP" ^ Netstring_str.matched_group r 1 e3 | None -> e3 ;; let names = (* The first name is the official name, the other are aliases. * The aliases must not contain any of the punctuation characters * - _ . * `Enc_subset is missing in this list, of course. * * http://www.iana.org/assignments/character-sets * * A good reference is also: * http://www.firstobject.com/character-set-name-alias-code-page.htm *) [ `Enc_utf16, [ "UTF-16"; "UTF16"; "UCS2"; "ISO10646UCS2" ]; `Enc_utf16_be, [ "UTF-16BE"; "UTF16BE" ]; `Enc_utf16_le, [ "UTF-16LE"; "UTF16LE" ]; `Enc_utf32, [ "UTF-32"; "UTF32"; "UCS4"; "ISO10646UCS4" ]; `Enc_utf32_be, [ "UTF-32BE"; "UTF32BE" ]; `Enc_utf32_le, [ "UTF-32LE"; "UTF32LE" ]; `Enc_utf8, [ "UTF-8"; "UTF8" ]; `Enc_utf8_opt_bom, [ "UTF-8"; "UTF8" ]; `Enc_java, [ "UTF-8-JAVA"; "UTF8JAVA"; "JAVA" ]; `Enc_usascii, [ "US-ASCII"; "USASCII"; "ASCII"; "ISO646US"; "CP367"; "ISOIR6"; "ANSIX341968" ]; `Enc_iso88591, [ "ISO-8859-1"; "ISO88591"; "LATIN1"; "CP819"; "ISOIR100" ]; `Enc_iso88592, [ "ISO-8859-2"; "ISO88592"; "LATIN2"; "ISOIR101"; "CP912" ]; `Enc_iso88593, [ "ISO-8859-3"; "ISO88593"; "LATIN3"; "ISOIR109" ]; `Enc_iso88594, [ "ISO-8859-4"; "ISO88594"; "LATIN4"; "ISOIR110" ]; `Enc_iso88595, [ "ISO-8859-5"; "ISO88595"; "CYRILLIC"; "ISOIR144"; "CP915" ]; `Enc_iso88596, [ "ISO-8859-6"; "ISO88596"; "ARABIC"; "ECMA114"; "ASMO708"; "ISOIR127"; "CP1089" ]; `Enc_iso88597, [ "ISO-8859-7"; "ISO88597"; "GREEK"; "GREEK8"; "ELOT928"; "ECMA118"; "ISOIR126"; "CP813" ]; `Enc_iso88598, [ "ISO-8859-8"; "ISO88598"; "HEBREW"; "ISOIR138"; "CP916" ]; `Enc_iso88599, [ "ISO-8859-9"; "ISO88599"; "LATIN5"; "ISOIR148"; "CP920" ]; `Enc_iso885910, [ "ISO-8859-10"; "ISO885910"; "LATIN6"; "ISOIR157" ]; `Enc_iso885911, [ "ISO-8859-11"; "ISO885911"; ]; `Enc_iso885913, [ "ISO-8859-13"; "ISO885913"; "LATIN7" ]; `Enc_iso885914, [ "ISO-8859-14"; "ISO885914"; "LATIN8"; "ISOIR199"; "ISOCELTIC" ]; `Enc_iso885915, [ "ISO-8859-15"; "ISO885915"; "LATIN9"; "ISOIR203" ]; `Enc_iso885916, [ "ISO-8859-16"; "ISO885916"; "LATIN10"; "SR14111"; "ROMANIAN"; "ISOIR226" ]; `Enc_koi8r, [ "KOI8-R"; "KOI8R"; "CP878" ]; `Enc_jis0201, [ "JIS_X0201"; "JIS0201"; "JISX0201"; "X0201" ]; `Enc_eucjp, [ "EUC-JP"; "EUCJP"; ]; `Enc_euckr, [ "EUC-KR"; "EUCKR"; ]; `Enc_windows1250, [ "WINDOWS-1250"; "WINDOWS1250" ]; `Enc_windows1251, [ "WINDOWS-1251"; "WINDOWS1251" ]; `Enc_windows1252, [ "WINDOWS-1252"; "WINDOWS1252" ]; `Enc_windows1253, [ "WINDOWS-1253"; "WINDOWS1253" ]; `Enc_windows1254, [ "WINDOWS-1254"; "WINDOWS1254" ]; `Enc_windows1255, [ "WINDOWS-1255"; "WINDOWS1255" ]; `Enc_windows1256, [ "WINDOWS-1256"; "WINDOWS1256" ]; `Enc_windows1257, [ "WINDOWS-1257"; "WINDOWS1257" ]; `Enc_windows1258, [ "WINDOWS-1258"; "WINDOWS1258" ]; `Enc_cp437, [ "IBM437"; "CP437" ]; `Enc_cp737, [ "IBM737"; "CP737" ]; `Enc_cp775, [ "IBM775"; "CP775" ]; `Enc_cp850, [ "IBM850"; "CP850" ]; `Enc_cp852, [ "IBM852"; "CP852" ]; `Enc_cp855, [ "IBM855"; "CP855" ]; `Enc_cp856, [ "IBM856"; "CP856" ]; `Enc_cp857, [ "IBM857"; "CP857" ]; `Enc_cp860, [ "IBM860"; "CP860" ]; `Enc_cp861, [ "IBM861"; "CP861"; "CPIS" ]; `Enc_cp862, [ "IBM862"; "CP862" ]; `Enc_cp863, [ "IBM863"; "CP863" ]; `Enc_cp864, [ "IBM864"; "CP864" ]; `Enc_cp865, [ "IBM865"; "CP865" ]; `Enc_cp866, [ "IBM866"; "CP866" ]; `Enc_cp869, [ "IBM869"; "CP869"; "CPGR" ]; `Enc_cp874, [ "IBM874"; "CP874" ]; `Enc_cp1006, [ "IBM1006"; "CP1006" ]; `Enc_cp037, [ "IBM037"; "CP037"; "EBCDICCPUS"; "EBCDICCPCA"; "EBCDICCPWT"; "EBCDICCPNL" ]; `Enc_cp424, [ "IBM424"; "CP424"; "EBCDICCPHE" ]; `Enc_cp500, [ "IBM500"; "CP500"; "EBCDICCPBE"; "EBCDICCPCH" ]; `Enc_cp875, [ "IBM875"; "CP875" ]; `Enc_cp1026, [ "IBM1026"; "CP1026" ]; `Enc_cp1047, [ "IBM1047"; "CP1047"; ]; `Enc_adobe_standard_encoding, [ "ADOBE-STANDARD-ENCODING"; "ADOBESTANDARDENCODING" ]; `Enc_adobe_symbol_encoding, [ "ADOBE-SYMBOL-ENCODING"; "ADOBESYMBOLENCODING" ]; `Enc_adobe_zapf_dingbats_encoding, [ "ADOBE-ZAPF-DINGBATS-ENCODING"; "ADOBEZAPFDINGBATSENCODING" ]; `Enc_macroman, [ "MACINTOSH"; "MACINTOSH"; "MACROMAN"; "MAC" ]; (* The ASN.1 encodings are intentionally not member of this list *) ] ;; let encoding_of_string e = let ne = norm_enc_name e in try fst (List.find (fun (enc, nlist) -> List.mem ne (List.tl nlist)) names ) with Not_found -> failwith "Netconversion.encoding_of_string: unknown encoding" ;; let rec string_of_encoding (e : encoding) = (* If there is a "preferred MIME name", this name is returned (see IANA). *) match e with | `Enc_subset(e,_) -> string_of_encoding e | _ -> try let l = List.assoc e names in List.hd l with Not_found -> assert false (* Because [names] must be complete *) ;; let internal_name (cs : charset) = (* The name used for netdb lookups *) match cs with | `Set_unicode -> "unicode" | `Set_usascii -> "usascii" | `Set_iso88591 -> "iso88591" | `Set_iso88592 -> "iso88592" | `Set_iso88593 -> "iso88593" | `Set_iso88594 -> "iso88594" | `Set_iso88595 -> "iso88595" | `Set_iso88596 -> "iso88596" | `Set_iso88597 -> "iso88597" | `Set_iso88598 -> "iso88598" | `Set_iso88599 -> "iso88599" | `Set_iso885910 -> "iso885910" | `Set_iso885911 -> "iso885911" | `Set_iso885913 -> "iso885913" | `Set_iso885914 -> "iso885914" | `Set_iso885915 -> "iso885915" | `Set_iso885916 -> "iso885916" | `Set_koi8r -> "koi8r" | `Set_jis0201 -> "jis0201" | `Set_jis0208 -> "jis0208" | `Set_jis0212 -> "jis0212" | `Set_ks1001 -> "ks1001" | `Set_asn1_iso646 -> "asn1_iso646" | `Set_asn1_T61 -> "asn1_t61" | `Set_asn1_printable -> "asn1_printable" | `Set_windows1250 -> "windows1250" | `Set_windows1251 -> "windows1251" | `Set_windows1252 -> "windows1252" | `Set_windows1253 -> "windows1253" | `Set_windows1254 -> "windows1254" | `Set_windows1255 -> "windows1255" | `Set_windows1256 -> "windows1256" | `Set_windows1257 -> "windows1257" | `Set_windows1258 -> "windows1258" | `Set_cp437 -> "cp437" | `Set_cp737 -> "cp737" | `Set_cp775 -> "cp775" | `Set_cp850 -> "cp850" | `Set_cp852 -> "cp852" | `Set_cp855 -> "cp855" | `Set_cp856 -> "cp856" | `Set_cp857 -> "cp857" | `Set_cp860 -> "cp860" | `Set_cp861 -> "cp861" | `Set_cp862 -> "cp862" | `Set_cp863 -> "cp863" | `Set_cp864 -> "cp864" | `Set_cp865 -> "cp865" | `Set_cp866 -> "cp866" | `Set_cp869 -> "cp869" | `Set_cp874 -> "cp874" | `Set_cp1006 -> "cp1006" | `Set_cp037 -> "cp037" | `Set_cp424 -> "cp424" | `Set_cp500 -> "cp500" | `Set_cp875 -> "cp875" | `Set_cp1026 -> "cp1026" | `Set_cp1047 -> "cp1047" | `Set_adobe_standard_encoding -> "adobe_standard_encoding" | `Set_adobe_symbol_encoding -> "adobe_symbol_encoding" | `Set_adobe_zapf_dingbats_encoding -> "adobe_zapf_dingbats_encoding" | `Set_macroman -> "macroman" ;; let rec required_charsets (e : encoding) = (* The name is a bit misleading. The function returns the charsets that * correspond to the conversion tables that are required to support the * encoding. *) match e with | `Enc_utf8 | `Enc_utf8_opt_bom | `Enc_java | `Enc_utf16 | `Enc_utf16_le | `Enc_utf16_be | `Enc_utf32 | `Enc_utf32_le | `Enc_utf32_be -> [] | `Enc_usascii -> [] | `Enc_iso88591 -> [] | `Enc_iso88592 -> [ `Set_iso88592 ] | `Enc_iso88593 -> [ `Set_iso88593 ] | `Enc_iso88594 -> [ `Set_iso88594 ] | `Enc_iso88595 -> [ `Set_iso88595 ] | `Enc_iso88596 -> [ `Set_iso88596 ] | `Enc_iso88597 -> [ `Set_iso88597 ] | `Enc_iso88598 -> [ `Set_iso88598 ] | `Enc_iso88599 -> [ `Set_iso88599 ] | `Enc_iso885910 -> [ `Set_iso885910 ] | `Enc_iso885911 -> [ `Set_iso885911 ] | `Enc_iso885913 -> [ `Set_iso885913 ] | `Enc_iso885914 -> [ `Set_iso885914 ] | `Enc_iso885915 -> [ `Set_iso885915 ] | `Enc_iso885916 -> [ `Set_iso885916 ] | `Enc_koi8r -> [ `Set_koi8r ] | `Enc_jis0201 -> [ `Set_jis0201 ] | `Enc_eucjp -> [ `Set_jis0201; `Set_jis0208; `Set_jis0212 ] | `Enc_euckr -> [ `Set_ks1001 ] | `Enc_asn1_iso646 -> [ `Set_asn1_iso646 ] | `Enc_asn1_T61 -> [ `Set_asn1_T61 ] | `Enc_asn1_printable -> [ `Set_asn1_printable ] | `Enc_windows1250 -> [ `Set_windows1250 ] | `Enc_windows1251 -> [ `Set_windows1251 ] | `Enc_windows1252 -> [ `Set_windows1252 ] | `Enc_windows1253 -> [ `Set_windows1253 ] | `Enc_windows1254 -> [ `Set_windows1254 ] | `Enc_windows1255 -> [ `Set_windows1255 ] | `Enc_windows1256 -> [ `Set_windows1256 ] | `Enc_windows1257 -> [ `Set_windows1257 ] | `Enc_windows1258 -> [ `Set_windows1258 ] | `Enc_cp437 -> [ `Set_cp437 ] | `Enc_cp737 -> [ `Set_cp737 ] | `Enc_cp775 -> [ `Set_cp775 ] | `Enc_cp850 -> [ `Set_cp850 ] | `Enc_cp852 -> [ `Set_cp852 ] | `Enc_cp855 -> [ `Set_cp855 ] | `Enc_cp856 -> [ `Set_cp856 ] | `Enc_cp857 -> [ `Set_cp857 ] | `Enc_cp860 -> [ `Set_cp860 ] | `Enc_cp861 -> [ `Set_cp861 ] | `Enc_cp862 -> [ `Set_cp862 ] | `Enc_cp863 -> [ `Set_cp863 ] | `Enc_cp864 -> [ `Set_cp864 ] | `Enc_cp865 -> [ `Set_cp865 ] | `Enc_cp866 -> [ `Set_cp866 ] | `Enc_cp869 -> [ `Set_cp869 ] | `Enc_cp874 -> [ `Set_cp874 ] | `Enc_cp1006 -> [ `Set_cp1006 ] | `Enc_cp037 -> [ `Set_cp037 ] | `Enc_cp424 -> [ `Set_cp424 ] | `Enc_cp500 -> [ `Set_cp500 ] | `Enc_cp875 -> [ `Set_cp875 ] | `Enc_cp1026 -> [ `Set_cp1026 ] | `Enc_cp1047 -> [ `Set_cp1047 ] | `Enc_adobe_standard_encoding -> [ `Set_adobe_standard_encoding ] | `Enc_adobe_symbol_encoding -> [ `Set_adobe_symbol_encoding ] | `Enc_adobe_zapf_dingbats_encoding -> [ `Set_adobe_zapf_dingbats_encoding ] | `Enc_macroman -> [ `Set_macroman ] | `Enc_subset(e',_) -> required_charsets e' | `Enc_empty -> [] ;; let rec same_encoding e1 e2 = match (e1,e2) with (`Enc_subset(e1_sub, f1), `Enc_subset(e2_sub, f2)) -> same_encoding e1_sub e2_sub && f1 == f2 | (_,_) -> e1 = e2 ;; let rec byte_order_mark = function `Enc_utf16_le -> "\255\254" | `Enc_utf16_be -> "\254\255" | `Enc_utf32_le -> "\255\254\000\000" | `Enc_utf32_be -> "\000\000\254\255" | `Enc_subset(e,_) -> byte_order_mark e | _ -> "" ;; let available_input_encodings() = let l = ref [] in List.iter (fun (e,_) -> let charsets = required_charsets e in if List.for_all (fun cs -> Netdb.exists_db ("cmapf." ^ internal_name cs)) charsets then l := e :: !l ) names; !l ;; let available_output_encodings() = let exclude = [ `Enc_utf16; `Enc_utf32 ] in let l = ref [] in List.iter (fun (e,_) -> if not (List.mem e exclude) then begin let charsets = required_charsets e in if List.for_all (fun cs -> Netdb.exists_db ("cmapr." ^ internal_name cs)) charsets then l := e :: !l end ) names; !l ;; let (win32_code_pages : (_ * encoding) list) = [ 65001, `Enc_utf8; 1200, `Enc_utf16_le; 1201, `Enc_utf16_be; 20127, `Enc_usascii; 28591, `Enc_iso88591; 28592, `Enc_iso88592; 28593, `Enc_iso88593; 28594, `Enc_iso88594; 28595, `Enc_iso88595; 28596, `Enc_iso88596; 28597, `Enc_iso88597; 28598, `Enc_iso88598; 28599, `Enc_iso88599; (* `Enc_iso885910 *) (* `Enc_iso885911 *) 28603, `Enc_iso885913; (* `Enc_iso885914 *) 28605, `Enc_iso885915; (* `Enc_iso885916 *) 20866, `Enc_koi8r; (* `Enc_jis0201 *) 20932, `Enc_eucjp; 51949, `Enc_euckr; 1250, `Enc_windows1250; 1251, `Enc_windows1251; 1252, `Enc_windows1252; 1253, `Enc_windows1253; 1254, `Enc_windows1254; 1255, `Enc_windows1255; 1256, `Enc_windows1256; 1257, `Enc_windows1257; 1258, `Enc_windows1258; 437, `Enc_cp437; 737, `Enc_cp737; 775, `Enc_cp775; 850, `Enc_cp850; 852, `Enc_cp852; 855, `Enc_cp855; (* `Enc_cp856 *) 857, `Enc_cp857; 860, `Enc_cp860; 861, `Enc_cp861; 862, `Enc_cp862; 863, `Enc_cp863; 864, `Enc_cp864; 865, `Enc_cp865; 866, `Enc_cp866; 869, `Enc_cp869; 874, `Enc_cp874; (* `Enc_cp1006 *) 37, `Enc_cp037; 20424, `Enc_cp424; 500, `Enc_cp500; 875, `Enc_cp875; 1026, `Enc_cp1026; 1047, `Enc_cp1047; (* `Enc_adobe_standard_encoding *) (* `Enc_adobe_symbol_encoding *) (* `Enc_adobe_zapf_dingbats_encoding *) 10000, `Enc_macroman; ] let user_encoding() = match Sys.os_type with | "Win32" -> let cp = Netsys_win32.get_active_code_page() in ( try Some(List.assoc cp win32_code_pages) with Not_found -> None ) | _ -> ( try let codeset = (Netsys_posix.query_langinfo "").Netsys_posix.nl_CODESET in Some(encoding_of_string codeset) with | _ -> None ) (* Internal conversion interface: * * let (n_char, n_byte, enc') = read_XXX slice_char slice_blen s_in p_in l_in: * * - Scans the bytes from position p_in until the slice is decoded, but at * most until the last position p_in+l_in-1 of the input string s_in, and * decodes the character for the selected encoding. * - "slice_char" is a preallocated array of ints storing the code points * of the characters. It is allowed that "slice_char" is only partially * filled with characters. In this case, there must be a -1 after the * last valid code point. * - "slice_blen" is another "int array" with the same size as "slice_char". * It contains the byte length of every character. It is initialized with * a sequence of ones, so single-byte readers don't have to worry about * this array. * - Returns: * * n_char: the number of decoded characters * * n_byte: the number of scanned bytes ( <= l_in ) * * enc': the new encoding * - In the case of multi-byte encodings it is possible that * the last byte to read at position p_in+l_in-1 is the beginning of * a character. This character is excluded from being decoded. * - Errors: If an invalid byte sequence is found, the exception * Malformed_code_read(_,_,_) is raised. The exception returns the * triple (n_char, n_byte, enc') describing how much could be read * before the reader ran into the bad sequence. slice_char and slice_blen * are only partially initialized, with a (-1) at the end of slice_char. * * let (n_char, n_byte) = * write_XXX slice_char slice_pos slice_length s_out p_out l_out subst * * - Writes the characters found in slice_char to s_out. Only the elements * from slice_pos to slice_pos + slice_length -1 are written. The resulting * bytes are written to s_out from byte position p_out to p_out+l_out-1. * - There must not be a -1 (EOF mark) in the first slice_length characters * of slice_char. * - Only whole characters must be written. * - For code points p that cannot be represented in the output * encoding, the function subst is called. The function must return * the (already encoded) string to substitute. This must be a small string. * - Of course, p >= 0. As special case, p >= 0x110000 may be used to force * that subst is called (it is assumed that max_int can be never * represented). * - Returns: * * n_char: the number of processed characters * * n_byte: the number of written bytes ( <= l_in ) * * let (n_char, n_byte) = * back_XXX s_in range_in range_in_len p_in n_char: * * - The substring of s_in beginning at range_in and with length * range_in_len is considered as the valid range * - The cursor is at byte position p_in and goes n_char characters back * - The routine returns: * * n_char: the characters the cursor was actually moved backwards * * n_byte: the bytes the cursor was actually moved backwards * - The validity of the input encoding needs not to be checked *) exception Malformed_code_read of (int * int * encoding);; (* not exported! *) Callback.register_exception "Netconversion.Malformed_code_read" (Malformed_code_read(0,0,`Enc_empty));; (* Needed by netaccel_c.c *) (* UNSAFE_OPT: A number of functions have been optimized by using * unsafe features of O'Caml (unsafe_get, unsafe_set, unsafe_chr). * These functions have been checked very carefully, and there are * a lot of comments arguing about the correctness of the array * and string accesses. *) type poly_reader = { read : 's . 's Netstring_tstring.tstring_ops -> int array -> int array -> 's -> int -> int -> (int * int * encoding) } let read_iso88591 maxcode enc = (* UNSAFE_OPT *) let read ops slice_char slice_blen s_in p_in l_in = let open Netstring_tstring in assert(Array.length slice_char = Array.length slice_blen); assert(p_in >= 0 && p_in + l_in <= ops.length s_in && l_in >= 0); let m = min l_in (Array.length slice_char) in let m3 = m/3 in for k3 = 0 to m3-1 do let k = 3*k3 in (* let ch = Char.code s_in.[ p_in + k ] in *) let chars = ops.unsafe_get3 s_in (p_in + k) in let c0 = chars lsr 16 in let c1 = (chars lsr 8) land 0xff in let c2 = chars land 0xff in if c0 > maxcode then ( slice_char.(k) <- (-1); raise(Malformed_code_read(k,k,enc)) ); Array.unsafe_set slice_char k c0; if c1 > maxcode then ( slice_char.(k+1) <- (-1); raise(Malformed_code_read(k+1,k+1,enc)) ); Array.unsafe_set slice_char (k+1) c1; if c2 > maxcode then ( slice_char.(k+2) <- (-1); raise(Malformed_code_read(k+2,k+2,enc)) ); Array.unsafe_set slice_char (k+2) c2; done; for k = 3*m3 to m-1 do let c0 = Char.code (ops.unsafe_get s_in (p_in + k)) in if c0 > maxcode then ( slice_char.(k) <- (-1); raise(Malformed_code_read(k,k,enc)) ); Array.unsafe_set slice_char k c0; done; if m < Array.length slice_char then ( slice_char.(m) <- (-1); ); (m,m,enc) in { read } ;; let read_iso88591_ref = ref read_iso88591;; let get_8bit_to_unicode_map enc = let cs = match required_charsets enc with [ cs ] -> cs | _ -> failwith "get_8bit_to_unicode_map" in let to_unicode = Netmappings.get_to_unicode (internal_name cs) in assert(Array.length to_unicode = 256); to_unicode ;; let read_8bit enc = let m_to_unicode = get_8bit_to_unicode_map enc in (* the 256-byte array mapping the character set to unicode *) let read ops slice_char slice_blen s_in p_in l_in = (* UNSAFE_OPT *) let open Netstring_tstring in assert(Array.length slice_char = Array.length slice_blen); assert(p_in >= 0 && p_in + l_in <= ops.length s_in && l_in >= 0); let m = min l_in (Array.length slice_char) in let m3 = m/3 in for k3 = 0 to m3-1 do let k = 3*k3 in let chars = ops.unsafe_get3 s_in k in let c0 = chars lsr 16 in let c1 = (chars lsr 8) land 0xff in let c2 = chars land 0xff in let c0_uni = Array.unsafe_get m_to_unicode c0 in if c0_uni < 0 then ( slice_char.(k) <- (-1); raise(Malformed_code_read(k,k,enc)); ); Array.unsafe_set slice_char k c0_uni; let c1_uni = Array.unsafe_get m_to_unicode c1 in if c1_uni < 0 then ( slice_char.(k+1) <- (-1); raise(Malformed_code_read(k+1,k+1,enc)); ); Array.unsafe_set slice_char (k+1) c1_uni; let c2_uni = Array.unsafe_get m_to_unicode c2 in if c2_uni < 0 then ( slice_char.(k+2) <- (-1); raise(Malformed_code_read(k+2,k+2,enc)); ); Array.unsafe_set slice_char (k+2) c2_uni; done; for k = 3*m3 to m-1 do let c0 = Char.code (ops.get s_in k) in let c0_uni = Array.unsafe_get m_to_unicode c0 in if c0_uni < 0 then ( slice_char.(k) <- (-1); raise(Malformed_code_read(k,k,enc)); ); Array.unsafe_set slice_char k c0_uni; done; if m < Array.length slice_char then ( slice_char.(m) <- (-1); ); (m,m,enc) in { read } ;; let read_utf8 is_java = (* UNSAFE_OPT *) let read ops slice_char slice_blen s_in p_in l_in = let open Netstring_tstring in assert(Array.length slice_char = Array.length slice_blen); assert(p_in >= 0 && p_in + l_in <= ops.length s_in && l_in >= 0); (* k: counts the bytes * n: counts the characters *) let p = ref p_in in let p_max = p_in + l_in in let n = ref 0 in let n_ret = ref (-1) in let malformed_code() = slice_char.( !n ) <- (-1); raise(Malformed_code_read(!n, !p - p_in, `Enc_utf8)); in let slice_length = Array.length slice_char in while !p < p_max && !n < slice_length do let k_inc = (* length of the character in bytes; 0 means: stop *) (* We know: * (1) p_in >= 0 ==> !p >= 0 * (2) !p < p_max = p_in + l_in <= String.length s_in * ==> unsafe get ok *) (* match s_in.[k_in + k] with *) match ops.unsafe_get s_in !p with '\000' -> if is_java then malformed_code(); (* slice_char.(n) <- 0; *) Array.unsafe_set slice_char !n 0; (* ok *) 1 | ('\001'..'\127' as x) -> (* slice_char.(n) <- Char.code x; *) Array.unsafe_set slice_char !n (Char.code x); (* ok *) 1 | ('\128'..'\223' as x) -> if !p+1 >= p_max then 0 else begin (* ==> !p+1 < p_max = p_in + l_in <= String.length s_in * ==> unsafe get ok *) let n1 = Char.code x in let n2 = (* Char.code (s_in.[!p + 1]) *) Char.code(ops.unsafe_get s_in (!p + 1)) in if is_java && (n1 = 0x80 && n2 = 0xc0) then begin (* slice_char.(n) <- 0; *) Array.unsafe_set slice_char !n 0; (* ok *) 2 end else begin if n2 < 128 || n2 > 191 then malformed_code(); let p = ((n1 land 0b11111) lsl 6) lor (n2 land 0b111111) in if p < 128 then malformed_code(); (* slice_char.(n) <- p; *) Array.unsafe_set slice_char !n p; (* ok *) 2 end end | ('\224'..'\239' as x) -> if !p + 2 >= p_max then 0 else begin (* ==> !p+2 < p_max = p_in + l_in <= String.length s_in * ==> unsafe get ok *) let n1 = Char.code x in let n2 = (* Char.code (s_in.[!p + 1]) *) Char.code(ops.unsafe_get s_in (!p + 1)) in let n3 = (* Char.code (s_in.[!p + 2]) *) Char.code(ops.unsafe_get s_in (!p + 2)) in if n2 < 128 || n2 > 191 then malformed_code(); if n3 < 128 || n3 > 191 then malformed_code(); let p = ((n1 land 0b1111) lsl 12) lor ((n2 land 0b111111) lsl 6) lor (n3 land 0b111111) in if p < 0x800 then malformed_code(); if (p >= 0xd800 && p < 0xe000) then (* Surrogate pairs are not supported in UTF-8 *) malformed_code(); if (p >= 0xfffe && p <= 0xffff) then malformed_code(); (* slice_char.(n) <- p; *) Array.unsafe_set slice_char !n p; (* ok *) 3 end | ('\240'..'\247' as x) -> if !p + 3 >= p_max then 0 else begin (* ==> !p+3 < p_max = p_in + l_in <= String.length s_in * ==> unsafe get ok *) let n1 = Char.code x in let chars = ops.unsafe_get3 s_in (!p + 1) in let n2 = chars lsr 16 in let n3 = (chars lsr 8) land 0xff in let n4 = chars land 0xff in if n2 < 128 || n2 > 191 then malformed_code(); if n3 < 128 || n3 > 191 then malformed_code(); if n4 < 128 || n4 > 191 then malformed_code(); let p = ((n1 land 0b111) lsl 18) lor ((n2 land 0b111111) lsl 12) lor ((n3 land 0b111111) lsl 6) lor (n4 land 0b111111) in if p < 0x10000 then malformed_code(); if p >= 0x110000 then (* These code points are not supported. *) malformed_code(); (* slice_char.(n) <- p; *) Array.unsafe_set slice_char !n p; (* ok *) 4 end | _ -> (* Outside the valid range of XML characters *) malformed_code(); in (* If k_inc = 0, the character was partially outside the processed * range of the string, and could not be decoded. *) if k_inc > 0 then begin (* We know: * (1) n >= 0, because n starts with 0 and is only increased * (2) n < Array.length slice_char = Array.length slice_blen * ==> unsafe set ok *) (* slice_blen.(n) <- k_inc; *) Array.unsafe_set slice_blen !n k_inc; (* next iteration: *) p := !p + k_inc; incr n; end else begin (* Stop loop: *) n_ret := !n; n := slice_length; end done; if (!n_ret = (-1)) then n_ret := !n; if !n_ret < slice_length then ( (* EOF marker *) slice_char.(!n_ret) <- (-1); ); (!n_ret,!p-p_in,`Enc_utf8) in { read } ;; let read_utf8_ref = ref read_utf8;; let have_utf8_bom ops s p = let open Netstring_tstring in let c0 = ops.get s (p + 0) in let c1 = ops.get s (p + 1) in let c2 = ops.get s (p + 2) in c0 = '\xEF' && c1 = '\xBB' && c2 = '\xBF' let read_utf8_opt_bom expose_bom = let read ops slice_char slice_blen s_in p_in l_in = let open Netstring_tstring in assert(Array.length slice_char = Array.length slice_blen); assert(p_in >= 0 && p_in + l_in <= ops.length s_in && l_in >= 0); (* Expect a BOM at the beginning of the text *) if l_in >= 3 then ( if have_utf8_bom ops s_in p_in then ( let p_in1, l_in1 = if expose_bom then p_in, l_in else p_in+3, l_in-3 in let (n_ret, p_ret, enc) = (!read_utf8_ref false).read ops slice_char slice_blen s_in p_in1 l_in1 in let p_ret1 = if expose_bom then p_ret else p_ret+3 in if expose_bom && n_ret >= 1 then slice_char.(0) <- (-3); (n_ret, p_ret1, enc) ) else (!read_utf8_ref false).read ops slice_char slice_blen s_in p_in l_in ) else ( let bom_possible = l_in=0 || (l_in=1 && ops.get s_in 0 = '\xEF') || (l_in=2 && ops.get s_in 0 = '\xEF' && ops.get s_in 1 = '\xBB') in if bom_possible then (0, 0, `Enc_utf8_opt_bom) else (!read_utf8_ref false).read ops slice_char slice_blen s_in p_in l_in ) in { read } ;; let surrogate_offset = 0x10000 - (0xD800 lsl 10) - 0xDC00;; let read_utf16_lebe lo hi n_start enc = (* lo=0, hi=1: little endian * lo=1, hi=0: big endian * n_start: First cell in slice to use *) let read ops slice_char slice_blen s_in p_in l_in = let open Netstring_tstring in assert(Array.length slice_char = Array.length slice_blen); assert(p_in >= 0 && p_in + l_in <= ops.length s_in && l_in >= 0); let malformed_code k n = slice_char.(n) <- (-1); raise(Malformed_code_read(n,k,enc)) in (* k: counts the bytes * n: counts the characters *) let rec put_loop k n = if k+1 < l_in && n < Array.length slice_char then begin let p = (Char.code (ops.get s_in (p_in + k + lo))) lor ((Char.code (ops.get s_in (p_in + k + hi))) lsl 8) in if p >= 0xd800 && p < 0xe000 then begin (* This is a surrogate pair. *) if k+3 < l_in then begin if p <= 0xdbff then begin let q = (Char.code (ops.get s_in (p_in + k + 2 + lo))) lor ((Char.code (ops.get s_in (p_in + k + 2 + hi))) lsl 8) in if q < 0xdc00 || q > 0xdfff then malformed_code k n; let eff_p = (p lsl 10) + q + surrogate_offset in slice_char.(n) <- eff_p; slice_blen.(n) <- 4; put_loop (k+4) (n+1) end else (* Malformed pair: *) malformed_code k n; end else (n,k) end else (* Normal 2-byte character *) if p = 0xfffe then (* Wrong byte order mark: It is illegal here *) malformed_code k n else begin (* A regular code point *) slice_char.(n) <- p; slice_blen.(n) <- 2; put_loop (k+2) (n+1) end end else (n,k) in let (n,k) = put_loop 0 n_start in if n < Array.length slice_char then ( (* EOF marker *) slice_char.(n) <- (-1); ); (n,k,enc) in { read } ;; let get_endianess ops s_in p_in = let open Netstring_tstring in let c0 = ops.get s_in (p_in + 0) in let c1 = ops.get s_in (p_in + 1) in if c0 = '\254' && c1 = '\255' then `Big_endian else if c0 = '\255' && c1 = '\254' then `Little_endian else `No_BOM ;; (* expose_bom: when true, the BOM is considered as a character and * put as value (-3) into slice_char *) let read_utf16 expose_bom = let read ops slice_char slice_blen s_in p_in l_in = let open Netstring_tstring in assert(Array.length slice_char = Array.length slice_blen); assert(p_in >= 0 && p_in + l_in <= ops.length s_in && l_in >= 0); (* Expect a BOM at the beginning of the text *) if l_in >= 2 then begin if expose_bom then ( slice_char.(0) <- (-3); slice_blen.(0) <- 0; (* Later corrected *) ); match get_endianess ops s_in p_in with `Big_endian -> let n_start = if expose_bom then 1 else 0 in let (n, k, enc') = (read_utf16_lebe 1 0 n_start `Enc_utf16_be).read ops slice_char slice_blen s_in (p_in+2) (l_in-2) in if n > 0 then slice_blen.(0) <- slice_blen.(0) + 2; (n, k+2, enc') | `Little_endian -> let n_start = if expose_bom then 1 else 0 in let (n, k, enc') = (read_utf16_lebe 0 1 n_start `Enc_utf16_le).read ops slice_char slice_blen s_in (p_in+2) (l_in-2) in if n > 0 then slice_blen.(0) <- slice_blen.(0) + 2; (n, k+2, enc') | `No_BOM -> (* byte order mark missing *) slice_char.(0) <- (-1); raise(Malformed_code_read(0,0,`Enc_utf16)) end else ( slice_char.(0) <- (-1); (0, 0, `Enc_utf16) ) in { read } ;; let read_utf32_lebe little n_start enc = (* little: whether little endian * n_start: First cell in slice to use *) let read ops slice_char slice_blen s_in p_in l_in = let open Netstring_tstring in assert(Array.length slice_char = Array.length slice_blen); assert(p_in >= 0 && p_in + l_in <= ops.length s_in && l_in >= 0); let malformed_code k n = slice_char.(n) <- (-1); raise(Malformed_code_read(n,k,enc)) in let b0 = if little then 0 else 3 in let b1 = if little then 1 else 2 in let b2 = if little then 2 else 1 in let b3 = if little then 3 else 0 in (* k: counts the bytes * n: counts the characters *) let rec put_loop k n = if k+3 < l_in && n < Array.length slice_char then begin let p3 = Char.code (ops.get s_in (p_in + k + b3)) in if p3 <> 0 then malformed_code k n; let p = (Char.code (ops.get s_in (p_in + k + b0))) lor ((Char.code (ops.get s_in (p_in + k + b1))) lsl 8) lor ((Char.code (ops.get s_in (p_in + k + b2))) lsl 16) in if (p >= 0xD800 && p <= 0xDFFF) || p >= 0x10FFFF then malformed_code k n; if p = 0xfffe then (* Wrong byte order mark: It is illegal here *) malformed_code k n; slice_char.(n) <- p; slice_blen.(n) <- 4; put_loop (k+4) (n+1) end else (n,k) in let (n,k) = put_loop 0 n_start in if n < Array.length slice_char then ( (* EOF marker *) slice_char.(n) <- (-1); ); (n,k,enc) in { read } ;; let get_endianess32 ops s_in p_in = let open Netstring_tstring in let c0 = ops.get s_in (p_in + 0) in let c1 = ops.get s_in (p_in + 1) in let c2 = ops.get s_in (p_in + 2) in let c3 = ops.get s_in (p_in + 3) in if c0 = '\000' && c1 = '\000' && c2 = '\254' && c3 = '\255' then `Big_endian else if c0 = '\255' && c1 = '\254' && c2 = '\000' && c3 = '\000' then `Little_endian else `No_BOM ;; let read_utf32 expose_bom = let read ops slice_char slice_blen s_in p_in l_in = let open Netstring_tstring in assert(Array.length slice_char = Array.length slice_blen); assert(p_in >= 0 && p_in + l_in <= ops.length s_in && l_in >= 0); (* Expect a BOM at the beginning of the text *) if l_in >= 4 then begin if expose_bom then ( slice_char.(0) <- (-3); slice_blen.(0) <- 0; (* Later corrected *) ); match get_endianess32 ops s_in p_in with `Big_endian -> let n_start = if expose_bom then 1 else 0 in let (n, k, enc') = (read_utf32_lebe false n_start `Enc_utf32_be).read ops slice_char slice_blen s_in (p_in+4) (l_in-4) in if n > 0 then slice_blen.(0) <- slice_blen.(0) + 4; (n, k+4, enc') | `Little_endian -> let n_start = if expose_bom then 1 else 0 in let (n, k, enc') = (read_utf32_lebe true n_start `Enc_utf32_le).read ops slice_char slice_blen s_in (p_in+4) (l_in-4) in if n > 0 then slice_blen.(0) <- slice_blen.(0) + 4; (n, k+4, enc') | `No_BOM -> (* byte order mark missing *) slice_char.(0) <- (-1); raise(Malformed_code_read(0,0,`Enc_utf32)) end else ( slice_char.(0) <- (-1); (0, 0, `Enc_utf32) ) in { read } ;; let read_euc len1 len2 len3 map1 map2 map3 enc = (* Code set 0 is US-ASCII. * Code sets 1, 2, 3 may be anything. lenX = 0: code set is not supported. * lenX is either 0, 1, or 2. *) (* UNSAFE_OPT *) let open Netstring_tstring in assert(len1 >= 0 && len1 <= 2); assert(len2 >= 0 && len2 <= 2); assert(len3 >= 0 && len3 <= 2); let read ops slice_char slice_blen s_in p_in l_in = assert(Array.length slice_char = Array.length slice_blen); assert(p_in >= 0 && p_in + l_in <= ops.length s_in && l_in >= 0); (* k: counts the bytes * n: counts the characters *) let p = ref p_in in let p_max = p_in + l_in in let n = ref 0 in let n_ret = ref (-1) in let malformed_code() = slice_char.( !n ) <- (-1); raise(Malformed_code_read(!n, !p - p_in, enc)); in let slice_length = Array.length slice_char in while !p < p_max && !n < slice_length do let k_inc = (* length of the character in bytes; 0 means: stop *) (* We know: * (1) p_in >= 0 ==> !p >= 0 * (2) !p < p_max = p_in + l_in <= String.length s_in * ==> unsafe get ok *) (* match s_in.[k_in + k] with *) match ops.unsafe_get s_in !p with '\000'..'\127' as x -> (* US-ASCII *) Array.unsafe_set slice_char !n (Char.code x); (* ok *) 1 | '\142' -> (* Code set 2 *) if len2 = 0 then malformed_code(); if !p+len2 >= p_max then 0 else begin let x1 = Char.code (ops.get s_in (!p + 1)) in let x2 = if len2=1 then 256 else Char.code (ops.get s_in (!p + 2)) in if x1 < 160 || x2 < 160 then malformed_code(); let uni = map2 x1 x2 in Array.unsafe_set slice_char !n uni; (* ok *) len2+1 end | '\143' -> (* Code set 3 *) if len3 = 0 then malformed_code(); if !p+len3 >= p_max then 0 else begin let x1 = Char.code (ops.get s_in (!p + 1)) in let x2 = if len3=1 then 256 else Char.code (ops.get s_in (!p + 2)) in if x1 < 160 || x2 < 160 then malformed_code(); let uni = map3 x1 x2 in Array.unsafe_set slice_char !n uni; (* ok *) len3+1 end | '\160'..'\255' as x1_code -> (* Code set 1 *) if !p+len1 > p_max then 0 else begin let x1 = Char.code x1_code in let x2 = if len1=1 then 256 else Char.code (ops.get s_in (!p + 1)) in if x2 < 160 then malformed_code(); let uni = map1 x1 x2 in Array.unsafe_set slice_char !n uni; (* ok *) len1 end | _ -> (* illegal *) malformed_code() in (* If k_inc = 0, the character was partially outside the processed * range of the string, and could not be decoded. *) if k_inc > 0 then begin (* We know: * (1) n >= 0, because n starts with 0 and is only increased * (2) n < Array.length slice_char = Array.length slice_blen * ==> unsafe set ok *) (* slice_blen.(n) <- k_inc; *) Array.unsafe_set slice_blen !n k_inc; (* next iteration: *) p := !p + k_inc; incr n; end else begin (* Stop loop: *) n_ret := !n; n := slice_length; end done; if (!n_ret = (-1)) then n_ret := !n; if !n_ret < slice_length then ( (* EOF marker *) slice_char.(!n_ret) <- (-1); ); (!n_ret,!p-p_in,enc) in { read } ;; let read_eucjp () = let jis0201 = Netmappings.get_to_unicode "jis0201" in let jis0208 = Netmappings.get_to_unicode "jis0208" in let jis0212 = lazy (Netmappings.get_to_unicode "jis0212") in (* seldom *) let map1 x1 x2 = jis0208.( (x1-160) * 96 + x2 - 160 ) in let map2 x1 _ = jis0201.( x1 ) in let map3 x1 x2 = (Lazy.force jis0212).( (x1-160) * 96 + x2 - 160 ) in read_euc 2 1 2 map1 map2 map3 `Enc_eucjp ;; let read_euckr () = let ks1001 = Netmappings.get_to_unicode "ks1001" in let map x1 x2 = ks1001.( (x1-160) * 96 + x2 - 160 ) in read_euc 2 0 0 map map map `Enc_euckr ;; let read_subset inner_read def = let read ops slice_char slice_blen s_in p_in l_in = let open Netstring_tstring in assert(Array.length slice_char = Array.length slice_blen); assert(p_in >= 0 && p_in + l_in <= ops.length s_in && l_in >= 0); let (n,k,enc') = inner_read.read ops slice_char slice_blen s_in p_in l_in in (* check codepoints: *) for j = 0 to n-1 do if not(def(slice_char.(j))) then ( (* raise Malformed_code_read... *) (* to get enc'' read again: *) let slice_char' = Array.make j (-1) in let slice_blen' = Array.make j 1 in let (n', k', enc'') = try inner_read.read ops slice_char' slice_blen' s_in p_in l_in with Malformed_code_read(_,_,_) -> assert false in assert(n' = j); int_blit slice_char' 0 slice_char 0 j; int_blit slice_blen' 0 slice_blen 0 j; slice_char.(j) <- (-1); raise (Malformed_code_read(j, k', enc'')) ); done; (n,k,enc') in { read } ;; (* * let (n_char, b_byte) = * write_XXX slice_char slice_length s_out p_out l_out subst *) let write_iso88591 maxcode slice_char slice_pos slice_length s_out p_out l_out subst = (* UNSAFE_OPT *) (* Use maxcode=255 for ISO-8859-1, and maxcode=127 for US-ASCII, * and maxcode=(-1) for `Enc_empty. *) assert(p_out >= 0 && p_out + l_out <= Bytes.length s_out && l_out >= 0); assert(slice_pos >= 0 && slice_pos+slice_length <= Array.length slice_char); assert(maxcode <= 255); let n = ref slice_pos in (* index of slice *) let n_ret = ref (-1) in (* returned number of characters *) let n_max = slice_pos + slice_length in let p = ref p_out in (* current output position *) let p_max = p_out + l_out in (* maximum output position *) while ( !n < n_max ) && ( !p < p_max ) do (* We know: * (1) !n >= 0, because it starts with 0 and is only increased * (2) !n < n_max = slice_pos + slice_length <= Array.length slice_char * ==> unsafe get ok *) let ch = Array.unsafe_get slice_char !n in if ch >= 0 && ch <= maxcode then begin (* Because !p < p_max: * !p < p_max = p_out + l_out <= String.length s_out * Furthermore, p_out >= 0, !p >= 0. * ==> unsafe set ok *) (* s_out.[ !p ] <- Char.chr ch; *) Bytes.unsafe_set s_out !p (Char.unsafe_chr ch); incr n; incr p; end else begin assert(ch >= 0); let replacement = subst ch in let l_repl = String.length replacement in if l_repl > multibyte_limit then failwith "Netconversion.write_iso88591: Substitution string too long"; if !p + l_repl <= p_max then begin (* Enough space to store 'replacement': *) Bytes.blit_string replacement 0 s_out !p l_repl; p := !p + l_repl; incr n end else begin (* Exit whole conversion *) n_ret := !n; n := n_max; end end done; if !n_ret >= 0 then (!n_ret - slice_pos, !p - p_out) else (!n - slice_pos, !p - p_out) ;; let get_8bit_from_unicode_map enc = let cs = match required_charsets enc with [ cs ] -> cs | _ -> failwith "get_8bit_from_unicode_map" in let from_unicode = Netmappings.get_from_unicode (internal_name cs) in assert(Array.length from_unicode = 256); from_unicode ;; let write_8bit enc = (* UNSAFE_OPT *) let m_from_unicode = get_8bit_from_unicode_map enc in let m_mask = Array.length m_from_unicode - 1 in fun slice_char slice_pos slice_length s_out p_out l_out subst -> assert(p_out >= 0 && p_out + l_out <= Bytes.length s_out && l_out >= 0); assert(slice_pos >= 0 && slice_pos+slice_length <= Array.length slice_char); let n = ref slice_pos in (* index of slice *) let n_max = slice_pos + slice_length in let k = ref 0 in (* written bytes *) let n_ret = ref (-1) in (* returned number of characters *) while ( !n < n_max ) && ( !k < l_out ) do (* We know: * (1) !n >= 0, because it starts with 0 and is only increased * (2) !n < n_max = slice_pos + slice_length <= Array.length slice * ==> unsafe get ok *) let p = (* slice_char.( !n ) *) Array.unsafe_get slice_char !n in let p' = match Array.unsafe_get m_from_unicode (p land m_mask) with Netmappings.U_nil -> -1 | Netmappings.U_single (p0,q0) -> if p0 = p then q0 else -1 | Netmappings.U_double (p0,q0,p1,q1) -> if p0 = p then q0 else if p1 = p then q1 else -1 | Netmappings.U_array pq -> let r = ref (-1) in let h = ref 0 in while !r < 0 && !h < Array.length pq do if pq.( !h ) = p then r := pq.( !h+1 ) else h := !h + 2 done; !r in (* If p=-1 ==> p'=-1, because -1 is never mapped to any code point *) if p' < 0 then begin if p < 0 then assert false (* EOF mark found *) else begin let replacement = subst p in let l_repl = String.length replacement in if l_repl > multibyte_limit then failwith "Netconversion.write_8bit: Substitution string too long"; if !k + l_repl <= l_out then begin (* Enough space to store 'replacement': *) Bytes.blit_string replacement 0 s_out (p_out + !k) l_repl; k := !k + l_repl; incr n end else begin (* Exit whole conversion *) n_ret := !n; n := n_max; end end end else begin (* Because !k < l_out: * p_out + !k < p_out + l_out <= String.length s_out * Furthermore, p_out >= 0, !k >= 0. * ==> unsafe set ok *) (* s_out.[ p_out + !k ] <- Char.chr p'; *) Bytes.unsafe_set s_out (p_out + !k) (Char.unsafe_chr(p' land 0xff)); incr n; incr k end; done; if !n_ret >= 0 then (!n_ret - slice_pos, !k) else (!n - slice_pos, !k) ;; let write_utf8 is_java slice_char slice_pos slice_length s_out p_out l_out subst = (* UNSAFE_OPT *) assert(p_out >= 0 && p_out + l_out <= Bytes.length s_out && l_out >= 0); assert(slice_pos >= 0 && slice_pos+slice_length <= Array.length slice_char); let n = ref slice_pos in (* index of slice *) let n_max = slice_pos + slice_length in let k = ref 0 in (* written bytes *) let n_ret = ref (-1) in (* returned number of characters *) while ( !n < n_max ) do (* We know: * (1) !n >= 0, because it starts with 0 and is only increased * (2) !n < n_max = slice_pos + slice_length <= Array.length slice * ==> unsafe get ok *) let p = (* slice.( !n ) *) Array.unsafe_get slice_char !n in let index = p_out + !k in let k_inc = (* k_inc: how many bytes are written. (-1) means: stop *) if p <= 127 && (not is_java || p <> 0) then begin if p < 0 then assert false; (* EOF mark *) if !k < l_out then begin (* (1) index = p_out + !k < p_out + l_out <= * String.length s_out * (2) p_out, !n >= 0 * ==> unsafe set ok * * 0 <= p <= 127 ==> unsafe_chr ok *) (* s_out.[index] <- Char.chr p; *) Bytes.unsafe_set s_out index (Char.unsafe_chr p); 1 end else (-1) end else if p <= 0x7ff then begin if !k + 1 < l_out then begin (* (1) index+1 = p_out + !k + 1 < p_out + l_out <= * String.length s_out * (2) p_out, !k >= 0 * ==> unsafe set ok * * p <= 0x7ff ==> p lsr 6 <= 0x1f * ==> 0xc0 lor (p lsr 6) <= df * p land 0x3f <= 0x3f ==> 0x80 lor (p land 0x3f) <= 0xbf * ==> unsafe_chr ok *) (* s_out.[index] <- Char.chr (0xc0 lor (p lsr 6)); *) (* s_out.[index + 1] <- Char.chr (0x80 lor (p land 0x3f)); *) Bytes.unsafe_set s_out index (Char.unsafe_chr (0xc0 lor (p lsr 6))); Bytes.unsafe_set s_out (index+1) (Char.unsafe_chr (0x80 lor (p land 0x3f))); 2 end else (-1) end else if p <= 0xffff then begin (* Refuse writing surrogate pairs, and fffe, ffff *) if (p >= 0xd800 && p < 0xe000) || (p >= 0xfffe) then failwith "Netconversion.write_utf8"; if !k + 2 < l_out then begin (* (1) index+2 = p_out + !k + 2 < p_out + l_out <= * String.length s_out * (2) p_out, !k >= 0 * ==> unsafe set ok * * Well, and it can be proven that unsafe_chr is ok, too... *) (* s_out.[index] <- Char.chr (0xe0 lor (p lsr 12)); *) (* s_out.[index + 1] <- Char.chr (0x80 lor ((p lsr 6) land 0x3f)); *) (* s_out.[index + 2] <- Char.chr (0x80 lor (p land 0x3f)); *) Bytes.unsafe_set s_out index (Char.unsafe_chr (0xe0 lor (p lsr 12))); Bytes.unsafe_set s_out (index+1) (Char.unsafe_chr (0x80 lor ((p lsr 6) land 0x3f))); Bytes.unsafe_set s_out (index+2) (Char.unsafe_chr (0x80 lor (p land 0x3f))); 3 end else (-1) end else if p <= 0x10ffff then begin if !k + 3 < l_out then begin (* No such characters are defined... *) Bytes.set s_out index (Char.chr (0xf0 lor (p lsr 18))); Bytes.set s_out (index + 1) (Char.chr (0x80 lor ((p lsr 12) land 0x3f))); Bytes.set s_out (index + 2) (Char.chr (0x80 lor ((p lsr 6) land 0x3f))); Bytes.set s_out (index + 3) (Char.chr (0x80 lor (p land 0x3f))); 4 end else (-1) end else begin (* Higher code points are not possible in XML; call subst *) let replacement = subst p in let l_repl = String.length replacement in if l_repl > multibyte_limit then failwith "Netconversion.write_utf8: Substitution string too long"; if !k + l_repl <= l_out then begin (* Enough space to store 'replacement': *) Bytes.blit_string replacement 0 s_out (p_out + !k) l_repl; l_repl (* may be 0! *) end else (-1) (* Exit whole conversion *) end in if k_inc >= 0 then ( k := !k + k_inc; incr n ) else ( n_ret := !n; n := n_max ); done; if !n_ret >= 0 then (!n_ret - slice_pos, !k) else (!n - slice_pos, !k) ;; let write_utf16_lebe lo hi slice_char slice_pos slice_length s_out p_out l_out subst = (* lo=0, hi=1: little endian * lo=1, hi=0: big endian *) assert(p_out >= 0 && p_out + l_out <= Bytes.length s_out && l_out >= 0); assert(slice_pos >= 0 && slice_pos+slice_length <= Array.length slice_char); let n = ref slice_pos in (* index of slice *) let n_max = slice_pos + slice_length in let k = ref 0 in (* written bytes *) let n_ret = ref (-1) in (* returned number of characters *) while ( !n < n_max ) do let p = slice_char.( !n ) in let index = p_out + !k in let k_inc = if p >= 0xfffe then begin if p <= 0x10ffff then begin if p <= 0xffff then failwith "Netconversion.write_utf16_le"; (* Must be written as surrogate pair *) if !k + 3 < l_out then begin let high = ((p - 0x10000) lsr 10) + 0xd800 in let low = (p land 0x3ff) + 0xdc00 in Bytes.set s_out (index + lo) (Char.chr (high land 0xff)); Bytes.set s_out (index + hi) (Char.chr (high lsr 8)); Bytes.set s_out (index + 2 + lo) (Char.chr (low land 0xff)); Bytes.set s_out (index + 2 + hi) (Char.chr (low lsr 8)); 4 end else (-1) end else begin (* Higher code points are not possible in XML; call subst *) let replacement = subst p in let l_repl = String.length replacement in if l_repl > multibyte_limit then failwith "Netconversion.write_utf16_le: Substitution string too long"; if !k + l_repl <= l_out then begin (* Enough space to store 'replacement': *) Bytes.blit_string replacement 0 s_out (p_out + !k) l_repl; l_repl (* may be 0! *) end else (-1) (* Exit whole conversion *) end end else begin (* 2-byte character *) if !k + 1 < l_out then begin Bytes.set s_out (index + lo) (Char.unsafe_chr (p land 0xff)); Bytes.set s_out (index + hi) (Char.unsafe_chr ((p lsr 8) land 0xff)); 2 end else (-1) end in if k_inc >= 0 then ( k := !k + k_inc; incr n ) else ( n_ret := !n; n := n_max ); done; if !n_ret >= 0 then (!n_ret - slice_pos, !k) else (!n - slice_pos, !k) ;; let write_utf32_lebe little slice_char slice_pos slice_length s_out p_out l_out subst = assert(p_out >= 0 && p_out + l_out <= Bytes.length s_out && l_out >= 0); assert(slice_pos >= 0 && slice_pos+slice_length <= Array.length slice_char); let n = ref slice_pos in (* index of slice *) let n_max = slice_pos + slice_length in let k = ref 0 in (* written bytes *) let n_ret = ref (-1) in (* returned number of characters *) let b0 = if little then 0 else 3 in let b1 = if little then 1 else 2 in let b2 = if little then 2 else 1 in let b3 = if little then 3 else 0 in while ( !n < n_max ) do let p = slice_char.( !n ) in let index = p_out + !k in let k_inc = if p <= 0x10ffff then ( if !k + 3 < l_out then ( Bytes.set s_out (index + b0) (Char.unsafe_chr (p land 0xff)); Bytes.set s_out (index + b1) (Char.unsafe_chr ((p lsr 8) land 0xff)); Bytes.set s_out (index + b2) (Char.unsafe_chr ((p lsr 16) land 0xff)); Bytes.set s_out (index + b3) (Char.unsafe_chr 0); 4 ) else (-1) ) else ( (* Higher code points are not possible in XML; call subst *) let replacement = subst p in let l_repl = String.length replacement in if l_repl > multibyte_limit then failwith "Netconversion.write_utf32: Substitution string too long"; if !k + l_repl <= l_out then begin (* Enough space to store 'replacement': *) Bytes.blit_string replacement 0 s_out (p_out + !k) l_repl; l_repl (* may be 0! *) end else (-1) (* Exit whole conversion *) ) in if k_inc >= 0 then ( k := !k + k_inc; incr n ) else ( n_ret := !n; n := n_max ); done; if !n_ret >= 0 then (!n_ret - slice_pos, !k) else (!n - slice_pos, !k) ;; let write_euc map enc = (* Code set 0 is US-ASCII. * let (set, byte1, byte2) = map unicode: * - set is 1, 2, 3, or 4. 4 means that the code point cannot be mapped. * - byte1 >= 160, <= 255 * - byte2 >= 160, <= 255, or byte2=256 meaning that it is not used *) (* UNSAFE_OPT *) fun slice_char slice_pos slice_length s_out p_out l_out subst -> assert(p_out >= 0 && p_out + l_out <= Bytes.length s_out && l_out >= 0); assert(slice_pos >= 0 && slice_pos+slice_length <= Array.length slice_char); let n = ref slice_pos in (* index of slice *) let n_max = slice_pos + slice_length in let k = ref 0 in (* written bytes *) let n_ret = ref (-1) in (* returned number of characters *) while ( !n < n_max ) do (* We know: * (1) !n >= 0, because it starts with 0 and is only increased * (2) !n < n_max = slice_pos + slice_length <= Array.length slice * ==> unsafe get ok *) let p = (* slice.( !n ) *) Array.unsafe_get slice_char !n in assert (p >= 0); let index = p_out + !k in let (set, b1, b2) = if p <= 127 then (0, p, 256) else map p in let k_inc = (* k_inc: how many bytes are written *) match set with 0 -> if !k < l_out then begin (* s_out.[index] <- Char.chr p; *) Bytes.unsafe_set s_out index (Char.unsafe_chr (b1 land 127)); 1 end else (-1) | 1 -> let bl = if b2 = 256 then 1 else 2 in if !k + bl < l_out then begin assert(b1 >= 160 && b1 <= 255 && b2 >= 160 && b2 <= 256); Bytes.set s_out (index) (Char.chr b1); if b2 <> 256 then Bytes.set s_out (index+1) (Char.chr b2); bl end else (-1) | 2 -> let bl = if b2 = 256 then 2 else 3 in if !k + bl < l_out then begin assert(b1 >= 160 && b1 <= 255 && b2 >= 160 && b2 <= 256); Bytes.set s_out index '\142'; Bytes.set s_out (index+1) (Char.chr b1); if b2 <> 256 then Bytes.set s_out (index+2) (Char.chr b2); bl end else (-1) | 3 -> let bl = if b2 = 256 then 2 else 3 in if !k + bl < l_out then begin assert(b1 >= 160 && b1 <= 255 && b2 >= 160 && b2 <= 256); Bytes.set s_out index '\143'; Bytes.set s_out (index+1) (Char.chr b1); if b2 <> 256 then Bytes.set s_out (index+2) (Char.chr b2); bl end else (-1) | 4 -> let replacement = subst p in let l_repl = String.length replacement in if l_repl > multibyte_limit then failwith "Netconversion.write_euc: Substitution string too long"; if !k + l_repl <= l_out then begin (* Enough space to store 'replacement': *) Bytes.blit_string replacement 0 s_out (p_out + !k) l_repl; l_repl end else (-1) (* Exit whole conversion *) | _ -> assert false in if k_inc >= 0 then ( k := !k + k_inc; incr n ) else ( n_ret := !n; n := n_max ); done; if !n_ret >= 0 then (!n_ret - slice_pos, !k) else (!n - slice_pos, !k) ;; let write_eucjp () = let jis0201 = Netmappings.get_from_unicode "jis0201" in let jis0208 = Netmappings.get_from_unicode "jis0208" in let jis0212 = Netmappings.get_from_unicode "jis0212" in let jis0201_mask = Array.length jis0201 - 1 in let jis0208_mask = Array.length jis0208 - 1 in let jis0212_mask = Array.length jis0212 - 1 in let map p = (* Try in order: jis0208, jis0201, jis0212 *) let map_tbl jistbl jistbl_mask = match jistbl.(p land jistbl_mask) with Netmappings.U_nil -> -1 | Netmappings.U_single (p0,q0) -> if p0 = p then q0 else -1 | Netmappings.U_double (p0,q0,p1,q1) -> if p0 = p then q0 else if p1 = p then q1 else -1 | Netmappings.U_array pq -> let r = ref (-1) in let h = ref 0 in while !r < 0 && !h < Array.length pq do if pq.( !h ) = p then r := pq.( !h+1 ) else h := !h + 2 done; !r in let cp_0208 = map_tbl jis0208 jis0208_mask in if cp_0208 >= 0 then let row = cp_0208 / 96 in let col = cp_0208 - row * 96 in (1, row + 160, col + 160) else let cp_0201 = map_tbl jis0201 jis0201_mask in if cp_0201 >= 128 then (* Ignore especially 0x5c, 0x7e *) (2, cp_0201, 256) else let cp_0212 = map_tbl jis0212 jis0212_mask in if cp_0212 >= 0 then let row = cp_0212 / 96 in let col = cp_0212 - row * 96 in (3, row + 160, col + 160) else (4,256,256) in write_euc map `Enc_eucjp ;; let write_euckr () = let ks1001 = Netmappings.get_from_unicode "ks1001" in let ks1001_mask = Array.length ks1001 - 1 in let map p = let map_tbl kstbl kstbl_mask = match kstbl.(p land kstbl_mask) with Netmappings.U_nil -> -1 | Netmappings.U_single (p0,q0) -> if p0 = p then q0 else -1 | Netmappings.U_double (p0,q0,p1,q1) -> if p0 = p then q0 else if p1 = p then q1 else -1 | Netmappings.U_array pq -> let r = ref (-1) in let h = ref 0 in while !r < 0 && !h < Array.length pq do if pq.( !h ) = p then r := pq.( !h+1 ) else h := !h + 2 done; !r in let cp_1001 = map_tbl ks1001 ks1001_mask in if cp_1001 >= 0 then let row = cp_1001 / 96 in let col = cp_1001 - row * 96 in (1, row + 160, col + 160) else (4,256,256) in write_euc map `Enc_euckr ;; let special_cpoint = 0x110000;; let write_subset inner_writer def slice_char slice_pos slice_length s_out p_out l_out subst = assert(p_out >= 0 && p_out + l_out <= Bytes.length s_out && l_out >= 0); assert(slice_pos >= 0 && slice_pos+slice_length <= Array.length slice_char); (* Force that the subst' function is called for all undefined code * points *) let slice_char' = Array.sub slice_char slice_pos slice_length in for n = 0 to slice_length - 1 do let ch = slice_char'.(n) in if ch >= special_cpoint || not (def ch) then slice_char'.(n) <- special_cpoint + n done; let subst' ch = if ch >= special_cpoint then subst (slice_char.(slice_pos + ch - special_cpoint)) else subst ch in inner_writer slice_char' 0 slice_length s_out p_out l_out subst' ;; let back_8bit ops s_in range_in p_in n_char = let p_rel = p_in - range_in in let n = min p_rel n_char in (n,n) ;; let back_utf8 ops s_in range_in p_in n_char = let open Netstring_tstring in let n = ref 0 in let k = ref 0 in let k_out = ref 0 in while p_in - !k > range_in && !n < n_char do incr k; let ch = Char.code (ops.get s_in (p_in - !k)) in if ch < 0x80 || ( ch >= 0xc0 && ch <=0xfd) then ( incr n; k_out := !k ) done; ( !n, !k_out ) ;; let back_utf16_lebe lo hi ops s_in range_in p_in n_char = (* lo=0, hi=1: little endian * lo=1, hi=0: big endian *) let open Netstring_tstring in let n = ref 0 in let k = ref 0 in let k_out = ref 0 in while p_in - !k > range_in + 1 && !n < n_char do incr k; incr k; let ch = (Char.code (ops.get s_in (p_in - !k + lo))) lor ((Char.code (ops.get s_in (p_in - !k + hi))) lsl 8) in if ch < 0xdc00 || ch >= 0xe000 then ( incr n; k_out := !k ); (* else: ch is the second half of a surrogate pair *) done; ( !n, !k_out ) ;; let back_utf32 ops s_in range_in p_in n_char = let open Netstring_tstring in let p_rel = p_in - range_in in let n = min p_rel (n_char lsl 2) in (n asr 2,n) ;; let back_euc ops s_in range_in p_in n_char = (* Works for 1-byte and 2-byte encodings *) let open Netstring_tstring in let n = ref 0 in let k = ref 0 in let k_out = ref 0 in while p_in - !k > range_in && !n < n_char do incr k; let ch1 = Char.code (ops.get s_in (p_in - !k)) in if ch1 < 0x80 then ( incr n; k_out := !k ) else if p_in - !k > range_in then ( incr k; let ch2 = Char.code (ops.get s_in (p_in - !k)) in (* ch2 < 0x80: wrong, but we do not report errors here *) if ch2 < 0x80 then ( incr n; k_out := !k ) else if ch2 = 142 || ch2 = 143 then ( incr n; k_out := !k ) else if p_in - !k > range_in then ( let ch3 = Char.code (ops.get s_in (p_in - !k - 1)) in if ch3 = 142 || ch3 = 143 then ( incr k; incr n; k_out := !k ) else ( incr n; k_out := !k ) ) else ( (* At the beginning of the string *) incr n; k_out := !k ) ) done; ( !n, !k_out ) ;; let check_unicode p = if p < 0 || (p > 0xd7ff && p < 0xe000) || p = 0xfffe || p = 0xffff || p > 0x10ffff then raise Malformed_code ;; let rec to_unicode cs = match cs with `Set_iso88591 -> (fun p -> if p < 0 || p > 255 then raise Malformed_code; p) | `Set_usascii -> (fun p -> if p < 0 || p > 127 then raise Malformed_code; p) | `Set_unicode -> (fun p -> check_unicode p; p) | _ -> let m_to_uni = Netmappings.get_to_unicode (internal_name cs) in (fun p -> if p < 0 || p >= Array.length m_to_uni then raise Malformed_code; let uni = m_to_uni.(p) in if uni < 0 then raise Malformed_code; uni ) ;; let rec from_unicode cs = match cs with `Set_iso88591 -> (fun p -> check_unicode p; if p > 255 then raise (Cannot_represent p); p) | `Set_usascii -> (fun p -> check_unicode p; if p > 127 then raise (Cannot_represent p); p) | `Set_unicode -> (fun p -> check_unicode p; p) | _ -> let m_from_unicode = Netmappings.get_from_unicode (internal_name cs) in let m_mask = Array.length m_from_unicode - 1 in (fun p -> check_unicode p; let p' = match Array.unsafe_get m_from_unicode (p land m_mask) with Netmappings.U_nil -> -1 | Netmappings.U_single (p0,q0) -> if p0 = p then q0 else -1 | Netmappings.U_double (p0,q0,p1,q1) -> if p0 = p then q0 else if p1 = p then q1 else -1 | Netmappings.U_array pq -> let r = ref (-1) in let h = ref 0 in while !r < 0 && !h < Array.length pq do if pq.( !h ) = p then r := pq.( !h+1 ) else h := !h + 2 done; !r in if p' < 0 then raise(Cannot_represent p); p' ) ;; type encoding1 = [ encoding | `Enc_utf16_bom | `Enc_utf32_bom | `Enc_utf8_bom ] ;; (* `Enc_*_bom considers the BOM as a character with code point -3. * This encoding is only internally used. *) let rec get_reader1 (enc : encoding1) = (* get_reader1 supports the additional internal encodings of * encoding1. get_reader (below) only supports the exported * encodings. *) match enc with `Enc_iso88591 -> !read_iso88591_ref 255 `Enc_iso88591 | `Enc_usascii -> !read_iso88591_ref 127 `Enc_usascii | `Enc_empty -> !read_iso88591_ref (-1) `Enc_empty | `Enc_utf8 -> !read_utf8_ref false | `Enc_java -> !read_utf8_ref true | `Enc_utf8_opt_bom -> read_utf8_opt_bom false | `Enc_utf8_bom -> read_utf8_opt_bom true | `Enc_utf16 -> read_utf16 false | `Enc_utf16_bom -> read_utf16 true | `Enc_utf16_le -> read_utf16_lebe 0 1 0 `Enc_utf16_le | `Enc_utf16_be -> read_utf16_lebe 1 0 0 `Enc_utf16_be | `Enc_utf32 -> read_utf32 false | `Enc_utf32_bom -> read_utf32 true | `Enc_utf32_le -> read_utf32_lebe true 0 `Enc_utf32_le | `Enc_utf32_be -> read_utf32_lebe false 0 `Enc_utf32_be | `Enc_eucjp -> read_eucjp () | `Enc_euckr -> read_euckr () | `Enc_subset(e,def) -> let reader' = get_reader1 (e :> encoding1) in read_subset reader' def | #encoding as e -> read_8bit (e :> encoding) ;; let get_reader = (get_reader1 : encoding1 -> 'a :> encoding -> 'a);; let rec get_writer enc = match enc with `Enc_iso88591 -> write_iso88591 255 | `Enc_usascii -> write_iso88591 127 | `Enc_empty -> write_iso88591 (-1) | `Enc_utf8 -> write_utf8 false | `Enc_java -> write_utf8 true | `Enc_utf16 -> failwith "Netconversion: Cannot output text as `Enc_utf16, use `Enc_utf16_le or `Enc_utf16_be" | `Enc_utf16_le -> write_utf16_lebe 0 1 | `Enc_utf16_be -> write_utf16_lebe 1 0 | `Enc_utf32 -> failwith "Netconversion: Cannot output text as `Enc_utf32, use `Enc_utf32_le or `Enc_utf32_be" | `Enc_utf32_le -> write_utf32_lebe true | `Enc_utf32_be -> write_utf32_lebe false | `Enc_eucjp -> write_eucjp () | `Enc_euckr -> write_euckr () | `Enc_subset(e,def) -> let writer' = get_writer e in write_subset writer' def | _ -> write_8bit enc ;; let rec get_back_fn enc = match enc with | `Enc_utf8 | `Enc_java -> back_utf8 | `Enc_utf16 -> failwith "Netconversion: Cannot go back in text encoded as `Enc_utf16, use `Enc_utf16_le or `Enc_utf16_be" | `Enc_utf16_le -> back_utf16_lebe 0 1 | `Enc_utf16_be -> back_utf16_lebe 1 0 | `Enc_utf32 | `Enc_utf32_le | `Enc_utf32_be -> back_utf32 | `Enc_eucjp -> back_euc | `Enc_euckr -> back_euc | `Enc_subset(e,def) -> get_back_fn e | _ -> back_8bit ;; let recode_poly ~in_ops ~in_enc ~in_buf ~in_pos ~in_len ~out_enc ~out_buf ~out_pos ~out_len ~max_chars ~subst = let open Netstring_tstring in if (in_pos < 0 || in_len < 0 || in_pos + in_len > in_ops.length in_buf || out_pos < 0 || out_len < 0 || out_pos + out_len > Bytes.length out_buf) then invalid_arg "Netconversion.recode"; (* An array with 250 elements can be allocated in the minor heap. *) let slice_length = big_slice in let slice_char = Array.make slice_length (-1) in let slice_blen = Array.make slice_length 1 in let in_k = ref 0 in (* read bytes *) let in_n = ref 0 in (* read characters *) let in_eof = ref (!in_k >= in_len) in let out_k = ref 0 in (* written bytes *) let out_n = ref 0 in (* written characters *) let out_eof = ref (!out_k >= out_len || !out_n >= max_chars) in let rd_enc = ref in_enc in let reader = ref (get_reader in_enc) in let writer = get_writer out_enc in while not !in_eof && not !out_eof do let in_n_inc, in_k_inc, rd_enc' = try !reader.read in_ops slice_char slice_blen in_buf (in_pos + !in_k) (in_len - !in_k) with Malformed_code_read(in_n_inc, in_k_inc, rd_enc') -> if in_n_inc = 0 then raise Malformed_code; (in_n_inc, in_k_inc, rd_enc') in let out_n_inc_max = min in_n_inc (max_chars - !out_n) in (* do not write more than max_chars *) let out_n_inc, out_k_inc = if out_n_inc_max > 0 then writer slice_char 0 out_n_inc_max out_buf (out_pos + !out_k) (out_len - !out_k) subst else (0,0) in let in_n_inc', in_k_inc' = if in_n_inc > out_n_inc then begin (* Not all read characters could be written *) let sum = ref 0 in for j = 0 to out_n_inc - 1 do sum := !sum + slice_blen.(j) done; (out_n_inc, !sum) end else (in_n_inc, in_k_inc) in in_k := !in_k + in_k_inc'; in_n := !in_n + in_n_inc'; out_k := !out_k + out_k_inc; out_n := !out_n + out_n_inc; (* Detect change of input encoding: *) if rd_enc' <> !rd_enc then begin rd_enc := rd_enc'; reader := get_reader rd_enc'; Array.fill slice_blen 0 slice_length 1; end; (* EOF criteria: * - It is possible that !in_k never reaches in_len because there is a * multibyte character at the end that is partially outside the input * range * - For the same reason it is possible that !out_k never reaches out_len * - It is accepted as reader EOF if not even one character can be * scanned * - It is accepted as writer EOF if fewer than in_n_inc characters * could be written *) in_eof := (!in_k >= in_len || in_n_inc = 0); out_eof := (!out_k >= out_len || !out_n >= max_chars || out_n_inc < in_n_inc); done; ( !in_k, !out_k, !rd_enc ) ;; let recode = recode_poly ~in_ops:Netstring_tstring.string_ops let recode_bytes = recode_poly ~in_ops:Netstring_tstring.bytes_ops let recode_tstring ~in_enc ~in_buf ~in_pos ~in_len ~out_enc ~out_buf ~out_pos ~out_len ~max_chars ~subst = let f = { Netstring_tstring.with_fun = (fun in_ops in_buf -> recode_poly ~in_ops ~in_enc ~in_buf ~in_pos ~in_len ~out_enc ~out_buf ~out_pos ~out_len ~max_chars ~subst ) } in Netstring_tstring.with_tstring f in_buf let rec ustring_of_uchar enc = let multi_byte writer n p = let s = Bytes.create n in let _,n_act = writer [|p|] 0 1 s 0 n (fun _ -> raise (Cannot_represent p)) in Bytes.sub_string s 0 n_act in match enc with `Enc_iso88591 -> (fun p -> if p > 255 then raise (Cannot_represent p); String.make 1 (Char.chr p)) | `Enc_usascii -> (fun p ->if p > 127 then raise (Cannot_represent p); String.make 1 (Char.chr p)) | `Enc_utf8 | `Enc_utf8_opt_bom -> multi_byte (write_utf8 false) 4 | `Enc_java -> multi_byte (write_utf8 true) 4 | `Enc_utf16_le -> multi_byte (write_utf16_lebe 0 1) 4 | `Enc_utf16_be -> multi_byte (write_utf16_lebe 1 0) 4 | `Enc_utf16 -> invalid_arg "Netconversion.ustring_of_uchar: UTF-16 not possible" | `Enc_utf32_le -> multi_byte (write_utf32_lebe true) 4 | `Enc_utf32_be -> multi_byte (write_utf32_lebe false) 4 | `Enc_utf32 -> invalid_arg "Netconversion.ustring_of_uchar: UTF-32 not possible" | `Enc_eucjp -> multi_byte (write_eucjp()) 3 | `Enc_euckr -> multi_byte (write_euckr()) 2 | `Enc_subset(e,def) -> (fun p -> if def p then ustring_of_uchar e p else raise (Cannot_represent p)) | _ -> let writer = write_8bit enc in multi_byte writer 1 ;; let makechar enc = let us = ustring_of_uchar enc in (fun p -> try us p with Cannot_represent _ -> raise Not_found) ;; (* The following algorithms assume that there is an upper limit of the length * of a multibyte character. Currently, UTF8 is the encoding with the longest * multibyte characters (6 bytes). * Because of this limit, it is allowed to allocate a buffer that is "large * enough" in order to ensure that at least one character is recoded in every * loop cycle. If the buffer was not large enough, no character would be * processed in a cycle, and the algorithm would hang. *) let convert_poly : type s t . in_ops:s Netstring_tstring.tstring_ops -> out_kind:t Netstring_tstring.tstring_kind -> ?subst:(int -> string) -> in_enc:encoding -> out_enc:encoding -> ?range_pos:int -> ?range_len:int -> s -> t = fun ~in_ops ~out_kind ?(subst = (fun p -> raise (Cannot_represent p))) ~in_enc ~out_enc ?(range_pos=0) ?range_len s -> let open Netstring_tstring in let range_len = match range_len with Some l -> l | None -> in_ops.length s - range_pos in if range_pos < 0 || range_len < 0 || range_pos+range_len > in_ops.length s then invalid_arg "Netconversion.convert"; (* Estimate the size of the output string: * length * 2 is just guessed. It is assumed that this number is usually * too large, and to avoid that too much memory is wasted, the buffer is * limited by 10000. *) let size = ref (max multibyte_limit (min 10000 (range_len * 2))) in let out_buf = ref (Bytes.create !size) in let k_in = ref 0 in let k_out = ref 0 in while !k_in < range_len do let in_len = range_len - !k_in in let out_len = !size - !k_out in assert (out_len >= multibyte_limit); (* space for at least one char *) let k_in_inc, k_out_inc, in_enc' = recode_poly ~in_ops ~in_enc ~in_buf:s ~in_pos:(range_pos + !k_in) ~in_len ~out_enc ~out_buf:(!out_buf) ~out_pos:(!k_out) ~out_len ~max_chars:max_int ~subst in if k_in_inc = 0 then raise Malformed_code; (* Reasons for k_in_inc = 0: * (1) There is not enough space in out_buf to add a single character * (2) in_buf ends with a prefix of a multi-byte character * Because there is always space for at least one character * ( = multibyte_limit ), reason (1) can be excluded. So it must * be (2), and we can raise Malformed_code. *) k_in := !k_in + k_in_inc; k_out := !k_out + k_out_inc; (* double the size of out_buf: *) let size' = min Sys.max_string_length (!size + !size) in if size' < !size + multibyte_limit then failwith "Netconversion.convert: string too long"; let out_buf' = Bytes.create size' in Bytes.blit !out_buf 0 out_buf' 0 !k_out; out_buf := out_buf'; size := size'; done; match out_kind with | Netstring_tstring.String_kind -> Bytes.sub_string !out_buf 0 !k_out | Netstring_tstring.Bytes_kind -> Bytes.sub !out_buf 0 !k_out | Netstring_tstring.Memory_kind -> let m = Bigarray.Array1.create Bigarray.char Bigarray.c_layout !k_out in Netsys_mem.blit_bytes_to_memory !out_buf 0 m 0 !k_out; m ;; let convert ?subst ~in_enc ~out_enc ?range_pos ?range_len s = convert_poly ?subst ~in_ops:Netstring_tstring.string_ops ~out_kind:Netstring_tstring.String_kind ~in_enc ~out_enc ?range_pos ?range_len s let convert_bytes ?subst ~in_enc ~out_enc ?range_pos ?range_len s = convert_poly ?subst ~in_ops:Netstring_tstring.bytes_ops ~out_kind:Netstring_tstring.Bytes_kind ~in_enc ~out_enc ?range_pos ?range_len s let convert_tstring ?subst ~in_enc ~out_enc ~out_kind ?range_pos ?range_len ts = let f = { Netstring_tstring.with_fun = (fun in_ops s -> convert_poly ?subst ~in_ops ~out_kind ~in_enc ~out_enc ?range_pos ?range_len s ) } in Netstring_tstring.with_tstring f ts class conversion_pipe ?(subst = (fun p -> raise (Cannot_represent p))) ~in_enc ~out_enc () = let current_in_enc = ref in_enc in let conv in_netbuf at_eof out_netbuf = if at_eof then (* TODO: avoid the extra allocations *) let s = convert_bytes ~subst ~in_enc:!current_in_enc ~out_enc (Netbuffer.unsafe_buffer in_netbuf) in Netbuffer.add_bytes out_netbuf s else let in_buf = Netbuffer.unsafe_buffer in_netbuf in let in_pos = 0 in let in_len = Netbuffer.length in_netbuf in let n = Netbuffer.add_inplace out_netbuf (fun out_buf out_pos out_len -> let (in_n,out_n,in_enc') = recode_bytes ~in_enc:!current_in_enc ~in_buf ~in_pos ~in_len ~out_enc ~out_buf ~out_pos ~out_len ~max_chars:out_len ~subst in Netbuffer.delete in_netbuf 0 in_n; current_in_enc := in_enc'; out_n ) in if n = 0 && in_len > 0 then begin (* To avoid endless loops, ensure here that there is enough space * in out_netbuf *) ignore(Netbuffer.add_inplace ~len:multibyte_limit out_netbuf (fun _ _ _ -> 0)); end; () in Netchannels.pipe ~conv () ;; (**********************************************************************) (* Cursors *) (**********************************************************************) (* The "read_*" functions are used to scan the string, and to move * the cursor forward. The slice array stores the scanned characters. * If the read call raises Malformed_code, the size of the slice * is decreased to 1, so the exact position can be calculated. *) (* Notes UTF-8/16/32 with BOM handling: * * cursor_enc is updated after the first slice has been read. This * usually changes this field to either the big or little endian * encoding variant. No update is needed when previous slices are * scanned, because the BOM is only allowed at the beginning of the * string, so can at most go back to exactly the BOM. * * cursor_encoding returns `Enc_utf16 when the cursor is over the * BOM, and cursor_enc otherwise. *) exception End_of_string;; exception Cursor_out_of_range;; exception Partial_character;; exception Byte_order_mark;; type 's poly_cursor = { (* configuration: *) cursor_ops : 's Netstring_tstring.tstring_ops; mutable cursor_target : 's; mutable cursor_range_pos : int; mutable cursor_range_len : int; mutable cursor_offset : int; mutable cursor_enc : encoding; (* `Enc_utf16: Only used if the slice or string is too short to * recognize the endianess. Otherwise, the encoding is set * to the endian-aware variant. * `Enc_utf32: same *) mutable cursor_has_bom : bool; (* Whether there is a BOM. Only when initially cursor_enc=`Enc_utf16 or utf32 *) (* conversion: *) mutable cursor_slice_char : int array; (* Contains the characters of the slice. Special values: * -1: EOF * -2: Incomplete multi-byte character at end * -3: BOM at the beginning *) mutable cursor_slice_blen : int array; (* Contains the byte length of the characters. * Recall that this array must contain 1s when single-byte * encodings are scanned, and must not be modified. The * "reader" does not fill this array for single-byte encodings, * so modifications would persist! *) mutable cursor_imbchar_len : int; (* This is always 0, except in the special case when the first * character of this slice is EOF, and EOF is preceded by an * incomplete multi-byte character (imbchar). In this case, * the length of the imbchar is stored here. *) mutable cursor_slice_char_pos : int; (* char pos of the beginning of the slice *) mutable cursor_slice_byte_pos : int; (* byte pos of the beginning of the slice *) mutable cursor_slice_length : int; (* number of characters *) mutable cursor_slice_bytes : int; (* number of bytes *) (* bookkeeping: *) mutable cursor_char_pos : int; mutable cursor_byte_pos : int; mutable cursor_index : int; (* index in the slice array *) mutable cursor_problem_range_start : int; mutable cursor_problem_range_end : int; (* The character positions >= range_start and < range_end are * considered as problem range. It is known that there is a * coding error (Malformed_code), so slices with length 1 must * be used. *) (* methods: *) mutable load_next_slice : unit -> unit; (* Precondition: cursor is one char right of the end of the slice * Action: load the next slice * Postcondition: cursor is at the beginning of the new slice *) mutable load_prev_slice : unit -> unit; (* Precondition: cursor is at the beginning of current slice * Action: load the previous slice * Postcondition: the cursor is at the end of the new slice * or the function raises Cursor_out_of_range * Note that this function actually moves the cursor one character * back (in contrast to load_next_slice that only reloads the * slice array, but does not move the cursor). The function may * choose to allocate a new, shorter slice array. *) } ;; type cursor = string poly_cursor let cursor_target cs = cs.cursor_target;; let cursor_range cs = (cs.cursor_range_pos, cs.cursor_range_len);; let cursor_initial_rel_pos cs = cs.cursor_offset;; let cursor_char_count cs = cs.cursor_char_pos;; let cursor_pos cs = cs.cursor_byte_pos;; let cursor_encoding cs = let enc = cs.cursor_enc in match enc with ( `Enc_utf16_le | `Enc_utf16_be ) when cs.cursor_has_bom -> if cs.cursor_byte_pos = cs.cursor_range_pos then `Enc_utf16 else enc | ( `Enc_utf32_le | `Enc_utf32_be ) when cs.cursor_has_bom -> if cs.cursor_byte_pos = cs.cursor_range_pos then `Enc_utf32 else enc | (`Enc_utf8 | `Enc_utf8_opt_bom) when cs.cursor_has_bom -> if cs.cursor_byte_pos = cs.cursor_range_pos then `Enc_utf8_opt_bom else enc | _ -> enc ;; exception Failing_in_Netconversion_uchar_at let uchar_at cs = let ch = cs.cursor_slice_char.(cs.cursor_index) in if ch < 0 then match ch with -1 -> raise End_of_string | -2 -> raise Partial_character | -3 -> raise Byte_order_mark | _ -> (* assert false *) raise Failing_in_Netconversion_uchar_at (* "assert false" isn't inlined! *) else ch ;; let cursor_byte_length cs = let ch = cs.cursor_slice_char.(cs.cursor_index) in if ch = -1 then raise End_of_string else cs.cursor_slice_blen.(cs.cursor_index) ;; let cursor_at_end cs = let ch = cs.cursor_slice_char.(cs.cursor_index) in ch = (-1) ;; let move_right num cs = let rec go num = let sl = Array.length cs.cursor_slice_char in if num >= sl - cs.cursor_index then begin (* Case: go at least to the next slice *) (* If the current slice is not completely filled, we will be * definitely outside of the valid range *) if cs.cursor_slice_length < sl then begin (* move to rightmost position, and raise the approriate exception *) cs.cursor_byte_pos <- cs.cursor_slice_byte_pos + cs.cursor_slice_bytes; cs.cursor_char_pos <- cs.cursor_slice_char_pos + cs.cursor_slice_length; cs.cursor_index <- cs.cursor_slice_length; assert(cs.cursor_slice_char.(cs.cursor_index) = (-1)); raise Cursor_out_of_range; end; assert(cs.cursor_slice_length = sl); let n = sl - cs.cursor_index in cs.cursor_byte_pos <- cs.cursor_slice_byte_pos + cs.cursor_slice_bytes; cs.cursor_char_pos <- cs.cursor_slice_char_pos + cs.cursor_slice_length; cs.cursor_index <- sl; cs.load_next_slice(); (* may raise Malformed_code *) go (num - n); end else begin (* Case: do not leave this slice *) let bl_sum = ref 0 in for k = cs.cursor_index to cs.cursor_index + num - 1 do let bl = cs.cursor_slice_blen.(k) in if k >= cs.cursor_slice_length then begin (* Cursor is beyond EOF *) cs.cursor_byte_pos <- cs.cursor_byte_pos + !bl_sum; cs.cursor_char_pos <- cs.cursor_char_pos + (k - cs.cursor_index); cs.cursor_index <- k; raise Cursor_out_of_range end; bl_sum := !bl_sum + bl done; cs.cursor_byte_pos <- cs.cursor_byte_pos + !bl_sum; cs.cursor_char_pos <- cs.cursor_char_pos + num; cs.cursor_index <- cs.cursor_index + num; end in assert(num >= 0); try go num with Malformed_code -> (* This happens when load_next_slice fails to decode the next slice * of length 1. In this case, load_next_slice keeps the state of * the cursor, so we have the chance to correct it now. *) cs.cursor_index <- cs.cursor_index - 1; cs.cursor_char_pos <- cs.cursor_char_pos - 1; cs.cursor_byte_pos <- cs.cursor_byte_pos - cs.cursor_slice_blen.(cs.cursor_index); raise Malformed_code ;; let move_left num cs = let rec go num = if num > cs.cursor_index then begin let n = cs.cursor_index in cs.cursor_byte_pos <- cs.cursor_slice_byte_pos; cs.cursor_char_pos <- cs.cursor_slice_char_pos; cs.cursor_index <- 0; (* cursor is now at the beginning of the slice *) cs.load_prev_slice(); (* go another character back *) go (num-n-1) (* so we went n+1 characters in this round *) end else begin (* num <= cs.cursor_index *) let bl_sum = ref 0 in let n = cs.cursor_index - num in for k = cs.cursor_index - 1 downto n do bl_sum := !bl_sum + cs.cursor_slice_blen.(k) done; cs.cursor_byte_pos <- cs.cursor_byte_pos - !bl_sum; cs.cursor_char_pos <- cs.cursor_char_pos - num; cs.cursor_index <- n; end in assert(num < 0); go (-num) ;; let move ?(num = 1) cs = if num >= 0 then move_right num cs else move_left num cs ;; let init_load_slice cs enc = let open Netstring_tstring in let ops = cs.cursor_ops in let reader0 = (get_reader enc).read ops in let back0 = lazy(get_back_fn enc ops) in (* For most encodings, [reader] and [back] never change. * For UTF-16, there may be refinements, however. *) let reader() = match cs.cursor_enc with ( `Enc_utf16 | `Enc_utf16_le | `Enc_utf16_be ) when cs.cursor_has_bom -> (* Ensure we use `Enc_utf16_bom when we read the beginning * of the range *) (fun slice_char slice_blen s bp bl -> if bp = cs.cursor_range_pos then (get_reader1 `Enc_utf16_bom).read ops slice_char slice_blen s bp bl else (get_reader cs.cursor_enc).read ops slice_char slice_blen s bp bl ) | ( `Enc_utf32 | `Enc_utf32_le | `Enc_utf32_be ) when cs.cursor_has_bom -> (* Ensure we use `Enc_utf32_bom when we read the beginning * of the range *) (fun slice_char slice_blen s bp bl -> if bp = cs.cursor_range_pos then (get_reader1 `Enc_utf32_bom).read ops slice_char slice_blen s bp bl else (get_reader cs.cursor_enc).read ops slice_char slice_blen s bp bl ) | ( `Enc_utf8 | `Enc_utf8_opt_bom ) when cs.cursor_has_bom -> (fun slice_char slice_blen s bp bl -> if bp = cs.cursor_range_pos then (get_reader1 `Enc_utf8_bom).read ops slice_char slice_blen s bp bl else (get_reader cs.cursor_enc).read ops slice_char slice_blen s bp bl ) | _ -> reader0 in let back() = match cs.cursor_enc with ( `Enc_utf16 | `Enc_utf16_le | `Enc_utf16_be ) when cs.cursor_has_bom -> get_back_fn cs.cursor_enc ops | ( `Enc_utf32 | `Enc_utf32_le | `Enc_utf32_be ) when cs.cursor_has_bom -> get_back_fn cs.cursor_enc ops | ( `Enc_utf8 | `Enc_utf8_opt_bom ) when cs.cursor_has_bom -> get_back_fn cs.cursor_enc ops | _ -> Lazy.force back0 in let record_imbchar rd_chars rd_bytes scan_bytes = (* Put a (-2) at position rd_chars of the current slice *) cs.cursor_slice_char.(rd_chars) <- (-2); cs.cursor_slice_blen.(rd_chars) <- scan_bytes - rd_bytes; if rd_chars+1 < Array.length cs.cursor_slice_char then ( cs.cursor_slice_char.(rd_chars+1) <- (-1); ); cs.cursor_slice_length <- rd_chars+1; cs.cursor_slice_bytes <- scan_bytes; in let repair_slice slice_size = (* When the reader raises Malformed_code, the slice has been * modified. This function reloads the old slice again. * * This function repairs these fields from the other fields: * - cursor_slice_char * - cursor_slice_blen * - cursor_slice_length * - cursor_slice_bytes *) let bp = cs.cursor_slice_byte_pos in let ep = cs.cursor_range_pos + cs.cursor_range_len in let (slice_char, slice_blen) = (Array.make slice_size (-1), Array.make slice_size 1) in let rd_chars, rd_bytes, _ = try reader () slice_char slice_blen cs.cursor_target bp (ep-bp) with (* should not happen: *) Malformed_code_read(_,_,_) -> raise Malformed_code in cs.cursor_slice_length <- rd_chars; cs.cursor_slice_bytes <- rd_bytes; cs.cursor_slice_char <- slice_char; cs.cursor_slice_blen <- slice_blen; (* Check for imbchars: *) if rd_chars < slice_size && rd_bytes < ep-bp then ( record_imbchar rd_chars rd_bytes (ep-bp); ); in let load_next_slice() = let cp = cs.cursor_char_pos in let bp = cs.cursor_byte_pos in let ep = cs.cursor_range_pos + cs.cursor_range_len in let load slice_size = let old_partial_len = (* Handle the case that the last character is (-2), and thus the first * character of the next slice will be (-1). Then, cursor_imbchar_len * must be set to the length of the (-2) character. *) if cs.cursor_slice_char.(cs.cursor_slice_length-1) = (-2) then cs.cursor_slice_blen.(cs.cursor_slice_length-1) else 0 in (* Check if the current array can be reused, or if we need new * arrays with different sizes *) let (slice_char, slice_blen) = if slice_size = Array.length cs.cursor_slice_char then (cs.cursor_slice_char, cs.cursor_slice_blen) (* use old arrays again *) else (Array.make slice_size (-1), Array.make slice_size 1) (* create new arrays with different size *) in (* Use the reader to decode the bytes and to put the characters into * slice_char. *) let rd_chars, rd_bytes, enc' = reader () slice_char slice_blen cs.cursor_target bp (ep-bp) in (* may raise Malformed_code_read *) (* Update cursor record: *) cs.cursor_index <- 0; cs.cursor_slice_char <- slice_char; cs.cursor_slice_blen <- slice_blen; cs.cursor_slice_length <- rd_chars; cs.cursor_slice_bytes <- rd_bytes; cs.cursor_slice_char_pos <- cp; cs.cursor_slice_byte_pos <- bp; cs.cursor_imbchar_len <- old_partial_len; cs.cursor_enc <- enc'; (* Check for imbchars: *) if rd_chars < slice_size && rd_bytes < ep-bp then ( record_imbchar rd_chars rd_bytes (ep-bp); ); in (* Is the cursor positioned in a problem range? If yes, decode only * one character. If not, try to decode a block of characters. * If the latter fails, the current position turns out to be * problematic, and is remembered as such. *) let old_slice_size = Array.length cs.cursor_slice_char in if cp >= cs.cursor_problem_range_start && cp < cs.cursor_problem_range_end then begin try load 1 with Malformed_code_read(_,_,_) -> repair_slice old_slice_size; raise Malformed_code end else begin try load big_slice with Malformed_code_read(_,_,_) -> cs.cursor_problem_range_start <- cp; cs.cursor_problem_range_end <- cp+big_slice; try load 1 with Malformed_code_read(_,_,_) -> repair_slice old_slice_size; raise Malformed_code end in let load_prev_slice() = let cp = cs.cursor_char_pos in let bp = cs.cursor_byte_pos in let ep = cs.cursor_range_pos + cs.cursor_range_len in let load slice_size = (* Check if the current array can be reused, or if we need new * arrays with different sizes *) let (slice_char, slice_blen) = if slice_size = Array.length cs.cursor_slice_char then (cs.cursor_slice_char, cs.cursor_slice_blen) (* use old arrays again *) else (Array.make slice_size (-1), Array.make slice_size 1) (* create new arrays with different size *) in (* Go back 1 character (must always succeed): *) if bp = cs.cursor_range_pos then raise Cursor_out_of_range; let bk1_chars, bk1_bytes = if cs.cursor_imbchar_len > 0 then (* Special case: the last character of this slice is an imbchar. * Assume imbchar_len *) (1, cs.cursor_imbchar_len) else back () cs.cursor_target cs.cursor_range_pos bp 1 in if bk1_chars = 0 then raise Malformed_code; (* bk1_chars = 0: this means there is a multi-byte suffix at the * beginning of the range * ==> bk1_chars = 1 *) (* Go back further slice_size-1 characters (or less): *) let bk_chars, bk_bytes = back () cs.cursor_target cs.cursor_range_pos (bp-bk1_bytes) (slice_size-1) in let bp' = bp - bk1_bytes - bk_bytes in (* Use the reader to decode the bytes and to put the characters into * slice_char. *) let rd_chars, rd_bytes, _ = reader () slice_char slice_blen cs.cursor_target bp' (ep-bp') in (* may raise Malformed_code_read *) assert(rd_chars >= bk_chars); (* Update cursor record: *) cs.cursor_index <- bk_chars; cs.cursor_slice_char <- slice_char; cs.cursor_slice_blen <- slice_blen; cs.cursor_slice_length <- rd_chars; cs.cursor_slice_bytes <- rd_bytes; cs.cursor_slice_char_pos <- cp - bk_chars - 1; cs.cursor_slice_byte_pos <- bp'; cs.cursor_imbchar_len <- 0; (* Cannot happen *) (* Don't need to update cursor_enc! *) (* Check for imbchars: *) if rd_chars < slice_size && rd_bytes < ep-bp' then ( record_imbchar rd_chars rd_bytes (ep-bp'); ); (* Implicitly go one character back: *) cs.cursor_char_pos <- cp - 1; cs.cursor_byte_pos <- bp - bk1_bytes; in (* Is the cursor positioned in a problem range? If yes, decode only * one character. If not, try to decode a block of characters. * If the latter fails, the current position turns out to be * problematic, and is remembered as such. *) let old_slice_size = Array.length cs.cursor_slice_char in if cp > cs.cursor_problem_range_start && cp <= cs.cursor_problem_range_end then begin try load 1 with Malformed_code_read(_,_,_) -> repair_slice old_slice_size; raise Malformed_code end else begin try load big_slice with Malformed_code_read(_,_,_) -> cs.cursor_problem_range_start <- cp-big_slice; cs.cursor_problem_range_end <- cp; try load 1 with Malformed_code_read(_,_,_) -> repair_slice old_slice_size; raise Malformed_code end in (* Important note: These two functions either modify the cursor state * as requested, or they raise an exception, and keep the cursor state * as before. Considered exceptions are Malformed_code, and * Cursor_out_of_range. *) cs.load_next_slice <- load_next_slice; cs.load_prev_slice <- load_prev_slice ;; let create_poly_cursor ?(range_pos = 0) ?range_len ?(initial_rel_pos = 0) enc ops s = let open Netstring_tstring in if range_pos < 0 || range_pos > ops.length s then invalid_arg "Netconversion.create_cursor"; let range_len = match range_len with Some l -> l | None -> ops.length s - range_pos in if range_len < 0 || range_pos + range_len > ops.length s then invalid_arg "Netconversion.create_cursor"; if initial_rel_pos < 0 || initial_rel_pos > range_len then invalid_arg "Netconversion.create_cursor"; if enc = `Enc_utf16 && initial_rel_pos <> 0 then failwith "Netconversion.create_cursor: The encoding `Enc_utf16 only supported when initial_rel_pos=0"; if enc = `Enc_utf32 && initial_rel_pos <> 0 then failwith "Netconversion.create_cursor: The encoding `Enc_utf32 only supported when initial_rel_pos=0"; let cs = { cursor_ops = ops; cursor_target = s; cursor_range_pos = range_pos; cursor_range_len = range_len; cursor_offset = initial_rel_pos; cursor_enc = enc; cursor_has_bom = (enc = `Enc_utf16 || enc = `Enc_utf32 || enc = `Enc_utf8_opt_bom); cursor_slice_char = [| 1 |]; cursor_slice_blen = [| 1 |]; cursor_imbchar_len = 0; cursor_slice_char_pos = 0; cursor_slice_byte_pos = range_pos + initial_rel_pos; cursor_slice_length = 1; cursor_slice_bytes = 0; cursor_char_pos = 0; cursor_byte_pos = range_pos + initial_rel_pos; cursor_index = 1; cursor_problem_range_start = max_int; cursor_problem_range_end = max_int; load_next_slice = (fun () -> assert false); load_prev_slice = (fun () -> assert false); } in init_load_slice cs enc; (* load the next slice to do the rest of the initialization: *) cs.load_next_slice(); cs ;; let create_cursor ?range_pos ?range_len ?initial_rel_pos enc s = let ops = Netstring_tstring.string_ops in create_poly_cursor ?range_pos ?range_len ?initial_rel_pos enc ops s type 'a with_cursor_fun = { with_cursor_fun : 's . 's Netstring_tstring.tstring_ops -> 's poly_cursor -> 'a } let with_tstring_cursor ?range_pos ?range_len ?initial_rel_pos enc ts f = let f = { Netstring_tstring.with_fun = (fun ops s -> f.with_cursor_fun ops (create_poly_cursor ?range_pos ?range_len ?initial_rel_pos enc ops s) ) } in Netstring_tstring.with_tstring f ts let reinit_cursor ?(range_pos = 0) ?range_len ?(initial_rel_pos = 0) ?enc s cs = let open Netstring_tstring in let ops = cs.cursor_ops in if range_pos < 0 || range_pos > ops.length s then invalid_arg "Netconversion.reinit_cursor"; let range_len = match range_len with Some l -> l | None -> ops.length s - range_pos in if range_len < 0 || range_pos + range_len > ops.length s then invalid_arg "Netconversion.reinit_cursor"; if initial_rel_pos < 0 || initial_rel_pos > range_len then invalid_arg "Netconversion.reinit_cursor"; let enc = match enc with None -> cs.cursor_enc | Some e -> e in if enc = `Enc_utf16 && initial_rel_pos <> 0 then failwith "Netconversion.reinit_cursor: The encoding `Enc_utf16 only supported when initial_rel_pos=0"; if enc = `Enc_utf32 && initial_rel_pos <> 0 then failwith "Netconversion.reinit_cursor: The encoding `Enc_utf32 only supported when initial_rel_pos=0"; let old_enc = cs.cursor_enc in cs.cursor_target <- s; cs.cursor_range_pos <- range_pos; cs.cursor_range_len <- range_len; cs.cursor_offset <- initial_rel_pos; cs.cursor_enc <- enc; cs.cursor_has_bom <- (enc = `Enc_utf16 || enc = `Enc_utf32 || enc = `Enc_utf8_opt_bom); cs.cursor_imbchar_len <- 0; cs.cursor_slice_char_pos <- 0; cs.cursor_slice_byte_pos <- range_pos + initial_rel_pos; cs.cursor_slice_length <- 1; cs.cursor_slice_bytes <- 0; cs.cursor_char_pos <- 0; cs.cursor_byte_pos <- range_pos + initial_rel_pos; cs.cursor_index <- 1; cs.cursor_problem_range_start <- max_int; cs.cursor_problem_range_end <- max_int; cs.load_next_slice <- (fun () -> assert false); cs.load_prev_slice <- (fun () -> assert false); cs.cursor_slice_char.(0) <- 1; if not (same_encoding enc old_enc) then (* slice_blen: It might have happened that the new encoding is an * 8 bit charset, but the old was not. Re-initialize this array * to ensure it contains only "1" in this case. *) Array.fill cs.cursor_slice_blen 0 (Array.length cs.cursor_slice_blen) 1; init_load_slice cs enc; (* load the next slice to do the rest of the initialization: *) cs.load_next_slice(); ;; let copy_cursor ?enc cs = let enc = match enc with None -> cs.cursor_enc | Some e -> e in if same_encoding enc cs.cursor_enc then { cs with cursor_slice_char = Array.copy cs.cursor_slice_char; cursor_slice_blen = Array.copy cs.cursor_slice_blen; } else begin if enc = `Enc_utf16 then failwith "Netconversion.copy_cursor: The encoding `Enc_utf16 is not supported"; if enc = `Enc_utf32 then failwith "Netconversion.copy_cursor: The encoding `Enc_utf32 is not supported"; let cs' = { cs with cursor_enc = enc; cursor_slice_char = [| 1 |]; cursor_slice_blen = [| 1 |]; cursor_slice_length = 1; cursor_problem_range_start = max_int; cursor_problem_range_end = max_int; } in init_load_slice cs' enc; (* load the next slice to do the rest of the initialization: *) cs'.load_next_slice(); cs' end ;; let cursor_blit_maxlen cs = let l = cs.cursor_slice_length - cs.cursor_index in (* Test on special situations: *) match cs.cursor_slice_char.(cs.cursor_index) with -1 -> (* EOF *) raise End_of_string | -3 -> (* BOM *) 0 | _ -> if cs.cursor_slice_char.(cs.cursor_slice_length - 1) = (-2) then (* Partial character *) l-1 else l ;; let cursor_blit cs ua pos len = if pos < 0 || len < 0 || pos+len > Array.length ua then invalid_arg "Netconversion.cursor_blit"; let cs_len = cursor_blit_maxlen cs in let l = min cs_len len in int_blit cs.cursor_slice_char cs.cursor_index ua pos l; l ;; let cursor_blit_positions cs ua pos len = if pos < 0 || len < 0 || pos+len > Array.length ua then invalid_arg "Netconversion.cursor_blit_positions"; let cs_len = cursor_blit_maxlen cs in let l = min cs_len len in let p = cs.cursor_byte_pos in let blen = cs.cursor_slice_blen in let cidx = cs.cursor_index in assert(pos+l <= Array.length ua); assert(cidx+l <= Array.length cs.cursor_slice_blen); Netaux.ArrayAux.int_series blen cidx ua pos l p; l ;; (**********************************************************************) (* String functions *) (**********************************************************************) (* CHECK * - ustring_length: Count imbchars? No! * * DOC: * - imbchar handling (additional exceptions) *) let ustring_length_poly ops enc = let open Netstring_tstring in if is_single_byte enc then fun ?(range_pos=0) ?range_len s -> let range_len = match range_len with None -> ops.length s - range_pos | Some l -> l in if range_pos < 0 || range_len < 0 || range_pos+range_len > ops.length s then invalid_arg "Netconversion.ustring_length"; range_len else fun ?range_pos ?range_len s -> (* Assumption: There is no string that has more than max_int * characters *) let cs = create_poly_cursor ?range_pos ?range_len enc ops s in ( try move ~num:max_int cs with Cursor_out_of_range -> ()); let n = cursor_char_count cs in (* Check that the last char is not an imbchar *) ( try move ~num:(-1) cs; let _ = uchar_at cs in () with Cursor_out_of_range -> () | Partial_character -> raise Malformed_code ); n ;; let ustring_length enc = ustring_length_poly Netstring_tstring.string_ops enc let ustring_length_ts enc ?range_pos ?range_len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> ustring_length_poly ops enc ?range_pos ?range_len s ) } ts exception Malformed_code_at of int;; let verify_poly ops enc ?range_pos ?range_len s = let cs = try create_poly_cursor ?range_pos ?range_len enc ops s with Malformed_code -> raise (Malformed_code_at 0) | _ -> assert false in ( try move ~num:max_int cs with Cursor_out_of_range -> () | Malformed_code -> (* Now cursor_pos is the byte position of the last valid * character. Add the length of this character. *) let n = cs.cursor_slice_blen.(cs.cursor_index) in raise (Malformed_code_at (cs.cursor_byte_pos + n)) ); (* Now we are at EOF. Check this. Furthermore, check whether there is * an imbchar just before EOF: *) ( try let _ = uchar_at cs in assert false with End_of_string -> () ); ( try move ~num:(-1) cs; let _ = uchar_at cs in () with Cursor_out_of_range -> () (* empty string *) | Partial_character -> raise (Malformed_code_at (cs.cursor_byte_pos)) ); () ;; let verify enc = verify_poly Netstring_tstring.string_ops enc let verify_ts enc ?range_pos ?range_len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> verify_poly ops enc ?range_pos ?range_len s ) } ts let ustring_iter_poly ops enc f ?range_pos ?range_len s = let cs = create_poly_cursor ?range_pos ?range_len enc ops s in try while true do let ch = uchar_at cs in (* or End_of_string *) f ch; move cs done; assert false with End_of_string -> () | Partial_character -> raise Malformed_code ;; let ustring_iter enc = ustring_iter_poly Netstring_tstring.string_ops enc let ustring_iter_ts enc f ?range_pos ?range_len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> ustring_iter_poly ops enc f ?range_pos ?range_len s ) } ts let ustring_map_poly ops out_kind enc f ?range_pos ?range_len s = (* The following algorithm works only if the mapped lists are short: let mkch = ustring_of_uchar enc in let subst p = let p' = f p in String.concat "" (List.map mkch p') in convert ~subst ~in_enc:enc ~out_enc:`Enc_empty ?range_pos ?range_len s *) let buf = Netbuffer.create 250 in ustring_iter_poly ops enc (fun p -> let l = f p in Netbuffer.add_string buf (String.concat "" (List.map (ustring_of_uchar enc) l)) ) ?range_pos ?range_len s; Netbuffer.to_tstring_poly buf out_kind ;; let ustring_map enc = ustring_map_poly Netstring_tstring.string_ops Netstring_tstring.String_kind enc let ustring_map_ts enc f ?range_pos ?range_len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> match ts with | `String _ -> let kind = Netstring_tstring.String_kind in `String( ustring_map_poly ops kind enc f ?range_pos ?range_len s) | `Bytes _ -> let kind = Netstring_tstring.Bytes_kind in `Bytes( ustring_map_poly ops kind enc f ?range_pos ?range_len s) | `Memory _ -> let kind = Netstring_tstring.Memory_kind in `Memory( ustring_map_poly ops kind enc f ?range_pos ?range_len s) ) } ts let ustring_to_lower enc ?range_pos ?range_len s = let f x = [ Netunichar.to_lower x ] in ustring_map enc f ?range_pos ?range_len s ;; let ustring_to_lower_ts enc ?range_pos ?range_len ts = let f x = [ Netunichar.to_lower x ] in ustring_map_ts enc f ?range_pos ?range_len ts ;; let ustring_to_lower_poly ops kind enc ?range_pos ?range_len ts = let f x = [ Netunichar.to_lower x ] in ustring_map_poly ops kind enc f ?range_pos ?range_len ts ;; let ustring_to_upper enc ?range_pos ?range_len s = let f x = [ Netunichar.to_upper x ] in ustring_map enc f ?range_pos ?range_len s ;; let ustring_to_upper_ts enc ?range_pos ?range_len ts = let f x = [ Netunichar.to_upper x ] in ustring_map_ts enc f ?range_pos ?range_len ts ;; let ustring_to_upper_poly ops kind enc ?range_pos ?range_len ts = let f x = [ Netunichar.to_upper x ] in ustring_map_poly ops kind enc f ?range_pos ?range_len ts ;; let ustring_to_title enc ?range_pos ?range_len s = let f x = [ Netunichar.to_title x ] in ustring_map enc f ?range_pos ?range_len s ;; let ustring_to_title_ts enc ?range_pos ?range_len ts = let f x = [ Netunichar.to_title x ] in ustring_map_ts enc f ?range_pos ?range_len ts ;; let ustring_to_title_poly ops kind enc ?range_pos ?range_len s = let f x = [ Netunichar.to_title x ] in ustring_map_poly ops kind enc f ?range_pos ?range_len s ;; let ustring_sub_poly ops out_kind enc pos len ?range_pos ?range_len s = let open Netstring_tstring in try if pos < 0 || len < 0 then raise Cursor_out_of_range; let cs = create_poly_cursor ?range_pos ?range_len enc ops s in move ~num:pos cs; let byte_pos_0 = cursor_pos cs in move ~num:len cs; let byte_pos_1 = cursor_pos cs in (* Check: The last character of the string must not be an imbchar *) if len > 0 then ( move ~num:(-1) cs; let _ = uchar_at cs in (); (* or Partial_character *) ); ops.subpoly out_kind s byte_pos_0 (byte_pos_1 - byte_pos_0) with Cursor_out_of_range -> invalid_arg "Netconversion.ustring_sub" | Partial_character -> raise Malformed_code ;; let ustring_sub enc = ustring_sub_poly Netstring_tstring.string_ops Netstring_tstring.String_kind enc let ustring_sub_ts enc pos len ?range_pos ?range_len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> match ts with | `String _ -> let kind = Netstring_tstring.String_kind in `String( ustring_sub_poly ops kind enc pos len ?range_pos ?range_len s) | `Bytes _ -> let kind = Netstring_tstring.Bytes_kind in `Bytes( ustring_sub_poly ops kind enc pos len ?range_pos ?range_len s) | `Memory _ -> let kind = Netstring_tstring.Memory_kind in `Memory( ustring_sub_poly ops kind enc pos len ?range_pos ?range_len s) ) } ts let ustring_compare_poly ops1 ops2 enc f ?range_pos:rp1 ?range_len:rl1 s1 ?range_pos:rp2 ?range_len:rl2 s2 = let cs1 = create_poly_cursor ?range_pos:rp1 ?range_len:rl1 enc ops1 s1 in let cs2 = create_poly_cursor ?range_pos:rp2 ?range_len:rl2 enc ops2 s2 in let r = ref 0 in try while !r = 0 do let ch1 = uchar_at cs1 in (* or End_of_string *) let ch2 = uchar_at cs2 in (* or End_of_string *) r := f ch1 ch2 done; !r with End_of_string -> ( match cursor_at_end cs1, cursor_at_end cs2 with true, false -> (-1) | false, true -> 1 | true, true -> 0 | _ -> assert false ) | Partial_character -> raise Malformed_code ;; let ustring_compare enc = ustring_compare_poly Netstring_tstring.string_ops Netstring_tstring.string_ops enc let ustring_compare_ts enc f ?range_pos:rp1 ?range_len:rl1 ts1 ?range_pos:rp2 ?range_len:rl2 ts2 = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops1 s1 -> Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops2 s2 -> ustring_compare_poly ops1 ops2 enc f ?range_pos:rp1 ?range_len:rl1 s1 ?range_pos:rp2 ?range_len:rl2 s2 ) } ts2 ) } ts1 let uarray_of_ustring_poly ops enc ?(range_pos=0) ?range_len s = let open Netstring_tstring in let range_len = match range_len with Some l -> l | None -> ops.length s - range_pos in if range_pos < 0 || range_len < 0 || range_pos+range_len > ops.length s then invalid_arg "Netconversion.uarray_of_ustring"; let slice_length = big_slice in let slice_char = Array.make slice_length (-1) in let slice_blen = Array.make slice_length 1 in let k = ref 0 in let e = ref enc in let reader = ref (get_reader enc) in let buf = ref [] in while !k < range_len do let (n_inc, k_inc, enc') = try (!reader).read ops slice_char slice_blen s (range_pos + !k) (range_len - !k) with Malformed_code_read(_,_,_) -> raise Malformed_code in k := !k + k_inc; buf := (Array.sub slice_char 0 n_inc) :: !buf ; if enc' <> !e then begin e := enc'; reader := get_reader enc'; Array.fill slice_blen 0 slice_length 1; end; if n_inc < slice_length then ( (* EOF *) if !k < range_len then raise Malformed_code; (* s ends with multi-byte prefix*) k := range_len; ); done; Array.concat (List.rev !buf) ;; let uarray_of_ustring enc = uarray_of_ustring_poly Netstring_tstring.string_ops enc let uarray_of_ustring_ts enc ?range_pos ?range_len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> uarray_of_ustring_poly ops enc ?range_pos ?range_len s ) } ts let ustring_of_uarray_poly out_kind ?(subst = fun code -> raise (Cannot_represent code)) enc ?(pos=0) ?len ua = let len = match len with Some l -> l | None -> Array.length ua - pos in if pos < 0 || len < 0 || pos+len > Array.length ua then invalid_arg "Netconversion.ustring_of_uarray"; (* Estimate the size of the output string: * length * 2 is just guessed. It is assumed that this number is usually * too large, and to avoid that too much memory is wasted, the buffer is * limited by 10000. *) let size = ref (max multibyte_limit (min 10000 (len * 2))) in let out_buf = ref (Bytes.create !size) in let writer = get_writer enc in let k_in = ref 0 in let k_out = ref 0 in while !k_in < len do let k_in_inc, k_out_inc = writer ua (pos + !k_in) (len - !k_in) !out_buf !k_out (!size - !k_out) subst in k_in := !k_in + k_in_inc; k_out := !k_out + k_out_inc; (* double the size of out_buf: *) let size' = min Sys.max_string_length (!size + !size) in if size' < !size + multibyte_limit then failwith "Netconversion.ustring_of_uarray: string too long"; let out_buf' = Bytes.create size' in Bytes.blit !out_buf 0 out_buf' 0 !k_out; out_buf := out_buf'; size := size'; done; Netstring_tstring.bytes_subpoly out_kind !out_buf 0 !k_out ;; let ustring_of_uarray ?subst = ustring_of_uarray_poly Netstring_tstring.String_kind ?subst let ustring_of_uarray_ts : type t . t Netstring_tstring.tstring_kind -> ?subst:(int->string) -> encoding -> ?pos:int -> ?len:int -> int array -> tstring = fun out_kind ?subst enc ?pos ?len ua -> let s = ustring_of_uarray_poly out_kind ?subst enc ?pos ?len ua in match out_kind with | Netstring_tstring.String_kind -> `String s | Netstring_tstring.Bytes_kind -> `Bytes s | Netstring_tstring.Memory_kind -> `Memory s let code_cmp x1 x2 = x1-x2 let ci_code_cmp x1 x2 = let x1_lc = Netunichar.to_lower x1 in let x2_lc = Netunichar.to_lower x2 in x1_lc - x2_lc ocamlnet-4.1.6/src/netstring/netconversion.mli0000644000175000017500000017420613274252307020172 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- *) (** Conversion between character encodings * * {b Contents} * {ul * {- {!Netconversion.preliminaries} * {ul * {- {!Netconversion.unicode}} * {- {!Netconversion.subsets}} * {- {!Netconversion.linking}} * {- {!Netconversion.domain}} * {- {!Netconversion.problems}}}} * {- {!Netconversion.interface} * {ul * {- {!Netconversion.direct_conv}} * {- {!Netconversion.cursors} * {ul {- {!Netconversion.bom}}}} * {- {!Netconversion.unicode_functions}} * } * } * } *) open Netsys_types (** {1:preliminaries Preliminaries} * * A {b character set} is a set of characters where every character is * identified by a {b code point}. An {b encoding} is a way of * representing characters from a set in byte strings. For example, * the Unicode character set has more than 96000 characters, and * the code points have values from 0 to 0x10ffff (not all code points * are assigned yet). The UTF-8 encoding represents the code points * by sequences of 1 to 4 bytes. There are also encodings that * represent code points from several sets, e.g EUC-JP covers four * sets. * * Encodings are enumerated by the type [encoding], and names follow * the convention [`Enc_*], e.g. [`Enc_utf8]. * Character sets are enumerated by the type * [charset], and names follow the convention [`Set_*], e.g. * [`Set_unicode]. * * This module deals mainly with encodings. It is important to know * that the same character set may have several encodings. For example, * the Unicode character set can be encoded as UTF-8 or UTF-16. * For the 8 bit character sets, however, there is usually only one * encoding, e.g [`Set_iso88591] is always encoded as [`Enc_iso88591]. * * In a {b single-byte encoding} every code point is represented by * one byte. This is what many programmers are accustomed at, and * what the OCaml language specially supports: A [string] is * a sequence of [char]s, where [char] means an 8 bit quantity * interpreted as character. For example, the following piece of code allocates * a [string] of four [char]s, and assigns them individually: * * {[ * let s = String.create 4 in * s.[0] <- 'G'; * s.[1] <- 'e'; * s.[2] <- 'r'; * s.[3] <- 'd'; * ]} * * In a {b multi-byte encoding} there are code points that are represented * by several bytes. As we still represent such text as [string], the * problem arises that a single [char], actually a byte, often represents * only a fraction of a full multi-byte character. There are two solutions: * - Give up the principle that text is represented by [string]. * This is, for example, the approach chosen by [Camomile], another OCaml * library dealing with Unicode. Instead, text is represented as * [int array]. This way, the algorithms processing the text can * remain the same. * - Give up the principle that individual characters can be directly * accessed in a text. This is the primary way chosen by Ocamlnet. * This means that there is not any longer the possibility to read * or write the [n]th character of a text. One can, however, still * compose texts by just concatenating the strings representing * individual characters. Furthermore, it is possible to define * a cursor for a text that moves sequentially along the text. * The consequence is that programmers are restricted to sequential * algorithms. Note that the majority of text processing falls into * this class. * * The corresponding piece of code for Ocamlnet's Unicode implementation * is: * {[ * let b = Buffer.create 80 in * Buffer.add b (ustring_of_uchar `Enc_utf8 71); (* 71 = code point of 'G' *) * Buffer.add b (ustring_of_uchar `Enc_utf8 101); (* 101 = code point of 'e' *) * Buffer.add b (ustring_of_uchar `Enc_utf8 114); (* 114 = code point of 'r' *) * Buffer.add b (ustring_of_uchar `Enc_utf8 100); (* 100 = code point of 'd' *) * let s = Buffer.contents b * ]} * * It is important to always remember that a [char] is no longer * a character but simply a byte. In many of the following explanations, * we strictly distinguish between {b byte positions} or {b byte counts}, * and {b character positions} or {b character counts}. * * There a number of special effects that usually only occur in * multi-byte encodings: * * - Bad encodings: Not every byte sequence is legal. When scanning * such text, the functions will raise the exception [Malformed_code] * when they find illegal bytes. * - Unassigned code points: It may happen that a byte sequence is * a correct representation for a code point, but that the code point * is unassigned in the character set. When scanning, this is also * covered by the exception [Malformed_code]. When converting from * one encoding to another, it is also possible that the code point * is only unassigned in the target character set. This case is * usually handled by a substitution function [subst], and if no such * function is defined, by the exception [Cannot_represent]. * - Incomplete characters: The trailing bytes of a string may be the * correct beginning of a byte sequence for a character, but not a * complete sequence. Of course, if that string is the end of a * text, this is just illegal, and also a case for [Malformed_code]. * However, when text is processed chunk by chunk, this phenomenon * may happen legally for all chunks but the last. For this reason, * some of the functions below handle this case specially. * - Byte order marks: Some encodings have both big and little endian * variants. A byte order mark at the beginning of the text declares * which variant is actually used. This byte order mark is a * declaration written like a character, but actually not a * character. * * There is a special class of encodings known as {b ASCII-compatible}. * They are important because there are lots of programs and protocols * that only interpret bytes from 0 to 127, and treat the bytes from * 128 to 255 as data. These programs can process texts as long as * the bytes from 0 to 127 are used as in ASCII. Fortunately, many * encodings are ASCII-compatible, including UTF-8. * * {2:unicode Unicode} * * [Netconversion] is centred around Unicode. * The conversion from one encoding to another works by finding the * Unicode code point of the character * to convert, and by representing the code point in the target encoding, * even if neither encodings have to do with Unicode. * Of course, this approach requires that all character sets handled * by [Netconversion] are subsets of Unicode. * * The supported range of Unicode code points: 0 to 0xd7ff, 0xe000 to 0xfffd, * 0x10000 to 0x10ffff. All these code points can be represented in * UTF-8 and UTF-16. [Netconversion] does not know which of the code * points are assigned and which not, and because of this, it simply * allows all code points of the mentioned ranges (but for other character * sets, the necessary lookup tables exist). * * {b UTF-8:} The UTF-8 representation can have one to four bytes. Malformed * byte sequences are always rejected, even those that want to cheat the * reader like "0xc0 0x80" for the code point 0. There is special support * for the Java variant of UTF-8 ([`Enc_java]). [`Enc_utf8] strings must not * have a byte order mark (it would be interpreted as "zero-width space" * character). However, the Unicode standard allows byte order marks * at the very beginning of texts; use [`Enc_utf8_opt_bom] in this case. * * {b UTF-16:} When reading from a string encoded as [`Enc_utf16], a byte * order mark is expected at the beginning. The detected variant * ([`Enc_utf16_le] or [`Enc_utf16_be]) is usually returned by the parsing * function. The byte order mark is not included into the output string. - * Some functions of this * module cannot cope with [`Enc_utf16] (i.e. UTF-16 without endianess * annotation), and will fail. * * Once the endianess is determined, the code point 0xfeff is no longer * interpreted as byte order mark, but as "zero-width non-breakable space". * * Some code points are represented by pairs of 16 bit values, these * are the so-called "surrogate pairs". They can only occur in UTF-16. * * {b UTF-32:} This is very much the same as for UTF-16. There is a little * endian version [`Enc_utf32_le] and a big endian version [`Enc_utf32_be]. * * {2:subsets Subsets of Unicode} * * The non-Unicode character sets are subsets of Unicode. Here, it may * happen that a Unicode code point does not have a corresponding * code point. In this case, certain rules are applied to handle * this (see below). It is, however, ensured that every non-Unicode * code point has a corresponding Unicode code point. (In other words, * character sets cannot be supported for which this property does * not hold.) * * It is even possible to create further subsets artificially. The * encoding [`Enc_subset(e,def)] means to derive a new encoding from * the existing one [e], but to only accept the code points for which * the definition function [def] yields the value [true]. For example, * the encoding * {[ `Enc_subset(`Enc_usascii, * fun i -> i <> 34 && i <> 38 && i <> 60 && i <> 62) ]} * is ASCII without the bracket angles, the quotation mark, and the * ampersand character, i.e. the subset of ASCII that can be included * in HTML text without escaping. * * If a code point is not defined by the encoding but found in a text, * the reader will raise the exception [Malformed_code]. When text is * output, however, the [subst] function will be called for undefined code * points (which raises [Cannot_represent] by default). The [subst] * function is an optional argument of many conversion functions that * allows it to insert a substitution text for undefined code points. * Note, however, that the substitution text is restricted to at most * 50 characters (because unlimited length would lead to difficult * problems we would like to avoid). * * {2:linking Linking this module} * * Many encodings require lookup tables. The following encodings * are built-in and always supported: * * - Unicode: [`Enc_utf8], [`Enc_java], [`Enc_utf16], [`Enc_utf16_le], [`Enc_utf16_be], [`Enc_utf32], [`Enc_utf32_le], [`Enc_utf32_be] * - Other: [`Enc_usascii], [`Enc_iso88591], [`Enc_empty] * * The lookup tables for the other encodings are usually loaded at * runtime, but it is also possible to embed them in the generated * binary executable. See {!Netunidata} for details. The functions * [available_input_encodings] and [available_output_encodings] can * be invoked to find out which encodings can be loaded, or are available * otherwise. * * {2:domain Supported Encodings, Restrictions} * * I took the mappings from [www.unicode.org], and the standard names of * the character sets from IANA. Obviously, many character sets are missing * that can be supported; especially ISO646 character sets, and many EBCDIC * code pages. Stateful encodings like generic ISO-2022 have been omitted * (stateless subsets of ISO-2022 like EUC can be supported, however; * currently we support EUC-JP and EUC-KR). * * Because of the copyright statement from Unicode, I cannot put the * source tables that describe the mappings into the distribution. They * are publicly available from [www.unicode.org]. * * {2:problems Known Problems} * * - The following charsets do not have a bijective mapping to Unicode: * adobe_standard_encoding, adobe_symbol_encoding, * adobe_zapf_dingbats_encoding, cp1002 (0xFEBE). The current implementation * simply removes one of the conflicting code point pairs - this might * not what you want. * - Japanese encodings: * JIS X 0208: The character 1/32 is mapped to 0xFF3C, and not * to 0x005C. *) (** {1:interface Interface} * * {b Naming conventions:} * * As it is possible to refer to substrings by either giving a byte * offset or by counting whole characters, these naming conventions * are helpful: * * - Labels called [range_pos] and [range_len] refer to byte positions of * characters, or substrings * - Labels called [count] refer to positions given as the number of characters * relative to an origin * * Furthermore: * * - A [uchar] is a single Unicode code point represented as int * - A [ustring] is a string of encoded characters * - A [uarray] is an [array of int] representing a string *) exception Malformed_code (** Raised when an illegal byte sequence is found *) exception Cannot_represent of int (** Raised when a certain Unicode code point cannot be represented in * the selected output encoding *) (** The polymorphic variant enumerating the supported encodings. We have: * - [`Enc_utf8]: UTF-8 * - [`Enc_utf8_opt_bom]: UTF-8 with an optional byte order mark at the * beginning of the text * - [`Enc_java]: The UTF-8 variant used by Java (the only difference is * the representation of NUL) * - [`Enc_utf16]: UTF-16 with unspecified endianess (restricted) * - [`Enc_utf16_le]: UTF-16 little endian * - [`Enc_utf16_be]: UTF-16 big endian * - [`Enc_utf32]: UTF-32 with unspecified endianess (restricted) * - [`Enc_utf32_le]: UTF-32 little endian * - [`Enc_utf32_be]: UTF-32 big endian * - [`Enc_usascii]: US-ASCII (7 bits) * - [`Enc_iso8859]{i n}: ISO-8859-{i n} * - [`Enc_koi8r]: KOI8-R * - [`Enc_jis0201]: JIS-X-0201 (Roman and Katakana) * - [`Enc_eucjp]: EUC-JP (code points from US-ASCII, JIS-X-0202, -0208, and * -0212) * - [`Enc_euckr]: EUC-KR (code points from US-ASCII, KS-X-1001) * - [`Enc_windows]{i n}: WINDOWS-{i n} * - [`Enc_cp]{i n}: IBM code page {i n}. Note that there are both ASCII- * and EBCDIC-based code pages * - [`Enc_adobe_*]: Adobe-specific encodings, e.g. used in Adobe fonts * - [`Enc_mac*]: Macintosh-specific encodings * - [`Enc_subset(e,def)]: The subset of [e] by applying the definition * function [def] * - [`Enc_empty]: The empty encoding (does not represent any character) *) type encoding = [ `Enc_utf8 (* UTF-8 *) | `Enc_utf8_opt_bom | `Enc_java (* The variant of UTF-8 used by Java *) | `Enc_utf16 (* UTF-16 with unspecified endianess (restricted usage) *) | `Enc_utf16_le (* UTF-16 little endian *) | `Enc_utf16_be (* UTF-16 big endian *) | `Enc_utf32 (* UTF-32 with unspecified endianess (restricted usage) *) | `Enc_utf32_le (* UTF-32 little endian *) | `Enc_utf32_be (* UTF-32 big endian *) | `Enc_usascii (* US-ASCII (only 7 bit) *) | `Enc_iso88591 (* ISO-8859-1 *) | `Enc_iso88592 (* ISO-8859-2 *) | `Enc_iso88593 (* ISO-8859-3 *) | `Enc_iso88594 (* ISO-8859-4 *) | `Enc_iso88595 (* ISO-8859-5 *) | `Enc_iso88596 (* ISO-8859-6 *) | `Enc_iso88597 (* ISO-8859-7 *) | `Enc_iso88598 (* ISO-8859-8 *) | `Enc_iso88599 (* ISO-8859-9 *) | `Enc_iso885910 (* ISO-8859-10 *) | `Enc_iso885911 (* ISO-8859-11 *) | `Enc_iso885913 (* ISO-8859-13 *) | `Enc_iso885914 (* ISO-8859-14 *) | `Enc_iso885915 (* ISO-8859-15 *) | `Enc_iso885916 (* ISO-8859-16 *) | `Enc_koi8r (* KOI8-R *) | `Enc_jis0201 (* JIS-X-0201 (Roman in lower half; Katakana upper half *) | `Enc_eucjp (* EUC-JP (includes US-ASCII, JIS-X-0201, -0208, -0212) *) (* Japanese, TODO: *) (*| `Enc_iso2022jp of jis_state = [ `Enc_usascii | `Enc_jis0201 | `Enc_jis0208_1978 | `Enc_jis0208_1893 ] It is very likely that ISO-2022 will be handled in a different module. This encoding is too weird. | `Enc_sjis *) | `Enc_euckr (* EUC-KR (includes US-ASCII, KS-X-1001) *) (* Older standards: *) | `Enc_asn1_iso646 (* only the language-neutral subset - "IA5String" *) | `Enc_asn1_T61 (* ITU T.61 ("Teletex") *) | `Enc_asn1_printable (* ASN.1 Printable *) (* Microsoft: *) | `Enc_windows1250 (* WINDOWS-1250 *) | `Enc_windows1251 (* WINDOWS-1251 *) | `Enc_windows1252 (* WINDOWS-1252 *) | `Enc_windows1253 (* WINDOWS-1253 *) | `Enc_windows1254 (* WINDOWS-1254 *) | `Enc_windows1255 (* WINDOWS-1255 *) | `Enc_windows1256 (* WINDOWS-1256 *) | `Enc_windows1257 (* WINDOWS-1257 *) | `Enc_windows1258 (* WINDOWS-1258 *) (* IBM, ASCII-based: *) | `Enc_cp437 | `Enc_cp737 | `Enc_cp775 | `Enc_cp850 | `Enc_cp852 | `Enc_cp855 | `Enc_cp856 | `Enc_cp857 | `Enc_cp860 | `Enc_cp861 | `Enc_cp862 | `Enc_cp863 | `Enc_cp864 | `Enc_cp865 | `Enc_cp866 | `Enc_cp869 | `Enc_cp874 | `Enc_cp1006 (* IBM, EBCDIC-based: *) | `Enc_cp037 | `Enc_cp424 | `Enc_cp500 | `Enc_cp875 | `Enc_cp1026 | `Enc_cp1047 (* Adobe: *) | `Enc_adobe_standard_encoding | `Enc_adobe_symbol_encoding | `Enc_adobe_zapf_dingbats_encoding (* Apple: *) | `Enc_macroman (* Encoding subset: *) | `Enc_subset of (encoding * (int -> bool)) | `Enc_empty (* does not encode any character *) ] (** A [charset] is simply a set of code points. It does not say how * the code points are encoded as bytes. Every encoding implies a certain * charset (or several charsets) that can be encoded, but the reverse is * not true. *) type charset = [ `Set_unicode (* The full Unicode repertoire *) | `Set_usascii (* US-ASCII (only 7 bit) *) | `Set_iso88591 (* ISO-8859-1 *) | `Set_iso88592 (* ISO-8859-2 *) | `Set_iso88593 (* ISO-8859-3 *) | `Set_iso88594 (* ISO-8859-4 *) | `Set_iso88595 (* ISO-8859-5 *) | `Set_iso88596 (* ISO-8859-6 *) | `Set_iso88597 (* ISO-8859-7 *) | `Set_iso88598 (* ISO-8859-8 *) | `Set_iso88599 (* ISO-8859-9 *) | `Set_iso885910 (* ISO-8859-10 *) | `Set_iso885911 (* ISO-8859-11 *) | `Set_iso885913 (* ISO-8859-13 *) | `Set_iso885914 (* ISO-8859-14 *) | `Set_iso885915 (* ISO-8859-15 *) | `Set_iso885916 (* ISO-8859-16 *) | `Set_koi8r (* KOI8-R *) | `Set_jis0201 (* JIS-X-0201 *) | `Set_jis0208 (* JIS-X-0208 *) | `Set_jis0212 (* JIS-X-0212 *) | `Set_ks1001 (* KS-X-1001 *) | `Set_asn1_iso646 | `Set_asn1_T61 | `Set_asn1_printable (* Microsoft: *) | `Set_windows1250 (* WINDOWS-1250 *) | `Set_windows1251 (* WINDOWS-1251 *) | `Set_windows1252 (* WINDOWS-1252 *) | `Set_windows1253 (* WINDOWS-1253 *) | `Set_windows1254 (* WINDOWS-1254 *) | `Set_windows1255 (* WINDOWS-1255 *) | `Set_windows1256 (* WINDOWS-1256 *) | `Set_windows1257 (* WINDOWS-1257 *) | `Set_windows1258 (* WINDOWS-1258 *) (* IBM, ASCII-based: *) | `Set_cp437 | `Set_cp737 | `Set_cp775 | `Set_cp850 | `Set_cp852 | `Set_cp855 | `Set_cp856 | `Set_cp857 | `Set_cp860 | `Set_cp861 | `Set_cp862 | `Set_cp863 | `Set_cp864 | `Set_cp865 | `Set_cp866 | `Set_cp869 | `Set_cp874 | `Set_cp1006 (* IBM, EBCDIC-based: *) | `Set_cp037 | `Set_cp424 | `Set_cp500 | `Set_cp875 | `Set_cp1026 | `Set_cp1047 (* Adobe: *) | `Set_adobe_standard_encoding | `Set_adobe_symbol_encoding | `Set_adobe_zapf_dingbats_encoding (* Apple: *) | `Set_macroman ] (** {b Pre-evaluation of the encoding argument:} * * A number of the following functions can be made run faster if they are * called several times for the same encoding. In this case, it is recommended * to apply the function once partially with the encoding argument, and to * call the resulting closure instead. For example, [ustring_of_uchar] supports * this technique: * * {[ * let my_ustring_of_uchar = ustring_of_uchar my_enc in * let s1 = my_ustring_of_uchar u1 ... * let s2 = my_ustring_of_uchar u2 ... ]} * * This is {b much} faster than * * {[ * let s1 = ustring_of_uchar my_enc u1 ... * let s2 = ustring_of_uchar my_enc u2 ... ]} * * The availability of this optimization is indicated by the predicate * PRE_EVAL({i arg}) where {i arg} identifies the encoding argument. * * {b Inlining} * * When a function can be inlined across module/library boundaries, * this is indicated by the predicate INLINED. Of course, this works * only for the ocamlopt compiler. *) val encoding_of_string : string -> encoding;; (** Returns the encoding of the name of the encoding. Fails if the * encoding is unknown. * E.g. [encoding_of_string "iso-8859-1" = `Enc_iso88591] * * Punctuation characters (e.g. "-") and year suffixes (e.g. * ":1991") are ignored. *) val string_of_encoding : encoding -> string;; (** Returns the name of the encoding. *) val is_ascii_compatible : encoding -> bool;; (** "ASCII compatible" means: The bytes 1 to 127 represent the ASCII * codes 1 to 127, and no other representation of a character contains * the bytes 1 to 127. * * For example, ISO-8859-1 is ASCII-compatible because the byte 1 to * 127 mean the same as in ASCII, and all other characters use bytes * greater than 127. UTF-8 is ASCII-compatible for the same reasons, * it does not matter that there are multi-byte characters. * EBCDIC is not ASCII-compatible because the bytes 1 to 127 do not mean * the same as in ASCII. UTF-16 is not ASCII-compatible because the bytes * 1 to 127 can occur in multi-byte representations of non-ASCII * characters. * * The byte 0 has been excluded from this definition because the C * language uses it with a special meaning that has nothing to do with * characters, so it is questionable to interpret the byte 0 anyway. *) val is_single_byte : encoding -> bool (** Returns whether the encoding is a single-byte encoding *) val same_encoding : encoding -> encoding -> bool (** Whether both encodings are the same. [`Enc_subset] encodings are only * considered as equal when the definition functions are physically the same. * * Warning: Don't use ( = ) to compare encodings because this may * fail. *) val byte_order_mark : encoding -> string (** Returns the byte order mark that must occur at the beginning of * files to indicate whether "little endian" or "big endian" is used. * If this does not apply to the encoding, an empty string is returned. * * See also the section about "{!Netconversion.bom}" below. *) val makechar : encoding -> int -> string (** [makechar enc i:] * Creates the string representing the Unicode code point [i] in encoding * [enc]. Raises [Not_found] if the character is legal but cannot be * represented in [enc]. * * Possible encodings: everything but [`Enc_utf16] and [`Enc_utf32] * * Evaluation hints: * - PRE_EVAL(encoding) * * @deprecated This function is deprecated since ocamlnet-0.96. Use * [ustring_of_uchar] instead. *) val ustring_of_uchar : encoding -> int -> string (** [ustring_of_uchar enc i]: * Creates the string representing the Unicode code point [i] in encoding * [enc]. Raises [Cannot_represent i] if the character is legal but cannot be * represented in [enc]. * * Possible encodings: everything but [`Enc_utf16] and [`Enc_utf32]. * * Evaluation hints: * - PRE_EVAL(encoding) *) val to_unicode : charset -> int -> int (** Maps the code point of the charset to the corresponding * Unicode code point, or raises [Malformed_code], when the * input number does not correspond to a code point. * * Note [`Set_jis0208] and [`Set_jis0212]: Code points are usually * given by a row and column number. The numeric code point returned by * this function is computed by multiplying the row number (1..94) with 96, * and by adding the column number (1..94), i.e. row*96+column. * * Evaluation hints: * - PRE_EVAL(charset) *) val from_unicode : charset -> int -> int (** Maps the Unicode code point to the corresponding code point of * the charset, or raises [Cannot_represent] when there is no such * corresponding code point. * * Note [`Set_jis0208] and [`Set_jis0212]: Code points are usually * given by a row and column number. The numeric code point returned by * this function is computed by multiplying the row number (1..94) with 96, * and by adding the column number (1..94), i.e. row*96+column. * * Evaluation hints: * - PRE_EVAL(charset) *) val available_input_encodings : unit -> encoding list (** Returns the list of all available encodings that can be used for * input strings. The list reflects the set of loadable/linked [Netmapping] * modules. *) val available_output_encodings : unit -> encoding list (** Returns the list of all available encodings that can be used for * output strings. The list reflects the set of loadable/linked [Netmapping] * modules. *) val user_encoding : unit -> encoding option (** Determines the preferred user encoding: - Unix: This is the character set from the current locale - Win32: This is derived from the current ANSI code page If an error occurs while determining the result, the value [None] is returned. *) val win32_code_pages : (int * encoding) list (** Mapping between Win32 code page numbers and Ocamlnet encodings. This is incomplete. The official list: http://msdn.microsoft.com/en-us/library/dd317756%28v=VS.85%29.aspx *) (**********************************************************************) (* Conversion between character encodings *) (**********************************************************************) (** {2:direct_conv Direct Conversion} *) (** In order to convert a string from one encoding to another, call * [convert] like in * * {[ let s_utf8 = * convert ~in_enc:`Enc_iso88591 ~out_enc:`Enc_utf8 s_latin1 ]} * * which converts the ISO-8859-1 string [s_latin1] to the UTF-8 string * [s_utf8]. * * It is also possible to convert while reading from or writing to a file. * This use case is effectively handled by the class * {!Netconversion.conversion_pipe}. * See the explanations of this class for examples. *) val convert : ?subst:(int -> string) -> in_enc:encoding -> out_enc:encoding -> ?range_pos:int -> ?range_len:int -> string -> string (** Converts the string from [in_enc] to [out_enc], and returns it. * The string must consist of a whole number of characters. If it * ends with an incomplete multi-byte character, however, this is * detected, and the exception [Malformed_code] will be raised. * This exception is also raised for other encoding errors in the * input string. * * @param subst This function is invoked for code points of [in_enc] that * cannot be represented in [out_enc], and the result of the function * invocation is substituted (directly, without any further conversion). * Restriction: The string returned by [subst] must not be longer than 50 * bytes. * If [subst] is missing, [Cannot_represent] is raised in this case. * * @param range_pos Selects a substring for conversion. [range_pos] * is the byte position of the first character of the substring. * (Default: 0) * * @param range_len Selects a substring for conversion. [range_len] * is the length of the substring in bytes (Default: Length * of the input string minus [range_pos]) *) val convert_tstring : ?subst:(int -> string) -> in_enc:encoding -> out_enc:encoding -> out_kind:'s Netstring_tstring.tstring_kind -> ?range_pos:int -> ?range_len:int -> tstring -> 's (** Same for tagged strings *) val convert_poly : in_ops:'s1 Netstring_tstring.tstring_ops -> out_kind:'s2 Netstring_tstring.tstring_kind -> ?subst:(int -> string) -> in_enc:encoding -> out_enc:encoding -> ?range_pos:int -> ?range_len:int -> 's1 -> 's2 (** Polymorphic version *) val recode : in_enc:encoding -> in_buf:string -> in_pos:int -> in_len:int -> out_enc:encoding -> out_buf:Bytes.t -> out_pos:int -> out_len:int -> max_chars:int -> subst:(int -> string) -> (int * int * encoding) (** * Converts the character sequence contained in the at most [in_len] bytes * of [in_buf] starting at byte position [in_pos], and writes the result * into at most [out_len] bytes of [out_buf] starting at byte position * [out_pos]. At most [max_chars] characters are converted from * [in_buf] to [out_buf]. * * The characters in [in_buf] are assumed to be encoded as [in_enc], and the * characters in [out_buf] will be encoded as [out_enc]. The case * [in_enc = out_enc] is not handled specially, and is carried out as * fast as any other conversion. * * If there is a code point which cannot be represented in [out_enc], * the function [subst] is called with the code point as argument, and the * resulting string (which must already be encoded as [out_enc]) is * inserted instead. * It is possible that [subst] is called several times for the same * character. Restriction: The string returned by subst must not be longer * than 50 bytes. * * It is allowed that the input buffer ends with an incomplete * multi-byte character. This character is not converted, i.e. the * conversion ends just before this character. This special condition * is not indicated to the caller. * * @return The triple [(in_n, out_n, in_enc')] is returned: * - [in_n] is the actual number of bytes that have been converted from * [in_buf]; [in_n] may be smaller than [in_len] because of incomplete * multi-byte characters, or because the output buffer has less space * for characters than the input buffer, or because of a change * of the encoding variant. * - [out_n] is the actual number of bytes written into [out_buf]. * - [in_enc'] is normally identical to [in_enc]. However, there are cases * where the encoding can be refined when looking at the byte * sequence; for example whether a little endian or big endian variant * of the encoding is used. [in_enc'] is the variant of [in_enc] that was * used for the last converted character. * * If there is at least one complete character in [in_buf], and at least * space for one complete character in [out_buf], and [max_chars >= 1], it is * guaranteed that [in_n > 0 && out_n > 0]. *) val recode_tstring : in_enc:encoding -> in_buf:tstring -> in_pos:int -> in_len:int -> out_enc:encoding -> out_buf:Bytes.t -> out_pos:int -> out_len:int -> max_chars:int -> subst:(int -> string) -> (int * int * encoding) (** A version of [recode] for tagged strings *) val recode_poly : in_ops:'s Netstring_tstring.tstring_ops -> in_enc:encoding -> in_buf:'s -> in_pos:int -> in_len:int -> out_enc:encoding -> out_buf:Bytes.t -> out_pos:int -> out_len:int -> max_chars:int -> subst:(int -> string) -> (int * int * encoding) (** A polymorphic version of [recode] *) class conversion_pipe : ?subst:(int -> string) -> in_enc:encoding -> out_enc:encoding -> unit -> Netchannels.io_obj_channel (** This pipeline class (see [Netchannels] for more information) can be used * to recode a netchannel while reading or writing. The argument [in_enc] * is the input encoding, and [out_enc] is the output encoding. * * The channel must consist of a whole number of characters. If it * ends with an incomplete multi-byte character, however, this is * detected, and the exception [Malformed_code] will be raised. * This exception is also raised for other encoding errors in the * channel data. * * {b Example.} Convert ISO-8859-1 to UTF-8 while writing to the file * ["output.txt"]: * * {[ * let ch = new output_channel (open_out "output.txt") in * let encoder = * new conversion_pipe ~in_enc:`Enc_iso88591 ~out_enc:`Enc_utf8 () in * let ch' = new output_filter encoder ch in * ... (* write to ch' *) * ch' # close_out(); * ch # close_out(); (* you must close both channels! *) * ]} * * If you write as UTF-16, don't forget to output the byte order * mark yourself, as the channel does not do this. * * {b Example.} Convert UTF-16 to UTF-8 while reading from the file * ["input.txt"]: * * {[ * let ch = new input_channel (open_in "input.txt") in * let encoder = * new conversion_pipe ~in_enc:`Enc_utf16 ~out_enc:`Enc_utf8 () in * let ch' = new input_filter ch encoder in * ... (* read from ch' *) * ch' # close_in(); * ch # close_in(); (* you must close both channels! *) * ]} * * @param subst This function is invoked for code points of [in_enc] that * cannot be represented in [out_enc], and the result of the function * invocation is substituted (directly, without any further conversion). * Restriction: The string returned by [subst] must not be longer than 50 * bytes. * If [subst] is missing, [Cannot_represent] is raised in this case. *) (**********************************************************************) (* Cursors *) (**********************************************************************) (** {2:cursors Reading Text Using Cursors} * * A cursor is a reference to a character in an encoded string. The * properties of the current character can be obtained, and the cursor * can be moved relative to its current position. * * For example, the following loop outputs the Unicode code points * of all characters of the UTF-8 input string [s]: * * {[ * let cs = create_cursor `Enc_utf8 s in * while not (cursor_at_end cs) do * let n = cursor_char_count cs in * let ch = uchar_at cs in * printf "At position %d: %d\n" n ch; * move cs; * done * ]} * * For a more exact definition, cursors are modeled as follows: The reference * to the encoded string is contained in the cursor. This * can be a complete string, or an arbitrary substring (denoted by a * range of valid byte positions). The cursor * position can be initially set to an arbitrary byte position of the * encoded string. * * Cursor positions can be denoted by * - byte positions [p] in the encoded string, or by * - character counts [n] relative to the initial position. * * Valid cursor positions are: * - [n=0]: This is always the initial cursor position * - [n>0]: Positive char counts refer to characters right to the initial * character. The rightmost position is the position [n_max] past the * rightmost character. The rightmost position does not have a * code point. * - [n<0]: Negative char counts refer to characters left to the initial * character. The leftmost position is the position [n_min] of the * leftmost character. * * For the empty string we have [n_min = n_max = 0], complementing the * above definition. * * Cursors are moved to the left or right of their current position * by a whole number of characters. When it is tried to move them * past the leftmost or rightmost position, the cursor is placed to the * leftmost or rightmost position, respectively, and the exception * [Cursor_out_of_range] is raised. * * There are two cases of illegal encodings: * - When the last byte sequence of the encoded string is an incomplete * multi-byte character, this is detected, and the special exception * [Partial_character] is raised when the code point of this character * is read. Note that this can only happen at position [n_max-1]. It * is allowed to move beyond this character to [n_max]. * - When an illegal byte sequence occurs in the encoded string (including * an incomplete multi-byte character at the beginning of the string), * it is not possible to move the cursor to this character, or across * this character. When it is tried to do so, the cursor stops just * before the bad sequence, and the exception [Malformed_code] is * raised. * * It is undefined what happens when the encoded string is modified * while a cursor is in use referring to it. *) type 's poly_cursor (** A cursor denotes a character position in an encoded string. The parameter ['s] is the string type, e.g. [string] or [bytes]. *) type cursor = string poly_cursor exception End_of_string (** Raised when it is tried to access the character after the end of the * string (at position [n_max]) *) exception Cursor_out_of_range (** Raised when it is tried to move the cursor beyond the beginning of the * string or beyond the end of the string. In the latter case, it is * legal to move the cursor to the position following the last character, * but it is not possible to move it further. *) exception Partial_character (** Raised when the last character of the string is an incomplete * multi-byte character, and it is tried to get the code point * (using [uchar_at]). *) exception Byte_order_mark (** Raised when it is tried to get the code point of the BOM at the * beginning of the string *) val create_cursor : ?range_pos:int -> ?range_len:int -> ?initial_rel_pos:int -> encoding -> string -> cursor (** Creates a new cursor for the passed string and the passed encoding. * By default, the allowed range of the cursor is the whole string, * and the cursor is intially positioned at the beginning of the string. * The {b range} is the part of the string the cursor can move within. * * {b Special behaviour for [`Enc_utf16]/[`Enc_utf32]:} UTF with unspecified * endianess is handled specially. First, this encoding is only * accepted when [initial_rel_pos=0]. Second, the first two bytes * must be a byte order mark (BOM) (if the string has a length of two * bytes or more). The BOM counts as character without code point. * The function [uchar_at] raises the exception [Byte_order_mark] * when the BOM is accessed. Third, when the cursor is moved to the * next character, the encoding as returned by [cursor_encoding] is * changed to either [`Enc_utf16_le] or [`Enc_utf16_be] according * to the BOM. The encoding changes back to [`Enc_utf16] when the * cursor is moved back to the initial position. * * {b Special behavior for [`Enc_utf8_opt_bom]:} Here, a byte order mark * at the beginning of the text is recognized, and [uchar_at] will * raise [Byte_order_mark]. Unlike in the UTF-16 and 32 cases, the BOM * is optional. The function [cursor_encoding] returns [`Enc_utf8] * if the cursor is moved away from the BOM, and changes back to * [`Enc_utf8_opt_bom] if moved back to the first character. * * @param range_pos Restricts the range of the cursor to a substring. * The argument [range_pos] is the byte position of the beginning * of the range. (Defaults to 0) * @param range_len Restricts the range of the cursor to a substring. * The argument [range_len] is the length of the range. * (Default: Length of the input string minus [range_pos]) * @param initial_rel_pos The initial position of the cursor, given * as bytes relative to [range_pos]. The character at this position * is considered as the zeroth character of the string (as reported * by [cursor_char_count]) *) val create_poly_cursor : ?range_pos:int -> ?range_len:int -> ?initial_rel_pos:int -> encoding -> 's Netstring_tstring.tstring_ops -> 's -> 's poly_cursor (** Polymorphic version *) (** Helper type for {!Netconversion.with_tstring_cursor} *) type 'a with_cursor_fun = { with_cursor_fun : 's . 's Netstring_tstring.tstring_ops -> 's poly_cursor -> 'a } val with_tstring_cursor : ?range_pos:int -> ?range_len:int -> ?initial_rel_pos:int -> encoding -> tstring -> 'a with_cursor_fun -> 'a (** Creates a cursor like [create_cursor] and calls [with_cursor_fun] with the cursor, returning any result unchanged. Note that there cannot be a "create_tstring_cursor" for typing reasons, and this is the closest approximation. *) val reinit_cursor : ?range_pos:int -> ?range_len:int -> ?initial_rel_pos:int -> ?enc:encoding -> 's -> 's poly_cursor -> unit (** Reuses an existing cursor for a new purpose. The arguments are * as in [create_cursor]. *) val copy_cursor : ?enc:encoding -> 's poly_cursor -> 's poly_cursor (** Copies the cursor. The copy can be moved independently of the original * cursor, but is applied to the same string. The copy starts at the * byte position of the string where the original cursor is currently * positioned. * * @param enc Optionally, the assumed * encoding can be changed to a different one by passing [enc]. *) val cursor_target : 's poly_cursor -> 's (** Returns the string of the cursor * * Evaluation hints: * - INLINED *) val cursor_range : _ poly_cursor -> (int * int) (** Returns the valid range of the cursor as pair [(range_pos, range_len)] * * Evaluation hints: * - INLINED *) val cursor_initial_rel_pos : _ poly_cursor -> int (** Returns the initial relative byte position of the cursor * * Evaluation hints: * - INLINED *) val cursor_char_count : _ poly_cursor -> int (** Returns the character count of the cursor. The initial position * (when [create_cursor] was called) has the number 0, positions to the * right denote positive numbers, and positions to the left negative numbers. * * Evaluation hints: * - INLINED *) val cursor_pos : _ poly_cursor -> int (** Returns the byte position of the cursor, i.e. the byte index of * the string that corresponds to the cursor position. The function * returns the absolute position (i.e. NOT relative to [cursor_range]). * * Evaluation hints: * - INLINED *) val uchar_at : _ poly_cursor -> int (** Returns the Unicode code point of the character at the cursor. * Raises [End_of_string] if the cursor is positioned past the last * character. * Raises [Partial_character] if the last character of the analysed * string range is an incomplete multi-byte character. * Raises [Byte_order_mark] if the first character of the string * is a BOM (when the encoding has BOMs). * * Evaluation hints: * - INLINED *) val cursor_byte_length : _ poly_cursor -> int (** Returns the byte length of the representation of the character at the * cursor. This works also for incomplete multi-byte characters and * BOMs. * Raises [End_of_string] if the cursor is positioned past the last * character. * * Evaluation hints: * - INLINED *) val cursor_at_end : _ poly_cursor -> bool (** Returns whether the cursor is positioned past the last character. * * Evaluation hints: * - INLINED *) val move : ?num:int -> _ poly_cursor -> unit (** Moves the cursor one character to the right, or if [num] is passed, * this number of characters to the right. [num] can be negative in * which case the cursor is moved to the left. * * If the cursor were placed outside the valid range, the cursor * would go into an illegal state, and because of this, this is * handled as follows: the cursor moves to the * leftmost or rightmost position (depending on the direction), * and the exception [Cursor_out_of_range] is raised. *) val cursor_encoding : _ poly_cursor -> encoding (** Returns the encoding of the cursor. For some encodings, the * returned encoding depends on the position of the cursor (see * the note about UTF-8 in [create_cursor]) * * Evaluation hints: * - INLINED *) val cursor_blit : _ poly_cursor -> int array -> int -> int -> int (** [cursor_blit cs ua pos len]: Copies at most [len] characters as code * points from * the cursor position and the following positions to the array [ua] * at index [pos]. The number of copied characters is returned. * If the cursor is already at the end of the string when this * function is called, the exception [End_of_string] will be raised instead, * and no characters are copied. The cursor positions containing byte * order marks and partial characters are never copied; this is ensured * by stopping the copying procedure just before these positions. This * may even make the function return the number 0. * * The function tries to copy as many characters as currently available * in the already decoded part of the string the cursor is attached to. * In the current implementation, this number is not higher than 250. * You can call [cursor_blit_maxlen] to get an upper limit. * * The function does not move the cursor. *) val cursor_blit_maxlen : _ poly_cursor -> int (** Returns the maximum number of characters [cursor_blit] can copy * at the current cursor position. This is the number of characters * [cursor_blit] would copy if the [len] argument were arbitrarily * large. * * Note that the value depends on the cursor position and on the * contents of the cursor string. * * This function raises [End_of_string] if the cursor is positioned * at the end of the string. *) val cursor_blit_positions : _ poly_cursor -> int array -> int -> int -> int (** Works like [cursor_blit], but copies the byte positions of the * characters into [ua] instead of the code points. * * When called directly after [cursor_blit] for the same cursor and * with the same value of [len], this function copies as many characters * and thus returns the same number: * * {[let n1 = cursor_blit cs ua ua_pos len in * let n2 = cursor_blit_pos cs pa pa_pos len in * assert (n1 = n2)]} *) (** {3:bom Byte Order Marks} * * Because UTF-16 allows both little and big endian, files and other * permanent representations of UTF-16 text are usually prepended by * a byte order mark (BOM). There is confusion about the BOM among * Unicode users, so the following explanations may be helpful. * * Of course, the BOM is only used for external representations like * files, as the endianess is always known for in-memory representations * by the running program. This module has six encoding identifiers: * - [`Enc_utf16]: UTF-16 where the endianess is unknown * - [`Enc_utf16_le]: UTF-16 little endian * - [`Enc_utf16_be]: UTF-16 big endian * - [`Enc_utf32]: UTF-32 where the endianess is unknown * - [`Enc_utf32_le]: UTF-32 little endian * - [`Enc_utf32_be]: UTF-32 big endian * * When a file is read, the endianess is unknown at the beginning. * This is expressed by e.g. [`Enc_utf16]. When the BOM is read, the encoding * is refined to either [`Enc_utf16_le] or [`Enc_utf16_be], whatever * the BOM says. This works as follows: The BOM is the representation * of the code point 0xfeff as little or big endian, i.e. as byte sequences * "0xfe 0xff" (big endian) or "0xff 0xfe" (little endian). As the "wrong" * code point 0xfffe is intentionally unused, the reader can determine * the endianess. * * There is one problem, though. Unfortunately, the code point 0xfeff * is also used for the normal "zero width non-breakable space" character. * When this code point occurs later in the text, it is interpreted as * this character. Of course, this means that one must know whether * there is a BOM at the beginning, and if not, one must know the * endianess. One cannot program in the style * "well, let's see what is coming and guess". * * Unicode also allows a BOM for UTF-8 although it is meaningless to specify * the endianess. If you create the cursor with the encoding [`Enc_utf8] * nothing is done about this, and you get the BOM as normal character. * If you create the cursor with [`Enc_utf8_opt_bom], the BOM is treated * specially like in the UTF-16 and -32 cases * (with the only difference that it is optional for UTF-8). * * The functions of this module can all deal with BOMs when reading * encoded text. In most cases, the BOM is hidden from the caller, * and just handled automatically. Cursors, however, treat BOMs as special * characters outside of the code set * (exception [Byte_order_mark] is raised). * The writing functions of this module do not generate BOMs, * however, as there is no way to tell them that a BOM is needed. The * function [byte_order_mark] can be used to output the BOM manually. * * {3 Examples for Cursors} * * Create the cursor: * * [ let cs = create_cursor `Enc_utf8 "B\195\164r";; ] * * The cursor is now positioned at the 'B': * * [ uchar_at cs ] {i returns} [66] (i.e. B) * * Move the cursor one character to the right. In UTF-8, this is a * two-byte character consisting of the bytes 195 and 164: * * [ move cs ;; ] * * [ uchar_at cs ] {i returns} [228] (i.e. a-Umlaut) * * One can easily move the cursor to the end of the string: * * [ move ~num:max_int cs ;; ] * * This raises [Cursor_out_of_range], but places the cursor at the end. * This is the position past the last letter 'r': * * [ uchar_at cs ] {i raises} [End_of_string] * * Go one character to the left: * * [ move ~num:(-1) cs ;; ] * * [ uchar_at cs ] {i returns} [114] (i.e. r) * * Cursors can only move relative to their current position. Of course, * one can easily write a function that moves to an absolute position, * like * * {[ let move_abs n cs = * let delta = n - cursor_pos cs in * move ~num:delta cs ]} * * However, this operation is expensive (O(string length)), and should * be avoided for efficient algorithms. Cursors are not arrays, and an * algorithm should only be based on cursors when it is possible to * iterate over the characters of the string one after another. *) (**********************************************************************) (* String functions *) (**********************************************************************) (** {2:unicode_functions Unicode String Functions} *) val ustring_length : encoding -> ?range_pos:int -> ?range_len:int -> string -> int (** Returns the length of the string in characters. The function fails * when illegal byte sequences or incomplete characters are found in the * string with [Malformed_code]. * * Evaluation hints: * - PRE_EVAL(encoding) * * @param range_pos The byte position of the substring to measure * (default: 0) * @param range_len The byte length of the substring to measure * (default: byte length of the input string minus [range_pos]) *) val ustring_length_ts : encoding -> ?range_pos:int -> ?range_len:int -> tstring -> int (** Same for tagged strings *) val ustring_length_poly : 's Netstring_tstring.tstring_ops -> encoding -> ?range_pos:int -> ?range_len:int -> 's -> int (** Polymorphic version *) val ustring_iter : encoding -> (int -> unit) -> ?range_pos:int -> ?range_len:int -> string -> unit (** Iterates over the characters of a string, and calls the passed function * for every code point. The function raises [Malformed_code] when * illegal byte sequences or incomplete characters are found. * * @param encoding specifies the encoding * @param range_pos The byte position of the substring to iterate over * (default: 0) * @param range_len The byte length of the substring to iterate over * (default: byte length of the input string minus [range_pos]) *) val ustring_iter_ts : encoding -> (int -> unit) -> ?range_pos:int -> ?range_len:int -> tstring -> unit (** Same for tagged strings *) val ustring_iter_poly : 's Netstring_tstring.tstring_ops -> encoding -> (int -> unit) -> ?range_pos:int -> ?range_len:int -> 's -> unit (** Polymorphic version *) val ustring_map : encoding -> (int -> int list) -> ?range_pos:int -> ?range_len:int -> string -> string (** Maps every character of a string to a list of characters, and returns * the concatenated string. * The [encoding] argument determines the encoding of both the argument * and the result string. * The map function gets every character as its Unicode code point, and * must return the list of code points to map to. * * The function raises [Malformed_code] when * illegal byte sequences or incomplete characters are found. * * @param range_pos The byte position of the substring to map * (default: 0) * @param range_len The byte length of the substring to map * (default: byte length of the input string minus [range_pos]) *) val ustring_map_ts : encoding -> (int -> int list) -> ?range_pos:int -> ?range_len:int -> tstring -> tstring (** Same for tagged strings. The output representation is the same as for the input *) val ustring_map_poly : 's Netstring_tstring.tstring_ops -> 't Netstring_tstring.tstring_kind -> encoding -> (int -> int list) -> ?range_pos:int -> ?range_len:int -> 's -> 't (** Polymorphic version *) val ustring_to_lower : encoding -> ?range_pos:int -> ?range_len:int -> string -> string (** Converts the input string to lowercase. The [encoding], [range_pos], and [range_len] arguments work as for [ustring_map]. The exception [Malformed_code] is raised when illegal byte sequences are found. *) val ustring_to_lower_ts : encoding -> ?range_pos:int -> ?range_len:int -> tstring -> tstring (** Same for tagged strings. The output representation is the same as for the input *) val ustring_to_lower_poly : 's Netstring_tstring.tstring_ops -> 't Netstring_tstring.tstring_kind -> encoding -> ?range_pos:int -> ?range_len:int -> 's -> 't (** Polymorphic version *) val ustring_to_upper : encoding -> ?range_pos:int -> ?range_len:int -> string -> string (** Converts the input string to uppercase. The [encoding], [range_pos], and [range_len] arguments work as for [ustring_map]. The exception [Malformed_code] is raised when illegal byte sequences are found. *) val ustring_to_upper_ts : encoding -> ?range_pos:int -> ?range_len:int -> tstring -> tstring (** Same for tagged strings. The output representation is the same as for the input *) val ustring_to_upper_poly : 's Netstring_tstring.tstring_ops -> 't Netstring_tstring.tstring_kind -> encoding -> ?range_pos:int -> ?range_len:int -> 's -> 't (** Polymorphic version *) val ustring_to_title : encoding -> ?range_pos:int -> ?range_len:int -> string -> string (** Converts the input string to titlecase. The [encoding], [range_pos], and [range_len] arguments work as for [ustring_map]. The exception [Malformed_code] is raised when illegal byte sequences are found. *) val ustring_to_title_ts : encoding -> ?range_pos:int -> ?range_len:int -> tstring -> tstring (** Same for tagged strings. The output representation is the same as for the input *) val ustring_to_title_poly : 's Netstring_tstring.tstring_ops -> 't Netstring_tstring.tstring_kind -> encoding -> ?range_pos:int -> ?range_len:int -> 's -> 't (** Polymorphic version *) val ustring_sub : encoding -> int -> int -> ?range_pos:int -> ?range_len:int -> string -> string (** [ustring_sub enc start length s]: Returns the substring of [s] starting * at character count [start] and consisting of [length] characters. Note * that [start] and [length] select the substring by multiples of * (usually multibyte) characters, not bytes. * * If the optional byte-based [range_pos] and [range_len] arguments are * present, these arguments are taken to determine a first substring * before [start] and [length] are applied to extract the final * substring. * * The function raises [Malformed_code] when * illegal byte sequences or incomplete characters are found. * * @param range_pos The byte position of the substring to extract * (default: 0) * @param range_len The byte length of the substring to extract * (default: byte length of the input string minus [range_pos]) *) val ustring_sub_ts : encoding -> int -> int -> ?range_pos:int -> ?range_len:int -> tstring -> tstring (** Same for tagged strings. The output representation is the same as for the input *) val ustring_sub_poly : 's Netstring_tstring.tstring_ops -> 't Netstring_tstring.tstring_kind -> encoding -> int -> int -> ?range_pos:int -> ?range_len:int -> 's -> 't (** Polymorphic version *) val ustring_compare : encoding -> (int -> int -> int) -> ?range_pos:int -> ?range_len:int -> string -> ?range_pos:int -> ?range_len:int -> string -> int (** Compares two strings lexicographically. The first argument is the * encoding of both strings (which must be the same). The second argument * is the function that compares two Unicode code points. It must return * 0 if both characters are the same, a negative value if the first * character is the smaller one, and a positive value if the second * character is the smaller one. * * The function raises [Malformed_code] when * illegal byte sequences or incomplete characters are found. * * @param range_pos The byte position of the substring to compare * (default: 0), referring to the following string argument * @param range_len The byte length of the substring to compare * (default: byte length of the input string minus [range_pos]), * referring to the following string argument *) val ustring_compare_ts : encoding -> (int -> int -> int) -> ?range_pos:int -> ?range_len:int -> tstring -> ?range_pos:int -> ?range_len:int -> tstring -> int (** Same for tagged strings *) val ustring_compare_poly : 's1 Netstring_tstring.tstring_ops -> 's2 Netstring_tstring.tstring_ops -> encoding -> (int -> int -> int) -> ?range_pos:int -> ?range_len:int -> 's1 -> ?range_pos:int -> ?range_len:int -> 's2 -> int (** Polymorphic version *) val code_cmp : int -> int -> int (** A compare function for [ustring_compare]: Normal string comparison: This function compares by code point *) val ci_code_cmp : int -> int -> int (** A compare function for [ustring_compare]: Case-insensitive comparison: This function compares by the lowercase code point if it exists, and the untransformed code point otherwise. NB. This bases on the lowercase transformation that maps one char to only one char, and not to many. *) val uarray_of_ustring : encoding -> ?range_pos:int -> ?range_len:int -> string -> int array (** Returns the characters of the string as array of Unicode code points. * * @param range_pos The byte position of the substring to extract * (default: 0) * @param range_len The byte length of the substring to extract * (default: byte length of the input string minus [range_pos]) *) val uarray_of_ustring_ts : encoding -> ?range_pos:int -> ?range_len:int -> tstring -> int array (** Same for tagged strings *) val uarray_of_ustring_poly : 's Netstring_tstring.tstring_ops -> encoding -> ?range_pos:int -> ?range_len:int -> 's -> int array (** Polymorphic version *) val ustring_of_uarray : ?subst:(int -> string) -> encoding -> ?pos:int -> ?len:int -> int array -> string (** Returns the array of Unicode code points as encoded string. * * @param pos Selects a subarray: [pos] is the first array position * to encode (default: 0) * @param len Selects a subarray: [len] is the length of the subarray * to encode (default: array length minus [pos]) * @param subst This function is called when a code point cannot be represented * in the chosen character encoding. It must returns the (already encoded) * string to substitute for this code point. By default * (if ~subst is not passed), the exception [Cannot_represent] * will be raised in this case. *) exception Malformed_code_at of int (** An illegal byte sequence is found at this byte position *) val verify : encoding -> ?range_pos:int -> ?range_len:int -> string -> unit (** Checks whether the string is properly encoded. If so, () is returned. * If not, the exception [Malformed_code_at] will be raised indicating * the byte position where the problem occurs. * * @param range_pos The byte position of the substring to verify * (default: 0) * @param range_len The byte length of the substring to verify * (default: byte length of the input string minus [range_pos]) *) val verify_ts : encoding -> ?range_pos:int -> ?range_len:int -> tstring -> unit (** Same for tagged strings *) val verify_poly : 's Netstring_tstring.tstring_ops -> encoding -> ?range_pos:int -> ?range_len:int -> 's -> unit (** Polymorphic version *) (**********************************************************************) (* Internal *) (**/**) val big_slice : int (* The length of the normal cursor slices. A "small slice" has always * length 1. *) type poly_reader = { read : 's . 's Netstring_tstring.tstring_ops -> int array -> int array -> 's -> int -> int -> (int * int * encoding) } val read_iso88591_ref : (int -> encoding -> poly_reader) ref val read_iso88591 : int -> encoding -> poly_reader val read_utf8_ref : (bool -> poly_reader) ref val read_utf8 : bool -> poly_reader (* The two read_* variables are initialised with default implementations. * They are overriden by Netaccel (if linked) *) val internal_name : charset -> string (* map charset to the key used in the lookup table *) ocamlnet-4.1.6/src/netstring/netdate.ml0000644000175000017500000007622313274252307016551 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) (* Thanks to Nicolas George for contributing the parsing and format code *) open Printf (* Calculate local zone offset in minutes *) let get_localzone_at t = let gt = Unix.gmtime t and lt = Unix.localtime t in let min_diff = (lt.Unix.tm_hour * 60 + lt.Unix.tm_min) - (gt.Unix.tm_hour * 60 + gt.Unix.tm_min) in let day_diff = lt.Unix.tm_yday - gt.Unix.tm_yday in if day_diff < -1 || day_diff = 1 then (* local day is UTC day + 1 *) min_diff + 24*60 else if day_diff > 1 || day_diff = -1 then (* local day is UTC day - 1 *) min_diff - 24*60 else (* local day is UTC day *) min_diff ;; let get_localzone() = get_localzone_at (Unix.time()) ;; let localzone_nodst = (* Get the timezone on 01-01-1970 and on 01-07-1970, and take the smaller one. This hopefully works on the northern and southern hemisphere *) min (get_localzone_at 0.0) (get_localzone_at 15638400.0) ;; let localzone = get_localzone() ;; type localization = { full_day_names : string array; abbr_day_names : string array; parsed_day_names : string list array; full_month_names : string array; abbr_month_names : string array; parsed_month_names : string list array; timezone_names : (string * int * bool) list; am_particle : string; pm_particle : string; d_format : string; t_format : string; d_t_format : string; t_format_ampm : string; char_encoding : string; } let posix_l9n = { full_day_names = [| "Sunday"; "Monday"; "Tuesday"; "Wednesday"; "Thursday"; "Friday"; "Saturday" |]; abbr_day_names = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |] ; parsed_day_names = [| [ "sunday"; "sun" ]; [ "monday"; "mon" ]; [ "tuesday"; "tue"; "tues" ]; [ "wednesday"; "wed"; "wednes" ]; [ "thursday"; "thu"; "thur"; "thurs" ]; [ "friday"; "fri" ]; [ "saturday"; "sat" ]; |]; full_month_names = [| "January"; "February"; "March"; "April"; "May"; "June"; "July"; "August"; "September"; "October"; "November"; "December" |]; abbr_month_names = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]; parsed_month_names = [| [ "january"; "jan" ]; [ "february"; "feb" ]; [ "march"; "mar" ]; [ "april"; "apr" ]; [ "may"; "may" ]; [ "june"; "jun" ]; [ "july"; "jul" ]; [ "august"; "aug" ]; [ "september"; "sep"; "sept" ]; [ "october"; "oct" ]; [ "november"; "nov" ]; [ "december"; "dec" ] |]; timezone_names = (* For a more complete list see http://en.wikipedia.org/wiki/List_of_time_zone_abbreviations We HAVE to implement the timezones mentioned in RFC-822 *) ( let z n = (n/100) * 60 in [ "gmt", z 0000, false; "ut", z 0000, false; "utc", z 0000, false; "wet", z 0000, false; "z", z 0000, false; "bst", z 0100, true; "cet", z 0100, false; "cest", z 0200, true; "met", z 0100, false; "mewt", z 0100, false; "mest", z 0200, true; "mesz", z 0200, true; "swt", z 0100, false; "sst", z 0200, true; "fwt", z 0100, false; "fst", z 0100, true; "eet", z 0200, false; "bt", z 0300, false; "zp4", z 0400, false; "zp5", z 0500, false; "zp6", z 0600, false; "wast", z 0700, false; "wadt", z 0800, true; "cct", z 0800, false; "jst", z 0900, false; "east", z 1000, false; "eadt", z 1100, true; "gst", z 1000, false; "nzt", z 1200, false; "nzst", z 1200, false; "nzdt", z 1300, true; "idle", z 1200, false; "idlw", z(-1200), false; "nt", z(-1100), false; "hst", z(-1000), false; "hdt", z(-0900), true; "cat", z(-1000), false; "ahst", z(-1000), false; "ydt", z(-0800), true; "yst", z(-0900), false; "pst", z(-0800), false; "pdt", z(-0700), true; "mst", z(-0700), false; "mdt", z(-0600), true; "cst", z(-0600), false; "cdt", z(-0500), true; "est", z(-0500), false; "edt", z(-0400), true; "ast", z(-0400), false; "adt", z(-0300), true; "wat", z(-0100), false; "at", z(-0200), false; ]); am_particle = "am"; pm_particle = "pm"; d_format = "%m/%d/%y"; t_format = "%H:%M:%S"; d_t_format = "%a %b %e %H:%M:%S %Y"; t_format_ampm = "%I:%M:%S %p"; char_encoding = "US-ASCII"; } let l9n_from_locale name = let open Netsys_posix in try let info = Netsys_posix.query_langinfo name in let enc = Netconversion.encoding_of_string info.nl_CODESET in let to_lower = Netconversion.ustring_to_lower enc in { full_day_names = [| info.nl_DAY_1; info.nl_DAY_2; info.nl_DAY_3; info.nl_DAY_4; info.nl_DAY_5; info.nl_DAY_6; info.nl_DAY_7; |]; abbr_day_names = [| info.nl_ABDAY_1; info.nl_ABDAY_2; info.nl_ABDAY_3; info.nl_ABDAY_4; info.nl_ABDAY_5; info.nl_ABDAY_6; info.nl_ABDAY_7; |]; parsed_day_names = [| [ to_lower info.nl_DAY_1; to_lower info.nl_ABDAY_1 ]; [ to_lower info.nl_DAY_2; to_lower info.nl_ABDAY_2 ]; [ to_lower info.nl_DAY_3; to_lower info.nl_ABDAY_3 ]; [ to_lower info.nl_DAY_4; to_lower info.nl_ABDAY_4 ]; [ to_lower info.nl_DAY_5; to_lower info.nl_ABDAY_5 ]; [ to_lower info.nl_DAY_6; to_lower info.nl_ABDAY_6 ]; [ to_lower info.nl_DAY_7; to_lower info.nl_ABDAY_7 ]; |]; full_month_names = [| info.nl_MON_1; info.nl_MON_2; info.nl_MON_3; info.nl_MON_4; info.nl_MON_5; info.nl_MON_6; info.nl_MON_7; info.nl_MON_8; info.nl_MON_9; info.nl_MON_10; info.nl_MON_11; info.nl_MON_12; |]; abbr_month_names = [| info.nl_ABMON_1; info.nl_ABMON_2; info.nl_ABMON_3; info.nl_ABMON_4; info.nl_ABMON_5; info.nl_ABMON_6; info.nl_ABMON_7; info.nl_ABMON_8; info.nl_ABMON_9; info.nl_ABMON_10; info.nl_ABMON_11; info.nl_ABMON_12; |]; parsed_month_names = [| [ to_lower info.nl_MON_1; to_lower info.nl_ABMON_1 ]; [ to_lower info.nl_MON_2; to_lower info.nl_ABMON_2 ]; [ to_lower info.nl_MON_3; to_lower info.nl_ABMON_3 ]; [ to_lower info.nl_MON_4; to_lower info.nl_ABMON_4 ]; [ to_lower info.nl_MON_5; to_lower info.nl_ABMON_5 ]; [ to_lower info.nl_MON_6; to_lower info.nl_ABMON_6 ]; [ to_lower info.nl_MON_7; to_lower info.nl_ABMON_7 ]; [ to_lower info.nl_MON_8; to_lower info.nl_ABMON_8 ]; [ to_lower info.nl_MON_9; to_lower info.nl_ABMON_9 ]; [ to_lower info.nl_MON_10; to_lower info.nl_ABMON_10 ]; [ to_lower info.nl_MON_11; to_lower info.nl_ABMON_11 ]; [ to_lower info.nl_MON_12; to_lower info.nl_ABMON_12 ]; |]; timezone_names = posix_l9n.timezone_names; am_particle = to_lower info.nl_AM_STR; pm_particle = to_lower info.nl_PM_STR; d_format = info.nl_D_FMT; t_format = info.nl_T_FMT; d_t_format = info.nl_D_T_FMT; t_format_ampm = info.nl_T_FMT_AMPM; char_encoding = info.nl_CODESET } with | _ -> posix_l9n type token = | Number of int * int (* number of digits, value *) | Day of int | Month of int | Meridian of bool | Zone of int * bool | Dst | Plus | Minus | Comma | Colon | Slash | Dot | Time (* "T" *) | Invalid ;; type compiled_localization = { l9n : localization; tokens : (string, token) Hashtbl.t } let compile_l9n l9n = let tokens = Hashtbl.create 53 in let add_token (name, value) = Hashtbl.replace tokens name value in List.iter (fun (name,zone,isdst) -> add_token (name, (Zone(zone,isdst))) ) l9n.timezone_names; add_token (l9n.am_particle, Meridian false); add_token (l9n.pm_particle, Meridian true); Array.iteri (fun i names -> List.iter (fun name -> add_token (name, Month(i+1)) ) names ) l9n.parsed_month_names; Array.iteri (fun i names -> List.iter (fun name -> add_token (name, Day i) ) names ) l9n.parsed_day_names; add_token ("t", Time); add_token ("dst", Dst); { l9n = l9n; tokens = tokens } let c_posix_l9n = compile_l9n posix_l9n let rec ten_power n = if n<=0 then 1 else 10 * (ten_power (n-1)) let to_lower cl9n = try let enc = Netconversion.encoding_of_string cl9n.l9n.char_encoding in fun s -> Netconversion.ustring_to_lower enc s with _ -> (fun s -> s) let to_upper cl9n = try let enc = Netconversion.encoding_of_string cl9n.l9n.char_encoding in fun s -> Netconversion.ustring_to_upper enc s with _ -> (fun s -> s) let stream_cons prefix stream = (* Prefix the list [prefix] before stream *) let prefix = ref prefix in Stream.from (fun _ -> match !prefix with | [] -> ( try Some(Stream.next stream) with Stream.Failure -> None ) | p :: prefix' -> prefix := prefix'; Some p ) let stream_njunk n stream = for k = 1 to n do Stream.junk stream done let tokens_of_string cl9n str = let to_lower = to_lower cl9n in let rec scan_any stream = match Stream.peek stream with | Some('0'..'9' as c) -> Stream.junk stream; scan_number (1, int_of_char c - 48) stream | Some(('a'..'z' | 'A'..'Z' | '\128'..'\255') as c) -> Stream.junk stream; let b = Buffer.create 16 in Buffer.add_char b c; scan_word b stream | Some '(' -> Stream.junk stream; scan_comment 0 stream | Some (' ' | '\t') -> Stream.junk stream; scan_any stream | Some '+' -> Stream.junk stream; stream_cons [ Plus ] (scan_any stream) | Some '-' -> Stream.junk stream; stream_cons [ Minus ] (scan_any stream) | Some ':' -> Stream.junk stream; stream_cons [ Colon ] (scan_any stream) | Some ',' -> Stream.junk stream; stream_cons [ Comma ] (scan_any stream) | Some '/' -> Stream.junk stream; stream_cons [ Slash ] (scan_any stream) | Some '.' -> Stream.junk stream; stream_cons [ Dot ] (scan_any stream) | Some _ -> Stream.junk stream; stream_cons [ Invalid ] (scan_any stream) | None -> Stream.of_list [] and scan_number (l,a) stream = match Stream.peek stream with | Some ( ('0'..'9') as c ) -> Stream.junk stream; if l = 9 then failwith "Netdate: number too large"; scan_number (l+1, a * 10 + (int_of_char c - 48)) stream | _ -> stream_cons [ Number(l,a) ] (scan_any stream) and scan_word b stream = match Stream.peek stream with | Some(('a'..'z' | 'A'..'Z' | '\128'..'\255') as c) -> Stream.junk stream; Buffer.add_char b c; scan_word b stream | Some '.' -> Stream.junk stream; scan_word b stream | _ -> let s = to_lower (Buffer.contents b) in let tok = try Hashtbl.find cl9n.tokens s with Not_found -> Invalid in stream_cons [ tok ] (scan_any stream) and scan_comment n stream = match Stream.peek stream with | Some ')' -> Stream.junk stream; if n=0 then scan_any stream else scan_comment (n-1) stream | Some '(' -> Stream.junk stream; scan_comment (n+1) stream | Some _ -> Stream.junk stream; scan_comment n stream | None -> raise Stream.Failure in scan_any (Stream.of_string str) ;; type t = { year : int; (* complete year *) month : int; (* 1..12 *) day : int; (* 1..31 *) hour : int; minute : int; second : int; nanos : int; zone : int; (* in minutes; 60 = UTC+0100 *) week_day : int (* 0 = sunday; -1 if not given *) } ;; let parse ?(localzone=false) ?zone:dzone ?(l9n = c_posix_l9n) str = let invalid() = invalid_arg "Netdate.parse" in let tokens = tokens_of_string l9n str in let hour = ref None and minute = ref None and second = ref None and nanos = ref None and zone = ref None and week_day = ref None and day = ref None and month = ref None and year = ref None in let add_data ?h ?m ?s ?ns ?mdn ?tz ?wd ?md ?mo ?y ?y2 () = (* tz as in the above table *) let may_store r = function | None -> () | v when !r = None -> r := v | _ -> invalid() in let h = match h with | None -> None | Some h -> match mdn with | None when h >= 0 && h <= 23 -> Some h | Some false when h > 0 && h <= 11 -> Some h | Some false when h = 12 -> Some 0 | Some true when h > 0 && h <= 11 -> Some (h + 12) | Some true when h = 12 -> Some 12 | _ -> invalid() in let y = match y with | None -> ( match y2 with | Some y -> if y < 69 then Some (2000 + y) else Some(1900 + y) | None -> None ) | Some y -> Some y in may_store hour h; may_store minute m; may_store second s; may_store nanos ns; may_store zone tz; may_store week_day wd; may_store day md; may_store month mo; may_store year y in let rec scan_gen stream = match Stream.peek stream with | Some(Number(l,n)) -> Stream.junk stream; scan_number (l,n) stream | Some Time -> Stream.junk stream; let tok1 = Stream.next stream in let tok2 = Stream.next stream in let tok3 = Stream.next stream in ( match tok1,tok2,tok3 with | Number((0|1|2),n), Colon, Number((0|1|2),m) -> scan_hour n m stream | _ -> invalid() ) | Some(Zone(tz,isdst)) -> Stream.junk stream; let dst = scan_dst stream in let eff_tz = if isdst then tz else match dst with | Some true -> tz + 60 | _ -> tz in add_data ~tz:eff_tz (); scan_gen stream | Some(Day wd) -> Stream.junk stream; let _ = scan_opt_coma stream in add_data ~wd (); scan_gen stream | Some(Month mo) -> Stream.junk stream; let tok1 = Stream.next stream in ( match tok1 with | Number(lmd,md) -> scan_date_m mo (lmd,md) stream | _ -> invalid() ) | Some _ -> Stream.junk stream; invalid() | None -> () and scan_number (l,n) stream = match Stream.peek stream with | Some(Meridian mdn) -> Stream.junk stream; add_data ~h:n ~mdn (); scan_gen stream | Some Colon -> Stream.junk stream; let tok1 = Stream.next stream in ( match tok1 with | Number((0|1|2),m) -> if l <= 2 then scan_hour n m stream else invalid() | _ -> invalid() ) | Some Slash -> Stream.junk stream; let tok1 = Stream.next stream in ( match tok1 with | Number((0|1|2),m) -> scan_date_s (l,n) m stream | _ -> invalid() ) | Some Dot -> Stream.junk stream; let tok1 = Stream.next stream in ( match tok1 with | Number((0|1|2),m) -> if l<=2 then scan_date_dot n m stream else invalid() | _ -> invalid() ) | Some Minus -> Stream.junk stream; scan_date_d (l,n) stream | Some (Month mo) -> Stream.junk stream; add_data ~md:n ~mo (); scan_gen stream | _ -> if l=4 then add_data ~y:n () else invalid(); scan_gen stream and scan_hour h m stream = match Stream.peek stream with | Some Colon -> Stream.junk stream; let tok1 = Stream.next stream in ( match tok1 with | Number(_,s) -> scan_hour_second_frac h m s stream | _ -> invalid() ) | _ -> let tz_opt = scan_tz_opt stream in ( match tz_opt with | Some tz -> add_data ~h ~m ~tz (); scan_gen stream | None -> let mdn = scan_opt_meridian stream in add_data ~h ~m ?mdn (); scan_gen stream ) and scan_tz_opt stream = match Stream.peek stream with | Some Plus -> Stream.junk stream; Some(scan_tz_details 1 stream) | Some Minus -> Stream.junk stream; Some(scan_tz_details (-1) stream) | _ -> None and scan_tz_details sign stream = match Stream.peek stream with | Some(Number(l,tz)) when l=4 -> Stream.junk stream; sign * ((tz/100) * 60 + (tz mod 100)) | Some(Number(l,tz)) when l<=2 -> Stream.junk stream; scan_tz_details2 sign tz stream | _ -> invalid() and scan_tz_details2 sign tz1 stream = match Stream.npeek 2 stream with | [ Colon; Number((0|1|2),tz2) ] -> stream_njunk 2 stream; sign * (60 * tz1 + tz2) | _ -> sign * 60 * tz1 and scan_hour_second_frac h m s stream = match Stream.npeek 2 stream with | [ Dot; Number(l,f) ] -> (* e.g. 12:50:48.12345 *) stream_njunk 2 stream; let ns = f * ten_power (9-l) in scan_hour_second h m s ns stream | _ -> scan_hour_second h m s 0 stream and scan_hour_second h m s ns stream = match scan_tz_opt stream with | Some tz -> add_data ~h ~m ~s ~ns ~tz (); scan_gen stream | None -> let mdn = scan_opt_meridian stream in add_data ~h ~m ~s ~ns ?mdn (); scan_gen stream and scan_date_s (ln,n) m stream = match Stream.npeek 2 stream with | [ Slash; Number(lp,p) ] -> stream_njunk 2 stream; if ln = 4 then add_data ~y:n ~mo:m ~md:p () else if lp = 4 then add_data ~y:p ~mo:n ~md:m () else if lp = 2 then add_data ~y2:p ~mo:n ~md:m () else invalid(); scan_gen stream | _ -> add_data ~mo:n ~md:m (); scan_gen stream and scan_date_dot n m stream = match Stream.npeek 2 stream with | [ Dot; Number(l,p) ] -> stream_njunk 2 stream; if l=4 then add_data ~md:n ~mo:m ~y: p () else if l=2 then add_data ~md:n ~mo:m ~y2: p () else invalid(); scan_gen stream | _ -> add_data ~md:n ~mo:m (); scan_gen stream and scan_date_d (ln,n) stream = match Stream.npeek 3 stream with | [ Number(_,mo); Minus; Number(_,md) ] -> stream_njunk 3 stream; if ln=4 then add_data ~y:n ~mo ~md () else if ln=2 then add_data ~y2:n ~mo ~md () else invalid(); scan_gen stream | [ Month mo; Minus; Number(ly,y) ] -> stream_njunk 3 stream; if ly=4 then add_data ~y ~mo ~md:n () else if ly=2 then add_data ~y2:y ~mo ~md:n () else invalid(); scan_gen stream | _ -> invalid() and scan_date_m mo (lmd,md) stream = match Stream.npeek 2 stream with | [ Comma; Number(4,y) ] -> stream_njunk 2 stream; add_data ~y ~mo ~md (); scan_gen stream | _ -> add_data ~mo ~md (); scan_gen stream and scan_dst stream = match Stream.peek stream with | Some Dst -> Stream.junk stream; Some true | _ -> None and scan_opt_coma stream = match Stream.peek stream with | Some Comma -> Stream.junk stream; () | _ -> () and scan_opt_meridian stream = match Stream.peek stream with | Some (Meridian mdn) -> Stream.junk stream; Some mdn | _ -> None in (try scan_gen tokens; with | Stream.Error _ -> invalid() | Stream.Failure -> invalid() ); let may_get r = match !r with | None -> invalid() | Some r -> r in let get_default d r = match !r with | None -> d | Some r -> r in let month = may_get month in if month < 1 || month > 12 then invalid(); let date = { year = may_get year; month = month; day = may_get day; hour = get_default 0 hour; minute = get_default 0 minute; second = get_default 0 second; nanos = get_default 0 nanos; zone = get_default (match dzone with None -> 0 | Some z -> z) zone; week_day = get_default (-1) week_day } in if !zone=None && dzone=None && localzone then let tm = { Unix.tm_year = date.year - 1900; tm_mon = date.month - 1; tm_mday = date.day; tm_hour = date.hour; tm_min = date.minute; tm_sec = date.second; tm_wday = 0; tm_yday = 0; tm_isdst = false } in let (_,tm) = Unix.mktime tm in let zone = localzone_nodst + (if tm.Unix.tm_isdst then 60 else 0) in { date with zone = zone } else date ;; let months_start = [| 0; 31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334 |] ;; let is_leap year = year mod 4 = 0 && (year mod 100 <> 0 || year mod 400 = 0) ;; let since_epoch date = if date.month < 1 || date.month > 12 then invalid_arg "Netdate.since_epoch"; let in_day = float_of_int (date.hour * 3600 + (date.minute - date.zone) * 60 + date.second) in let days = date.year * 365 + (date.year + 3) / 4 - (date.year + 99) / 100 + (date.year + 399) / 400 - 719528 in let days = days + months_start.(date.month - 1) + date.day - 1 in let days = if is_leap date.year && date.month > 2 then days + 1 else days in 86400.0 *. (float_of_int days) +. in_day ;; let since_epoch_timespec date = (since_epoch date, date.nanos) let since_epoch_approx date = since_epoch date +. (float date.nanos) *. 1E-9 let parse_epoch ?l9n ?localzone ?zone str = since_epoch (parse ?l9n ?localzone ?zone str) ;; let parse_epoch_timespec ?l9n ?localzone ?zone str = since_epoch_timespec (parse ?l9n ?localzone ?zone str) ;; let parse_epoch_approx ?l9n ?localzone ?zone str = since_epoch_approx (parse ?l9n ?localzone ?zone str) ;; let billion = 1_000_000_000 let create ?(localzone=false) ?zone ?(nanos=0) time = (* Add nanos to time: *) let t0 = floor time in let ns0 = truncate ( (time -. t0) *. 1E9 ) in let ns1 = if ns0 >= billion - nanos then (nanos-billion)+ns0 else nanos+ns0 in let t1 = if ns0 >= billion - nanos then t0 +. 1.0 else t0 in let zone = match zone with | Some z -> z | None -> if localzone then get_localzone_at t1 else 0 in let t2 = t1 +. (float_of_int (zone * 60)) in let days = floor (t2 /. 86400.0) in let in_day = int_of_float (t2 -. 86400.0 *. days) in let days = days +. 719528.0 in let n400 = floor (days /. 146097.0) in let r400 = int_of_float (days -. n400 *. 146097.0) in let n400 = int_of_float n400 in let (n100, r100) = if r400 < 36525 then (0, r400) else ((r400 - 1) / 36524, (r400 - 1) mod 36524) in let (n4, r4) = if n100 = 0 then (r100 / 1461, r100 mod 1461) else if r100 < 1460 then (0, r100) else ((r100 + 1) / 1461, (r100 + 1) mod 1461) in let (n1, r1) = if n4 = 0 && n100 <> 0 then (r4 / 365, r4 mod 365) else if r4 < 366 then (0, r4) else ((r4 - 1) / 365, (r4 - 1) mod 365) in let year = 400 * n400 + 100 * n100 + 4 * n4 + n1 in let month_start = if is_leap year then fun m -> months_start.(m) + (if m > 1 then 1 else 0) else fun m -> months_start.(m) in let month_guess = r1 / 29 in let month = if month_guess = 12 then 11 else if r1 >= month_start month_guess then month_guess else month_guess - 1 in let second = in_day mod 60 and minutes = in_day / 60 in let minute = minutes mod 60 and hour = minutes / 60 in { year = year; month = month + 1; day = r1 - (month_start month) + 1; hour = hour; minute = minute; second = second; nanos = ns1; zone = zone; week_day = int_of_float (mod_float (days +. 6.0) 7.0) } ;; let week_day date = (* 0..6, relative to timezone *) if date.week_day = (-1) then let t1 = since_epoch date in let t2 = t1 +. (float_of_int (date.zone * 60)) in let days = floor (t2 /. 86400.0) in int_of_float (mod_float (days +. 4.0) 7.0) else date.week_day ;; let year_day date = (* 0..365, relative to timezone *) let is_leap_year = is_leap date.year in months_start.(date.month - 1) + (if date.month >= 3 && is_leap_year then 1 else 0) + date.day - 1 ;; let rec iso8601_week_pair date = let ( % ) a b = if a >= 0 then a mod b else a mod b + b in let d_wday = week_day date in let d_yday = year_day date in let wday_jan_1 = (* wday of jan 1 *) (d_wday - d_yday) % 7 in let shift = if wday_jan_1 = 1 then 7 else (wday_jan_1 - 1) % 7 in let offset = if wday_jan_1 >= 2 && wday_jan_1 <= 4 then 1 else 0 in let week = (d_yday + shift) / 7 + offset in if week = 0 then (* replace with last week of last year *) let date' = { date with year = date.year - 1; month = 12; day = 31; week_day = (-1) } in iso8601_week_pair date' else if week = 53 then (* only if dec 31 is a thu/fri/sat/sun *) let date' = { date with month = 12; day = 31; week_day = (-1) } in let d_wday' = week_day date' in if d_wday' >= 4 || d_wday' = 0 then (53, date.year) else (1, date.year+1) else (week, date.year) let rec format_to ?(l9n=c_posix_l9n) out_ch ~fmt date = let to_lower = to_lower l9n in let to_upper = to_upper l9n in let add_char c = out_ch#output_char c and add_string s = out_ch#output_string s in let fail () = invalid_arg "Netdate.format_to" in let add_digits w b n = if n >= b * 10 then fail (); let rec aux b n = add_char (char_of_int (48 + n / b)); if b >= 10 then aux (b / 10) (n mod b) in if w then ( let rec aux_spaces b = if n >= b || b < 10 then ( aux b n ) else ( add_char ' '; aux_spaces (b / 10) ) in aux_spaces b ) else ( aux b n ) in let wd_lz = lazy (week_day date) in let wd () = Lazy.force wd_lz in let yd_lz = lazy (year_day date) in let yd () = Lazy.force yd_lz in let wp_lz = lazy (iso8601_week_pair date) in let wp() = Lazy.force wp_lz in let rec do_format ?(have_colon=false) ?(precision=0) = function | 'a' -> add_string l9n.l9n.abbr_day_names.( wd() ) | 'A' -> add_string l9n.l9n.full_day_names.( wd() ) | 'b' | 'h' -> add_string l9n.l9n.abbr_month_names.(date.month - 1) | 'B' -> add_string l9n.l9n.full_month_names.(date.month - 1) | 'C' -> add_digits false 10 (date.year / 100) | 'd' -> add_digits false 10 date.day | 'e' -> add_digits true 10 date.day | 'g' -> add_digits false 10 (snd(wp()) mod 10) | 'G' -> add_digits false 1000 (snd(wp())) | 'H' -> add_digits false 10 date.hour | 'I' -> add_digits false 10 (match date.hour mod 12 with 0 -> 12 | d -> d) | 'j' -> add_digits false 100 (yd () + 1) | 'k' -> add_digits true 10 date.hour | 'l' -> add_digits true 10 (match date.hour mod 12 with 0 -> 12 | d -> d) | 'm' -> add_digits false 10 date.month | 'M' -> add_digits false 10 date.minute | 'n' -> add_char '\n' | 'p' -> add_string (if date.hour >= 12 then to_upper l9n.l9n.pm_particle else to_upper l9n.l9n.am_particle ) | 'P' -> add_string (if date.hour >= 12 then to_lower l9n.l9n.pm_particle else to_lower l9n.l9n.am_particle) | 's' -> add_string (string_of_float (since_epoch date)) | 'S' -> add_digits false 10 date.second; if precision > 0 then ( add_char '.'; add_string (sprintf "%0*d" precision (date.nanos / ten_power(9-precision))) ) | 't' -> add_char '\t' | 'u' -> add_digits false 1 (match wd () with 0 -> 7 | n -> n) | 'y' -> add_digits false 10 (date.year mod 100) | 'Y' -> add_digits false 1000 date.year | 'z' | 'Z' -> let (s, z) = if date.zone >= 0 then ('+', date.zone) else ('-', -date.zone) in add_char s; add_digits false 10 (z / 60); if have_colon then add_char ':'; add_digits false 10 (z mod 60) | 'U' -> add_digits false 10 ((yd () - wd () + 7) / 7) | 'V' -> add_digits false 10 (fst(wp())) | 'W' -> let wdm = if wd() = 0 then 6 else wd() - 1 in add_digits false 10 ((yd () - wdm + 7) / 7) | 'w' -> add_digits false 1 (wd ()) | '%' -> add_char '%' | 'c' -> format_to ~l9n out_ch ~fmt:l9n.l9n.d_t_format date | 'F' -> do_format 'Y'; add_char '-'; do_format 'm'; add_char '-'; do_format 'd' | 'x' -> format_to ~l9n out_ch ~fmt:l9n.l9n.d_format date | 'X' -> format_to ~l9n out_ch ~fmt:l9n.l9n.t_format date | 'D' -> do_format 'm'; add_char '/'; do_format 'd'; add_char '/'; do_format 'y' | 'r' -> format_to ~l9n out_ch ~fmt:l9n.l9n.t_format_ampm date | 'R' -> do_format 'H'; add_char ':'; do_format 'M' | 'T' -> do_format 'R'; add_char ':'; do_format 'S' | _ -> fail () in let l_fmt = String.length fmt in let rec aux i = if i = l_fmt then () else match fmt.[i] with | '%' when i = l_fmt - 1 -> fail () | '%' -> if fmt.[i + 1] = ':' then ( if i+2 >= l_fmt then fail(); do_format ~have_colon:true fmt.[i + 2]; aux (i + 3) ) else ( if fmt.[i + 1] = '.' then ( if i+3 >= l_fmt then fail(); match fmt.[i+2] with | '0'..'9' as c -> let d = Char.code c - 48 in do_format ~precision:d fmt.[i + 3]; aux (i + 4) | _ -> fail() ) else ( do_format fmt.[i + 1]; aux (i + 2) ) ) | c -> add_char c; aux (i + 1) in try aux 0 with _ -> fail () ;; let format ?l9n ~fmt date = let b = Buffer.create (String.length fmt * 2) in format_to ?l9n (new Netchannels.output_buffer b) ~fmt date; Buffer.contents b ;; (* The format routines above may want to support internationalization * in the future. The following must use the English conventions * described in the relevant RFCs. *) let mk_date ?localzone ?zone ?nanos ~fmt t = format ~fmt (create ?localzone ?zone ?nanos t) let mk_mail_date ?localzone ?zone t = format "%a, %d %b %Y %H:%M:%S %z" (create ?localzone ?zone t) ;; let mk_usenet_date ?localzone ?zone t = format "%A, %d-%b-%y %H:%M:%S %z" (create ?localzone ?zone t) ;; let mk_internet_date ?localzone ?zone ?(digits=0) t = if digits < 0 || digits > 9 then failwith "Netdate.mk_internet_date: digits out of bounds"; let fmt = sprintf "%%Y-%%m-%%dT%%H:%%M:%%.%dS%%:z" digits in format ~fmt (create ?localzone ?zone t) ;; ocamlnet-4.1.6/src/netstring/netdate.mli0000644000175000017500000003072113274252307016713 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) (** Support for common date/time parsing and formatting. * Many routines refer to the epoch, which for Unix is * 00:00:00 UTC, January 1, 1970. Timestamps given as * "seconds since the epoch" ignore leap seconds. *) type t = { year : int; (** complete year *) month : int; (** 1..12 *) day : int; (** 1..31 *) hour : int; (** 0..23 *) minute : int; (** 0..59 *) second : int; (** 0..60 (60=leapsecond) *) nanos : int; (** nanoseconds, new since Ocamlnet-3.5 *) zone : int; (** in minutes; 60 = UTC+0100 *) week_day : int (** 0 = sunday; -1 if not given *) } val localzone : int (** The offset in minutes for the local time zone from the UTC. This is the zone from the time when the program was started. For long-running programs, it is possible that the zone changes when daylight savings become effective or non-effective. *) val localzone_nodst : int (** Returns the offset for the local time zone for the case that daylight savings are not effective. *) val get_localzone : unit -> int (** Retrieves the current offset for the local time zone, taking daylight savings into account. *) val create : ?localzone:bool -> ?zone:int -> ?nanos:int -> float -> t (** Convert the time (seconds since the epoch) to a date/time record The [nanos] are added to the float as nanoseconds. If [zone] is set this zone is taken. Otherwise, if [localzone] is set, the local timezone is used that is valid at the requested time. Otherwise, UTC is used. Note that [create ~localzone:true t] is different from [create ~zone:(get_localzone()) t] because the latter assumes the timezone that is in effect when the function is called, and not the timezone at the time [t]. *) type localization = { full_day_names : string array; (** Element [k] contains the name of the week day [k] (0=Sunday) *) abbr_day_names : string array; (** Element [k] contains the abbreviated name of the week day [k] (0=Sunday) *) parsed_day_names : string list array; (** Element [k] contains a list of all possible names of the week day [k]. The list includes full and abbreviated names, but can also contain any other allowed name (aliases). The names here are in lowercase characters. *) full_month_names : string array; (** Element [k] contains the name of the month day [k] (0=January) *) abbr_month_names : string array; (** Element [k] contains the abbreviated name of the month day [k] (0=January) *) parsed_month_names : string list array; (** Element [k] contains a list of all possible names of the month [k]. The list includes full and abbreviated names, but can also contain any other allowed name (aliases). The names here are in lowercase characters. *) timezone_names : (string * int * bool) list; (** A list of pairs [(name,offset,isdst)] of timezones. The offset is in minutes. *) am_particle : string; (** A particle for "AM" *) pm_particle : string; (** A particle for "PM" *) d_format : string; (** Format string for date according to the locale *) t_format : string; (** Format string for time according to the locale *) d_t_format : string; (** Format string for date and time according to the locale *) t_format_ampm : string; (** Format string for time, using am and pm, according to the locale *) char_encoding : string; (** The character encoding of this locale *) } type compiled_localization val posix_l9n : localization (** The standard POSIX localization (English names) *) val l9n_from_locale : string -> localization (** Retrieves the localization from the passed locale (use "" for the standard locale). Timezone names are not provided by the locale This function is not available on Windows (the POSIX localization is always returned). *) val compile_l9n : localization -> compiled_localization (** Preprocess the localization data for faster parsing and printing *) val parse : ?localzone:bool -> ?zone:int -> ?l9n:compiled_localization -> string -> t (** Parse a string and return a date/time record. The following particles are recognized (by example): - Date: [1971/06/22] - Date: [06/22/1971] - Date: [1971-06-22] - Date: [22-June-1971] - Date: [22.06.1971] - Date: [June 22, 1971] - Date: [22 June 1971] - Date (2 digit year): [06/22/71] - Date (2 digit year): [22.06.71] - Date (2 digit year): [71-06-22] - Date (2 digit year): [22-June-71] - Month names ([June], [Jun]) - Weekday names ([Monday], [Mon]) - Time: [14:55] - Time: [14:55:28] - Time: [14:55:28.6754] (the fractional part is not returned) - Time may be preceded by [T] - Time zone: identifiers like [UTC], [CET], or [Z] - Time zone: [+01:00], [-01:00], only following time - Time zone: [+0100], [-0100], only following time Years must have 2 or 4 digits. 2-digit years >= 70 are interpreted as [1900+x]. 2-digit years < 70 are interpreted as [2000+x]. Support for 2-digit years will be removed in a future version of Ocamlnet. (Support for 3-digit years is already removed in Ocamlnet 3.0.) The names of months and weekdays are recognized that are configured with the [l9n] argument. By default, English names are recognized. A date must be given. Time, time zones, and weekdays are optional. A missing time is reported as "00:00:00". A missing weekday is reported by setting [week_day=(-1)]. A missing time zone is reported by setting [zone] to the passed default (which is determined from the [zone] and [localzone] arguments as for [create]). It is not checked whether the parsed numbers make sense (e.g. whether months are between 1 and 12). Date/time strings as defined in RFC 3339 are supported since Ocamlnet 3.0. *) val since_epoch : t -> float (** Convert a date/time record into the time (seconds since the epoch), rounded down to the next integral number. *) val since_epoch_timespec : t -> (float * int) (** Returns the seconds since the epoch as pair [(seconds,nanos)] *) val since_epoch_approx : t -> float (** Same, but the nanos are added to the seconds. The precision of floats is not sufficient to represent this precisely, so the result is only an approximation. *) val week_day : t -> int (** Returns the week day. If the [week_day] field is (-1) the week day is computed. *) val year_day : t -> int (** Returns the year day (range 0 to 365) *) val iso8601_week_pair : t -> int * int (** Returns [(week_number, year)] for the ISO-8601 definition of weeks. The week starts with Monday, and has numbers 1-53. A week is considered to be part of the year into which four or more days fall. *) val parse_epoch : ?l9n:compiled_localization -> ?localzone:bool -> ?zone:int -> string -> float (** Parse a string and return the time (integral seconds since the epoch) *) val parse_epoch_timespec : ?l9n:compiled_localization -> ?localzone:bool -> ?zone:int -> string -> float * int (** Parse a string and return the time (seconds and nanos since the epoch) *) val parse_epoch_approx : ?l9n:compiled_localization -> ?localzone:bool -> ?zone:int -> string -> float (** Parse a string and return the time (approximate seconds since the epoch) *) val format_to : ?l9n:compiled_localization -> Netchannels.out_obj_channel -> fmt:string -> t -> unit (** Format a date/time record according to the format string and outputs * the resulting string to the channel. * * The format string consists of zero or more conversion specifications * and ordinary characters. All ordinary characters are output directly * to the channel. A conversion specification consists of the '%' * character and one other character. * * The conversion specifications are: * * - [%A]: full weekday name. * - [%a]: abbreviated weekday name. * - [%B]: full month name. * - [%b]: abbreviated month name. * - [%C]: (year / 100) as an integer; single digits are preceded by a zero. * - [%c]: the preferred date+time representation of [l9n] * - [%D]: equivalent to ["%m/%d/%y"]. * - [%d]: day of the month as an integer (01-31); single digits are * preceded by a zero. * - [%e]: day of the month as an integer (1-31). * - [%F]: equivalent to ["%Y-%m-%d"] (ISO 8601) * - [%G]: the year of the week according to the ISO-8601 week definition * - [%g]: same as %G but uses a two-digit year * - [%H]: hour (24-hour clock) as an integer (00-23). * - [%h]: the same as %b. * - [%I]: hour (12-hour clock) as an integer (01-12). * - [%j]: day of the year as an integer (001-366). * - [%k]: hour (24-hour clock) as an integer (0-23); * single digits are preceded by a blank. * - [%l]: hour (12-hour clock) as an integer (1-12); * single digits are preceded by a blank. * - [%M]: minute as an integer (00-59). * - [%m]: month as an integer (01-12). * - [%n]: a newline. * - [%p]: "AM" or "PM" as defined in [l9n], in uppercase * - [%P]: "am" or "pm" as defined in [l9n], in lowercase * - [%R]: equivalent to ["%H:%M"]. * - [%r]: the time in am/pm notation according to [l9n] * - [%S]: second as an integer (00-60). This format accepts a precision argument, e.g. [%.3S] to print the second with three digits after the dot. * - [%s]: number of seconds since the epoch * - [%T]: equivalent to ["%H:%M:%S"]. * - [%t]: a tab. * - [%U]: week number of the year (Sunday as the first day * of the week) as an integer (00-53). * - [%u] weekday (Monday as the first day of the week) as * an integer (1-7). * - [%V]: week number of the year (ISO-8601 definition, use together with * [%G] or [%g] * - [%W]: week number of the year (Monday as the first day * of the week) as an integer (00-53). * - [%w]: weekday (Sunday as the first day of the week) as * an integer (0-6). * - [%X]: representation of the time according to [l9n] * - [%x]: representation of the date according to [l9n] * - [%Y]: year with century as an integer. * - [%y]: year without century as an integer (00-99). * - [%z]: time zone offset from UTC; a leading plus sign * stands for east of UTC, a minus sign for west of UTC, hours and * minutes follow with two digits each and no delimiter between them * (common form for RFC 822 date headers). * - [%Z]: same as [%z] * - [%:z]: time zone with colon, e.g. +05:00 (new since Ocamlnet 3) * - [%%]: a `%' character. * * If [l9n] is not passed, the default is the POSIX localization * (English names). *) val format : ?l9n:compiled_localization -> fmt:string -> t -> string (** Format a date/time record as a string *) val mk_date : ?localzone:bool -> ?zone:int -> ?nanos:int -> fmt:string -> float -> string (** Format the seconds (plus nanos if present) as a string *) val mk_mail_date : ?localzone:bool -> ?zone:int -> float -> string (** Convert the time (seconds since the epoch) to a date string that * conforms to RFC 1123 (which updates RFC 822). * * Example: ["Sun, 06 Nov 1994 08:49:37 -0500"]. *) val mk_usenet_date : ?localzone:bool -> ?zone:int -> float -> string (** Convert the time (seconds since the epoch) to a date string that * conforms to RFC 1036 (which obsoletes RFC 850). * * Example: ["Sunday, 06-Nov-94 08:49:37 -0500"]. * * Note that this format has only two digits for the year. *) val mk_internet_date : ?localzone:bool -> ?zone:int -> ?digits:int -> float -> string (** Convert the time (seconds since the epoch) to a date string that * conforms to RFC 3339. This is the most modern format, and should * be used if permitted by the network protocol. Pass in [digits] the * number of digits for the fractional part of seconds. * * Example: ["1996-12-19T16:39:57.89-08:00"]. *) ocamlnet-4.1.6/src/netstring/netdb.ml0000644000175000017500000000234713274252307016215 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) let values = Hashtbl.create 13 let loaders = Hashtbl.create 13 let cksums = Hashtbl.create 13 let enabled = ref true let read_db name = let v = try Hashtbl.find values name with | Not_found -> if not !enabled then failwith ("Ocamlnet: The lookup table `" ^ name ^ "' is not compiled into the program, and access to " ^ "the external file database is disabled"); let loader = try Hashtbl.find loaders name with | Not_found -> failwith ("Ocamlnet: No such lookup table: " ^ name) in loader name in try let cksum = Hashtbl.find cksums name in if Digest.string v <> cksum then failwith ("Netdb: checksum error for table: " ^ name); v with | Not_found -> v let exists_db name = Hashtbl.mem values name || (!enabled && Hashtbl.mem loaders name) let set_db name value = Hashtbl.replace values name value let set_db_checksum name cksum = Hashtbl.replace cksums name cksum let set_db_loader name loader = Hashtbl.replace loaders name loader let enable_db_loaders b = enabled := b ocamlnet-4.1.6/src/netstring/netdb.mli0000644000175000017500000000260713274252307016365 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) (* This is an internal interface of ocamlnet! Do not use outside! *) (* This module manages persistent values (often lookup tables). These * values can be stored in external files, or they can be initialized * from string values. *) val read_db : string -> string (* Reads the value with the given name, and returns it. * * First it is checked whether there was a set_db call, and if so, * this value is unmarshalled and returned. Otherwise, it is checked * whether there is a loader, and if so, it is called. * * In both cases the checksum is checked. *) val exists_db : string -> bool (* Checks whether the named value is available, i.e. read_db would * be able to find it *) val set_db_checksum : string -> string -> unit (* [set_db_checksum key cksum]: sets the MD5 digest of this key *) val set_db : string -> string -> unit (* Sets the persistent value with the given name (1st arg) to the * passed value (2nd arg). The value must be marshalled as string. *) val set_db_loader : string -> (string -> string) -> unit (* [set_db_loader key loader]: sets a loader for this key, which is called when set_db has not been set for this key. The arg of the loader is the key. *) val enable_db_loaders : bool -> unit (* Whether dynamic loading is enabled *) ocamlnet-4.1.6/src/netstring/netdn.ml0000644000175000017500000002107513274252310016222 0ustar gerdgerd(* $Id$ *) open Printf type oid = Netoid.t type dn = (oid * Netasn1.Value.value) list list module type AT_LOOKUP = sig val attribute_types : (oid * string * string list) list val lookup_attribute_type_by_oid : oid -> string * string list val lookup_attribute_type_by_name : string -> oid * string * string list end module type DN_string = sig val parse : string -> dn val print : dn -> string end let () = Netmappings_asn1.init() (* ensure that asn1 tables are linked in *) let directory_string_from_ASN1 value = let fail_enc() = failwith "Netx509.directory_string_from_ASN1: bad input encoding" in match value with | Netasn1.Value.UTF8String s -> ( try Netconversion.verify `Enc_utf8 s with Netconversion.Malformed_code_at _ -> fail_enc() ); s | Netasn1.Value.PrintableString s -> ( try Netconversion.convert ~in_enc:`Enc_asn1_printable ~out_enc:`Enc_utf8 s with Netconversion.Malformed_code -> fail_enc() ) | Netasn1.Value.IA5String s -> ( try Netconversion.convert ~in_enc:`Enc_usascii ~out_enc:`Enc_utf8 s with Netconversion.Malformed_code -> fail_enc() ) | Netasn1.Value.TeletexString s -> ( try Netconversion.convert ~in_enc:`Enc_asn1_T61 ~out_enc:`Enc_utf8 s with Netconversion.Malformed_code -> fail_enc() ) | Netasn1.Value.BMPString s -> ( try Netconversion.convert ~in_enc:`Enc_utf16_be ~out_enc:`Enc_utf8 s with Netconversion.Malformed_code -> fail_enc() ) | Netasn1.Value.UniversalString s -> ( try Netconversion.convert ~in_enc:`Enc_utf32_be ~out_enc:`Enc_utf8 s with Netconversion.Malformed_code -> fail_enc() ) | _ -> failwith "Netx509.directory_string_from_ASN1: \ unsupported ASN.1 value type" module DN_string_generic(L : AT_LOOKUP) = struct type token = | Space | Quote | Hash | Plus | Comma | Semi | Less | Equal | Greater | Text of (string * bool) (* bool: whether there were escaped chars when decoding the text *) let illegal_esc() = failwith "Netdn.DN_string.parse: illegal escape sequence" let syntax_error() = failwith "Netdn.DN_string.parse: syntax error" let hex_val s = int_of_string ("0x" ^ s) let tokenize s = let l = String.length s in let b = Buffer.create 80 in let b_esc = ref false in let rec next k = if k < l then ( match s.[k] with | ' ' -> special Space (k+1) | '"' -> special Quote (k+1) | '#' -> special Hash (k+1) | '+' -> special Plus (k+1) | ',' -> special Comma (k+1) | ';' -> special Semi (k+1) | '<' -> special Less (k+1) | '=' -> special Equal (k+1) | '>' -> special Greater (k+1) | '\\' -> if k+1 < l then match s.[k+1] with | ( ' ' | '"' | '#' | '+' | ',' | ';' | '<' | '=' | '>' | '\\' ) as c -> Buffer.add_char b c; b_esc := true; next (k+2) | ( '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' ) as c1 -> if k+2 < l then match s.[k+2] with | ( '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' ) as c2 -> let h = Bytes.create 2 in Bytes.set h 0 c1; Bytes.set h 1 c2; let v = hex_val (Bytes.to_string h) in Buffer.add_char b (Char.chr v); b_esc := true; next (k+3) | _ -> illegal_esc() else illegal_esc() | _ -> illegal_esc() else illegal_esc() | c -> Buffer.add_char b c; next (k+1) ) else if Buffer.length b > 0 then [ Text (Buffer.contents b, !b_esc) ] else [] and special token k = if Buffer.length b > 0 then ( let u = Buffer.contents b in let e = !b_esc in Buffer.clear b; b_esc := false; Text(u,e) :: token :: next k ) else token :: next k in next 0 let rec skip_spaces toks = (* until the next Equal token *) match toks with | Space :: toks' -> skip_spaces toks' | Equal :: toks' -> toks | other :: toks' -> other :: skip_spaces toks' | [] -> [] let descr_re = Netstring_str.regexp "^[A-Za-z][A-Za-z0-9-]*$" let parse s = let rec parse_rdn cur toks = let toks = skip_spaces toks in match toks with | Text(name,esc) :: Equal :: toks1 -> if esc then illegal_esc(); if Netstring_str.string_match descr_re name 0 <> None then ( (* it's a descr *) let name_uc = STRING_UPPERCASE name in let (oid, _, _) = try L.lookup_attribute_type_by_name name_uc with Not_found -> failwith ("Netdn.DN_string.parse: unknown attribute '" ^ name ^ "'") in parse_value cur oid toks1 ) else ( try let oid = Netoid.of_string name in parse_value cur oid toks1 with | _ -> syntax_error() ) | _ -> syntax_error() and parse_value cur oid toks = match toks with | Hash :: _ -> failwith "Netdn.DN_string.parse: hex-encoded values are not \ supported by this parser" | Space :: toks1 -> (* CHECK *) parse_value cur oid toks1 | _ -> parse_value_rest cur oid [] toks and parse_value_rest cur oid value toks = match toks with | Plus :: toks1 -> let ava = (oid, utf8 (String.concat "" (List.rev value))) in parse_rdn (ava :: cur) toks1 | Comma :: toks1 -> let ava = (oid, utf8 (String.concat "" (List.rev value))) in let rdn = List.rev (ava :: cur) in rdn :: parse_rdn [] toks1 | Text(s,_) :: toks1 -> parse_value_rest cur oid (s :: value) toks1 | Hash :: toks1 -> parse_value_rest cur oid ("#" :: value) toks1 | Equal :: toks1 -> parse_value_rest cur oid ("=" :: value) toks1 | Space :: toks1 -> parse_value_rest cur oid (" " :: value) toks1 | (Quote | Semi | Less | Greater) :: toks1 -> syntax_error() | [] -> let ava = (oid, utf8 (String.concat "" (List.rev value))) in let rdn = List.rev (ava :: cur) in [ rdn ] and utf8 s = try Netconversion.verify `Enc_utf8 s; Netasn1.Value.UTF8String s with | Netconversion.Malformed_code_at _ -> failwith "Netdn.DN_string.parse: not in UTF-8" in parse_rdn [] (tokenize s) let string_of_ava (oid, value) = let oid_str = try let (_, l) = L.lookup_attribute_type_by_oid oid in if l = [] then raise Not_found; List.hd l with Not_found -> Netoid.to_string oid in let u = directory_string_from_ASN1 value in let b = Buffer.create 80 in Buffer.add_string b oid_str; Buffer.add_char b '='; let l = String.length u in for k = 0 to l - 1 do match String.unsafe_get u k with | ' ' -> if k=0 || k=l-1 then Buffer.add_string b "\\20" else Buffer.add_char b ' ' | '#' -> if k=0 then Buffer.add_string b "\\23" else Buffer.add_char b '#' | ('"' | '+' | ',' | ';' | '<' | '>' | '\\') as c -> Buffer.add_string b (sprintf "\\%02x" (Char.code c)) | c -> Buffer.add_char b c done; Buffer.contents b let print dn = String.concat "," (List.map (fun rdn -> String.concat "+" (List.map string_of_ava rdn) ) dn ) end ocamlnet-4.1.6/src/netstring/netdn.mli0000644000175000017500000000363613274252310016376 0ustar gerdgerd(* $Id$ *) (** X.500 distinguished names *) type oid = Netoid.t type dn = (oid * Netasn1.Value.value) list list (** This is the raw version of the DN: a sequence of relative DNs, and a relative DN is a set of (type,value) pairs. The types are things like cn, country, organization, ... *) module type AT_LOOKUP = sig val attribute_types : (oid * string * string list) list (** The above types in the format [(oid, full_name, short_names)] *) val lookup_attribute_type_by_oid : oid -> string * string list (** Looks the OID up, and returns [(full_name, short_names)]. May raise [Not_found]. *) val lookup_attribute_type_by_name : string -> oid * string * string list (** Looks the name up, which can either be a full name or a short name. Returns the whole triple [(oid, full_name, short_names)], or raises [Not_found]. *) end module type DN_string = sig (** For a given attribute lookup module [L] this module provides parser and printer for distinguished names in string format (RFC 4514). This implementation is restricted to attributes using the ASN.1 types [PrintableString], [TeletexString], [IA5String], [UniversalString], [BMPString], and [UTF8String]. It is not possible to parse hexencoded strings ('#' notation). (NB. We'd need a generic BER printer for supporting this.) *) val parse : string -> dn (** Parses the string (or fails). The string must use UTF-8 encoding. *) val print : dn -> string (** Prints the DN (cannot fail), using UTF-8 encoding *) end module DN_string_generic (L : AT_LOOKUP) : DN_string (** For a given attribute lookup module [L] this module provides parser and printer for distinguished names in string format (RFC 4514). *) (**/**) val directory_string_from_ASN1 : Netasn1.Value.value -> string (* See Netx509, where this function is exported officially *) ocamlnet-4.1.6/src/netstring/netencoding.ml0000644000175000017500000013703613274252310017414 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) let hexdigit_uc = [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'A'; 'B'; 'C'; 'D'; 'E'; 'F'; |] let hexdigit_lc = [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; |] let to_hex ?(lc=false) s = let hexdigit = if lc then hexdigit_lc else hexdigit_uc in let l = String.length s in let u = Bytes.create (2*l) in for k = 0 to l-1 do let c = String.unsafe_get s k in let j = k lsl 1 in Bytes.unsafe_set u j hexdigit.(Char.code c lsr 4); Bytes.unsafe_set u (j+1) hexdigit.(Char.code c land 15); done; Bytes.unsafe_to_string u module Base64 = struct let alphabet = [| 'A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M'; 'N'; 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g'; 'h'; 'i'; 'j'; 'k'; 'l'; 'm'; 'n'; 'o'; 'p'; 'q'; 'r'; 's'; 't'; 'u'; 'v'; 'w'; 'x'; 'y'; 'z'; '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; '+'; '/' |];; let mod_alphabet plus slash = if plus <> '+' || slash <> '/' then ( let a = Array.copy alphabet in a.(62) <- plus; a.(63) <- slash; a ) else alphabet let encode_with_options ops b64 equal s pos len linelen first_linelen crlf = (* encode using "base64". * 'b64': The encoding table, created by b64_pattern. * 'equal': The character that should be used instead of '=' in the original * encoding scheme. Pass '=' to get the original encoding scheme. * s, pos, len, linelen: See the interface description of encode_substring. * first_linelen: The length of the first line. * * Returns: (s,last_linelen) where [s] is the encoded string, and * [last_linelen] is the length of the last line *) let open Netstring_tstring in assert (Array.length b64 = 64); if len < 0 || pos < 0 || pos > ops.length s || linelen < 0 then invalid_arg "Netencoding.Base64.encode"; if pos + len > ops.length s then invalid_arg "Netencoding.Base64.encode"; let linelen = (linelen asr 2) lsl 2 in let first_linelen = (first_linelen asr 2) lsl 2 in let l_t = if len = 0 then 0 else ((len - 1) / 3 + 1) * 4 in (* l_t: length of the result without additional line endings *) let factor = if crlf then 2 else 1 in let l_t' = if linelen < 4 then l_t else if l_t <= first_linelen then ( if l_t = 0 then 0 else l_t + factor ) else let n_lines = ((l_t - first_linelen - 1) / linelen) + 2 in l_t + n_lines * factor in (* l_t': length of the result with CRLF or LF characters *) let t = Bytes.make l_t' equal in let j = ref 0 in let q = ref (linelen - first_linelen) in for k = 0 to len / 3 - 1 do let p = pos + 3*k in (* p >= pos >= 0: this is evident * p+2 < pos+len <= String.length s: * Because k <= len/3-1 * 3*k <= 3*(len/3-1) = len - 3 * pos+3*k+2 <= pos + len - 3 + 2 = pos + len - 1 < pos + len * So it is proved that the following unsafe string accesses always * work. *) let bits = ops.unsafe_get3 s p in (* Obviously, 'bits' is a 24 bit entity (i.e. bits < 2**24) *) assert(!j + 3 < l_t'); Bytes.unsafe_set t !j (Array.unsafe_get b64 ( bits lsr 18)); Bytes.unsafe_set t (!j+1) (Array.unsafe_get b64 ((bits lsr 12) land 63)); Bytes.unsafe_set t (!j+2) (Array.unsafe_get b64 ((bits lsr 6) land 63)); Bytes.unsafe_set t (!j+3) (Array.unsafe_get b64 ( bits land 63)); j := !j + 4; if linelen > 3 then begin q := !q + 4; if !q + 4 > linelen then begin (* The next 4 characters won't fit on the current line. So insert * a line ending. *) if crlf then begin Bytes.set t !j '\013'; Bytes.set t (!j+1) '\010'; j := !j + 2; end else begin Bytes.set t !j '\010'; incr j end; q := 0; end; end; done; (* padding if needed: *) let m = len mod 3 in begin match m with 0 -> () | 1 -> let bits = Char.code (ops.get s (pos + len - 1)) in Bytes.set t !j b64.( bits lsr 2); Bytes.set t (!j + 1) b64.( (bits land 0x03) lsl 4); j := !j + 4; q := !q + 4; | 2 -> let bits = (Char.code (ops.get s (pos + len - 2)) lsl 8) lor (Char.code (ops.get s (pos + len - 1))) in Bytes.set t !j b64.( bits lsr 10); Bytes.set t (!j + 1) b64.((bits lsr 4) land 0x3f); Bytes.set t (!j + 2) b64.((bits lsl 2) land 0x3f); j := !j + 4; q := !q + 4; | _ -> assert false end; (* If required, add another line end: *) if linelen > 3 && !q > 0 && len > 0 then begin if crlf then begin Bytes.set t !j '\013'; Bytes.set t (!j+1) '\010'; j := !j + 2; end else begin Bytes.set t !j '\010'; incr j; end; end; (t, !q) ;; let encode_poly ?(pos=0) ?len ?(linelength=0) ?(crlf=false) ?(plus='+') ?(slash='/') ops s = let open Netstring_tstring in let alpha = mod_alphabet plus slash in let l = match len with None -> ops.length s - pos | Some x -> x in let s,_ = encode_with_options ops alpha '=' s pos l linelength linelength crlf in s ;; let encode ?pos ?len ?linelength ?crlf ?plus ?slash s = let ops = Netstring_tstring.string_ops in let s = encode_poly ?pos ?len ?linelength ?crlf ?plus ?slash ops s in Bytes.unsafe_to_string s let encode_tstring ?pos ?len ?linelength ?crlf ?plus ?slash ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> encode_poly ?pos ?len ?linelength ?crlf ?plus ?slash ops s ) } ts let encoding_pipe_conv ?(linelength = 0) ?(crlf = false) ~plus ~slash alpha lastlen incoming incoming_eof outgoing = let ops = Netstring_tstring.bytes_ops in let linelength = (linelength asr 2) lsl 2 in let len = Netbuffer.length incoming in let len' = if incoming_eof then len else len - (len mod 3) (* only process a multiple of three characters *) in let (s,ll) = encode_with_options ops alpha '=' (Netbuffer.unsafe_buffer incoming) 0 len' linelength (linelength - !lastlen) crlf in Netbuffer.delete incoming 0 len'; (* LF/CRLF: Unless s = "", s ends with a LF/CRLF. This is only right * if ll = 0 or at EOF. In the other cases, this additional LF/CRLF * must not be added to [outgoing]. *) if linelength < 3 || ll=0 || Bytes.length s = 0 then begin Netbuffer.add_bytes outgoing s; end else begin let sl = Bytes.length s in assert(Bytes.get s (sl-1) = '\n'); let sl' = if crlf then sl-2 else sl-1 in Netbuffer.add_subbytes outgoing s 0 sl'; end; lastlen := ll; (* Ensure there is a LF/CRLF at the end: *) if incoming_eof && linelength > 3 && ll > 0 then Netbuffer.add_string outgoing (if crlf then "\r\n" else "\n"); (* TODO: Can be improved by using Netbuffer.add_inplace *) class encoding_pipe ?linelength ?crlf ?(plus='+') ?(slash='/') () = let alpha = mod_alphabet plus slash in let lastlen = ref 0 in let conv = encoding_pipe_conv ?linelength ?crlf ~plus ~slash alpha lastlen in Netchannels.pipe ~conv () let decode_prefix ops t pos len plus slash p_spaces p_full p_null = (* Decodes the prefix of a Base64-encoded string. Returns a triple * (s,n,eof) where s is the decoded prefix, and n is the number of * processed characters from t (i.e. the characters pos to pos+n-1 have * been processed), and where eof is the boolean flag whether the * padding '=' characters at the end of the string have been seen. * * p_spaces: accepts spaces in [t] (at the price of reduced speed) * p_full: [t] must be a closed encoded string (i.e. no prefix) * p_null: [t] must be an encoded null string *) let open Netstring_tstring in if len < 0 || pos < 0 || pos > ops.length t then invalid_arg "Netencoding.Base64.decode"; if pos + len > ops.length t then invalid_arg "Netencoding.Base64.decode"; (* Compute the number of effective characters l_t in 't'; * pad_chars: number of '=' characters at the end of the string. *) let l_t, pad_chars = if p_spaces then begin (* Count all non-whitespace characters: *) let c = ref 0 in let p = ref 0 in for i = pos to pos + len - 1 do match ops.unsafe_get t i with (' '|'\t'|'\r'|'\n'|'>') -> () | '=' -> incr c; incr p; if !p > 2 then invalid_arg "Netencoding.Base64.decode"; for j = i+1 to pos + len - 1 do match ops.unsafe_get t j with (' '|'\t'|'\r'|'\n'|'=') -> () | _ -> (* Only another '=' or spaces allowed *) invalid_arg "Netencoding.Base64.decode"; done | _ -> incr c done; !c, !p end else len, ( if len > 0 then ( if ops.substring t (len - 2) 2 = "==" then 2 else if ops.substring t (len - 1) 1 = "=" then 1 else 0 ) else 0 ) in if p_null && l_t <> 0 then invalid_arg "Netencoding.Base64.decode"; (* Compute the number of characters [l_t] that can be processed now * (i.e. the effective prefix) *) let l_t, pad_chars = let m = l_t mod 4 in if m = 0 then ( (l_t, pad_chars) (* a multiple of 4 *) ) else ( if p_full then invalid_arg "Netencoding.Base64.decode"; (l_t - m, 0) (* rounded to a multiple of 4 *) ) in let l_s = (l_t / 4) * 3 - pad_chars in let s = Bytes.create l_s in let decode_char c = match c with 'A' .. 'Z' -> Char.code(c) - 65 (* 65 = Char.code 'A' *) | 'a' .. 'z' -> Char.code(c) - 71 (* 71 = Char.code 'a' - 26 *) | '0' .. '9' -> Char.code(c) + 4 (* -4 = Char.code '0' - 52 *) | _ -> if c = plus then 62 else if c = slash then 63 else invalid_arg "Netencoding.Base64.decode"; in (* Decode all but the last quartet: *) let cursor = ref pos in let rec next_char() = match ops.get t !cursor with (' '|'\t'|'\r'|'\n'|'>') -> if p_spaces then (incr cursor; next_char()) else invalid_arg "Netencoding.Base64.decode" | c -> incr cursor; c in if p_spaces then begin for k = 0 to l_t / 4 - 2 do let q = 3*k in let c0 = next_char() in let c1 = next_char() in let c2 = next_char() in let c3 = next_char() in let n0 = decode_char c0 in let n1 = decode_char c1 in let n2 = decode_char c2 in let n3 = decode_char c3 in let x0 = (n0 lsl 2) lor (n1 lsr 4) in let x1 = ((n1 lsl 4) land 0xf0) lor (n2 lsr 2) in let x2 = ((n2 lsl 6) land 0xc0) lor n3 in Bytes.unsafe_set s q (Char.chr x0); Bytes.unsafe_set s (q+1) (Char.chr x1); Bytes.unsafe_set s (q+2) (Char.chr x2); done; end else begin (* Much faster: *) for k = 0 to l_t / 4 - 2 do let p = pos + 4*k in let q = 3*k in let c012 = ops.unsafe_get3 t p in let c0 = c012 lsr 16 in let c1 = (c012 lsr 8) land 0xff in let c2 = c012 land 0xff in let c3 = ops.unsafe_get t (p + 3) in let n0 = decode_char (Char.unsafe_chr c0) in let n1 = decode_char (Char.unsafe_chr c1) in let n2 = decode_char (Char.unsafe_chr c2) in let n3 = decode_char c3 in let x0 = (n0 lsl 2) lor (n1 lsr 4) in let x1 = ((n1 lsl 4) land 0xf0) lor (n2 lsr 2) in let x2 = ((n2 lsl 6) land 0xc0) lor n3 in Bytes.unsafe_set s q (Char.chr x0); Bytes.unsafe_set s (q+1) (Char.chr x1); Bytes.unsafe_set s (q+2) (Char.chr x2); done; cursor := pos + l_t - 4; end; (* Decode the last quartet: *) if l_t > 0 then begin let q = 3*(l_t / 4 - 1) in let c0 = next_char() in let c1 = next_char() in let c2 = next_char() in let c3 = next_char() in if (c2 = '=' && c3 = '=') then begin let n0 = decode_char c0 in let n1 = decode_char c1 in let x0 = (n0 lsl 2) lor (n1 lsr 4) in Bytes.set s q (Char.chr x0); end else if (c3 = '=') then begin let n0 = decode_char c0 in let n1 = decode_char c1 in let n2 = decode_char c2 in let x0 = (n0 lsl 2) lor (n1 lsr 4) in let x1 = ((n1 lsl 4) land 0xf0) lor (n2 lsr 2) in Bytes.set s q (Char.chr x0); Bytes.set s (q+1) (Char.chr x1); end else begin let n0 = decode_char c0 in let n1 = decode_char c1 in let n2 = decode_char c2 in let n3 = decode_char c3 in let x0 = (n0 lsl 2) lor (n1 lsr 4) in let x1 = ((n1 lsl 4) land 0xf0) lor (n2 lsr 2) in let x2 = ((n2 lsl 6) land 0xc0) lor n3 in Bytes.set s q (Char.chr x0); Bytes.set s (q+1) (Char.chr x1); Bytes.set s (q+2) (Char.chr x2); end end else cursor := 0; (s, !cursor - pos, pad_chars > 0) ;; let decode_poly ?(pos=0) ?len ?(accept_spaces=false) ?(plus='+') ?(slash='/') ops s = let open Netstring_tstring in let l = match len with None -> ops.length s - pos | Some x -> x in let (s,_,_) = decode_prefix ops s pos l plus slash accept_spaces true false in s let decode ?pos ?len ?accept_spaces ?plus ?slash s = let ops = Netstring_tstring.string_ops in let s' = decode_poly ?pos ?len ?accept_spaces ?plus ?slash ops s in Bytes.unsafe_to_string s' let decode_tstring ?pos ?len ?accept_spaces ?plus ?slash ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> decode_poly ?pos ?len ?accept_spaces ?plus ?slash ops s ) } ts (* TODO: Use Netbuffer.add_inplace instead of creating an intermediate * string s in [decoding_pipe_conv]. *) let decoding_pipe_conv plus slash accept_spaces padding_seen incoming incoming_eof outgoing = let ops = Netstring_tstring.bytes_ops in let len = Netbuffer.length incoming in let t = Netbuffer.unsafe_buffer incoming in if !padding_seen then begin (* Only accept the null string: *) let _,_,_ = decode_prefix ops t 0 len plus slash accept_spaces false true in Netbuffer.clear incoming end else begin let (s,n,ps) = decode_prefix ops t 0 len plus slash accept_spaces incoming_eof false in padding_seen := ps; if incoming_eof then Netbuffer.clear incoming else Netbuffer.delete incoming 0 n; Netbuffer.add_bytes outgoing s end; class decoding_pipe ?(accept_spaces=false) ?(plus='+') ?(slash='/') () = let padding_seen = ref false in let conv = decoding_pipe_conv plus slash accept_spaces padding_seen in Netchannels.pipe ~conv () end module QuotedPrintable = struct let encode_sub ?(crlf = true) ?(eot = false) ?(line_length = ref 0) ~pos ~len ops s = (* line_length: * - on input, the length of the line where the encoding starts * - on output, the length of the last written line * eot: * - false: it is known that the chunk is not at the end of text * - true: the chunk may be at the end of the text * eot has only an effect on trailing spaces *) let open Netstring_tstring in if len < 0 || pos < 0 || pos > ops.length s then invalid_arg "Netencoding.QuotedPrintable.encode"; if pos + len > ops.length s then invalid_arg "Netencoding.QuotedPrintable.encode"; let eol_len = if crlf then 2 else 1 in (* length of eol *) (* Note: The [count] algorithm must strictly correspond to the * "for" loop below. *) let rec count l n i = (* l: output line length * n: output byte count * i: input byte count *) if i < len then match ops.unsafe_get s (pos+i) with '\r' -> (* CR is deleted *) count l n (i+1) | '\n' -> (* LF may be expanded to CR/LF *) count 0 (n+eol_len) (i+1) | ('\000'..'\031'|'\127'..'\255'| '!'|'"'|'#'|'$'|'@'|'['|']'|'^'|'\''|'{'|'|'|'}'|'~'|'=') -> if l <= 69 then count (l+3) (n+3) (i+1) else (* Add soft line break after the encoded char: *) count 0 (n+4+eol_len) (i+1) | 'F' when l=0 -> (* Protect 'F' at the beginning of lines *) count (l+3) (n+3) (i+1) | ' ' when (i=len-1 && eot) || (* at end of text *) l>69 || (* line too long *) (i (* Protect spaces only if they occur at the end of a line, * or just before soft line breaks *) if l <= 69 then count (l+3) (n+3) (i+1) else (* Add soft line after the encoded space: *) count 0 (n+4+eol_len) (i+1) | _ -> if l>71 then (* Add soft line break after the char: *) count 0 (n+2+eol_len) (i+1) else count (l+1) (n+1) (i+1) else n in let t_len = count !line_length 0 0 in let t = Bytes.create t_len in let k = ref 0 in let add_quoted c = Bytes.set t !k '='; Bytes.set t (!k+1) (hexdigit_uc.( Char.code c lsr 4 )); Bytes.set t (!k+2) (hexdigit_uc.( Char.code c land 15 )) in let add_soft_break() = Bytes.set t !k '='; if crlf then ( Bytes.set t (!k+1) '\r'; Bytes.set t (!k+2) '\n'; ) else Bytes.set t (!k+1) '\n'; in (* In the following, the soft break criterion is [!l > 72]. Why? * We need to be able to add at least an encoded char (3 bytes) * plus the "=" sign for the soft break. So we are on the safe side * when there are four bytes space on the line. Lines must not be * longer than 76 chars (w/o CRLF), so 76-4=72. *) let l = ref !line_length in for i = 0 to len - 1 do match ops.unsafe_get s i with '\r' -> (* CR is deleted *) () | '\n' -> (* LF is expanded to CR/LF *) if crlf then ( Bytes.set t !k '\r'; Bytes.set t (!k+1) '\n'; k := !k + 2; ) else ( Bytes.set t !k '\n'; k := !k + 1; ); l := 0 | ('\000'..'\031'|'\127'..'\255'| '!'|'"'|'#'|'$'|'@'|'['|']'|'^'|'\''|'{'|'|'|'}'|'~'|'=') as c -> add_quoted c; k := !k + 3; l := !l + 3; if !l > 72 then ( (* Add soft line break: *) add_soft_break(); k := !k + 1 + eol_len; l := 0 ) | 'F' when !l = 0 -> (* Protect 'F' at the beginning of lines *) add_quoted 'F'; k := !k + 3; l := !l + 3; | ' ' when ((i=len-1 && eot) || !l > 69 || (i add_quoted ' '; k := !k + 3; l := !l + 3; if !l > 72 then ( add_soft_break(); k := !k + 1 + eol_len; l := 0; ) | c -> Bytes.unsafe_set t !k c; incr k; incr l; if !l > 72 then ( add_soft_break(); k := !k + 1 + eol_len; l := 0; ) done; assert(!k == t_len); line_length := !l; t ;; let encode_poly ?crlf ?(pos=0) ?len ops s = let open Netstring_tstring in let l = match len with None -> ops.length s - pos | Some x -> x in encode_sub ?crlf ~eot:true ~pos ~len:l ops s;; let encode ?crlf ?pos ?len s = let ops = Netstring_tstring.string_ops in let s' = encode_poly ?crlf ?pos ?len ops s in Bytes.unsafe_to_string s' let encode_tstring ?crlf ?pos ?len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> encode_poly ?crlf ?pos ?len ops s ) } ts let encoding_pipe_conv ?crlf line_length incoming incoming_eof outgoing = (* Problematic case: the incoming buffer ends with a space, but we are * not at EOF. It is possible that a LF immediately follows, and that * the space needs to be quoted. * Solution: Do not convert such spaces, they remain in the buffer. *) let open Netstring_tstring in let ops = Netstring_tstring.bytes_ops in let s = Netbuffer.unsafe_buffer incoming in let len = Netbuffer.length incoming in let (len',eot) = if not incoming_eof && len > 0 && ops.get s (len-1) = ' ' then (len-1, false) else (len, true) in let s' = encode_sub ?crlf ~eot ~line_length ~pos:0 ~len:len' ops s in Netbuffer.add_bytes outgoing s'; Netbuffer.delete incoming 0 len' ;; class encoding_pipe ?crlf () = let line_length = ref 0 in Netchannels.pipe ~conv:(encoding_pipe_conv ?crlf line_length) () let decode_sub ~pos ~len ops s = let open Netstring_tstring in if len < 0 || pos < 0 || pos > ops.length s then invalid_arg "Netencoding.QuotedPrintable.decode"; if pos + len > ops.length s then invalid_arg "Netencoding.QuotedPrintable.decode"; let decode_hex c = match c with '0'..'9' -> Char.code c - 48 | 'A'..'F' -> Char.code c - 55 | 'a'..'f' -> Char.code c - 87 | _ -> invalid_arg "Netencoding.QuotedPrintable.decode"; in let rec count n i = if i < len then match ops.unsafe_get s (pos+i) with '=' -> if i+1 = len then (* A '=' at EOF is ignored *) count n (i+1) else if i+1 < len then match ops.get s (pos+i+1) with '\r' -> (* Official soft break *) if i+2 < len && ops.get s (pos+i+2) = '\n' then count n (i+3) else count n (i+2) | '\n' -> (* Inofficial soft break *) count n (i+2) | _ -> if i+2 >= len then invalid_arg "Netencoding.QuotedPrintable.decode"; let _ = decode_hex (ops.get s (pos+i+1)) in let _ = decode_hex (ops.get s (pos+i+2)) in count (n+1) (i+3) else invalid_arg "Netencoding.QuotedPrintable.decode" | _ -> count (n+1) (i+1) else n in let l = count 0 0 in let t = Bytes.create l in let k = ref pos in let e = pos + len in let i = ref 0 in while !i < l do match ops.unsafe_get s !k with '=' -> if !k+1 = e then (* A '=' at EOF is ignored *) () else if !k+1 < e then match ops.get s (!k+1) with '\r' -> (* Official soft break *) if !k+2 < e && ops.get s (!k+2) = '\n' then k := !k + 3 else k := !k + 2 | '\n' -> (* Inofficial soft break *) k := !k + 2 | _ -> if !k+2 >= e then invalid_arg "Netencoding.QuotedPrintable.decode_substring"; let x1 = decode_hex (ops.get s (!k+1)) in let x2 = decode_hex (ops.get s (!k+2)) in Bytes.set t !i (Char.chr ((x1 lsl 4) lor x2)); k := !k + 3; incr i else invalid_arg "Netencoding.QuotedPrintable.decode_substring" | c -> Bytes.unsafe_set t !i c; incr k; incr i done; t ;; let decode_poly ?(pos=0) ?len ops s = let open Netstring_tstring in let l = match len with None -> ops.length s - pos | Some x -> x in decode_sub ~pos ~len:l ops s;; let decode ?pos ?len s = let ops = Netstring_tstring.string_ops in let s' = decode_poly ?pos ?len ops s in Bytes.unsafe_to_string s' let decode_tstring ?pos ?len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> decode_poly ?pos ?len ops s ) } ts let decoding_pipe_conv incoming incoming_eof outgoing = (* Problematic case: The incoming buffer ends with '=' or '=X'. In this * case these characters remain in the buffer, because they will be * completed to a full hex sequence by the next conversion call. *) let open Netstring_tstring in let ops = Netstring_tstring.bytes_ops in let s = Netbuffer.unsafe_buffer incoming in let len = Netbuffer.length incoming in let len' = if not incoming_eof then begin if len > 0 && ops.get s (len-1) = '=' then len - 1 else if len > 1 && ops.get s (len-2) = '=' then len - 2 else len end else len in let s' = decode_poly ~len:len' ops s in Netbuffer.add_bytes outgoing s'; Netbuffer.delete incoming 0 len' ;; class decoding_pipe () = Netchannels.pipe ~conv:decoding_pipe_conv () end module Q = struct let encode_sub ~pos ~len ops s = let open Netstring_tstring in if len < 0 || pos < 0 || pos > ops.length s then invalid_arg "Netencoding.Q.encode_substring"; if pos + len > ops.length s then invalid_arg "Netencoding.Q.encode_substring"; let rec count n i = if i < len then match ops.unsafe_get s (pos+i) with | ('A'..'Z'|'a'..'z'|'0'..'9') -> count (n+1) (i+1) | _ -> count (n+3) (i+1) else n in let l = count 0 0 in let t = Bytes.create l in let k = ref 0 in let add_quoted c = Bytes.set t !k '='; Bytes.set t (!k+1) (hexdigit_uc.( Char.code c lsr 4 )); Bytes.set t (!k+2) (hexdigit_uc.( Char.code c land 15 )) in for i = 0 to len - 1 do match ops.unsafe_get s i with | ('A'..'Z'|'a'..'z'|'0'..'9') as c -> Bytes.unsafe_set t !k c; incr k | c -> add_quoted c; k := !k + 3 done; t ;; let encode_poly ?(pos=0) ?len ops s = let open Netstring_tstring in let l = match len with None -> ops.length s - pos | Some x -> x in encode_sub ~pos ~len:l ops s;; let encode ?pos ?len s = let ops = Netstring_tstring.string_ops in let s' = encode_poly ?pos ?len ops s in Bytes.unsafe_to_string s' let encode_tstring ?pos ?len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> encode_poly ?pos ?len ops s ) } ts let decode_sub ~pos ~len ops s = let open Netstring_tstring in if len < 0 || pos < 0 || pos > ops.length s then invalid_arg "Netencoding.Q.decode_substring"; if pos + len > ops.length s then invalid_arg "Netencoding.Q.decode_substring"; let decode_hex c = match c with '0'..'9' -> Char.code c - 48 | 'A'..'F' -> Char.code c - 55 | 'a'..'f' -> Char.code c - 87 | _ -> invalid_arg "Netencoding.Q.decode_substring"; in let rec count n i = if i < len then match ops.unsafe_get s (pos+i) with '=' -> if i+2 >= len then invalid_arg "Netencoding.Q.decode_substring"; let _ = decode_hex (ops.get s (pos+i+1)) in let _ = decode_hex (ops.get s (pos+i+2)) in count (n+1) (i+3) | _ -> (* including '_' *) count (n+1) (i+1) else n in let l = count 0 0 in let t = Bytes.create l in let k = ref pos in let e = pos + len in let i = ref 0 in while !i < l do match ops.unsafe_get s !k with '=' -> if !k+2 >= e then invalid_arg "Netencoding.Q.decode_substring"; let x1 = decode_hex (ops.get s (!k+1)) in let x2 = decode_hex (ops.get s (!k+2)) in Bytes.set t !i (Char.chr ((x1 lsl 4) lor x2)); k := !k + 3; incr i | '_' -> Bytes.unsafe_set t !i ' '; incr k; incr i | c -> Bytes.unsafe_set t !i c; incr k; incr i done; t ;; let decode_poly ?(pos=0) ?len ops s = let open Netstring_tstring in let l = match len with None -> ops.length s - pos | Some x -> x in decode_sub ~pos ~len:l ops s;; let decode ?pos ?len s = let ops = Netstring_tstring.string_ops in let s' = decode_poly ?pos ?len ops s in Bytes.unsafe_to_string s' let decode_tstring ?pos ?len ts = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun ops s -> decode_poly ?pos ?len ops s ) } ts end module Url = struct let hex_digits = [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'A'; 'B'; 'C'; 'D'; 'E'; 'F' |];; let to_hex2 k = (* Converts k to a 2-digit hex string *) let s = Bytes.create 2 in Bytes.set s 0 (hex_digits.( (k lsr 4) land 15 )); Bytes.set s 1 (hex_digits.( k land 15 )); Bytes.unsafe_to_string s ;; let of_hex1 c = match c with ('0'..'9') -> Char.code c - Char.code '0' | ('A'..'F') -> Char.code c - Char.code 'A' + 10 | ('a'..'f') -> Char.code c - Char.code 'a' + 10 | _ -> raise Not_found ;; let url_encoding_re = Netstring_str.regexp "[^A-Za-z0-9_.!*-]";; let url_decoding_re = Netstring_str.regexp "\\+\\|%..\\|%.\\|%";; let encode ?(plus = true) s = Netstring_str.global_substitute url_encoding_re (fun r _ -> match Netstring_str.matched_string r s with " " when plus -> "+" | x -> let k = Char.code(x.[0]) in "%" ^ to_hex2 k ) s ;; let decode ?(plus = true) ?(pos=0) ?len s = let s_l = String.length s in let s1 = if pos = 0 && len=None then s else let len = match len with Some n -> n | None -> s_l in String.sub s pos len in let l = String.length s1 in Netstring_str.global_substitute url_decoding_re (fun r _ -> match Netstring_str.matched_string r s1 with | "+" -> if plus then " " else "+" | _ -> let i = Netstring_str.match_beginning r in (* Assertion: s1.[i] = '%' *) if i+2 >= l then failwith "Netencoding.Url.decode"; let c1 = s1.[i+1] in let c2 = s1.[i+2] in begin try let k1 = of_hex1 c1 in let k2 = of_hex1 c2 in String.make 1 (Char.chr((k1 lsl 4) lor k2)) with Not_found -> failwith "Netencoding.Url.decode" end ) s1 ;; let url_split_re = Netstring_str.regexp "[&=]";; let mk_url_encoded_parameters nv_pairs = String.concat "&" (List.map (fun (name,value) -> let name_encoded = encode name in let value_encoded = encode value in name_encoded ^ "=" ^ value_encoded ) nv_pairs ) ;; let dest_url_encoded_parameters parstr = let rec parse_after_amp tl = match tl with Netstring_str.Text name :: Netstring_str.Delim "=" :: Netstring_str.Text value :: tl' -> (decode name, decode value) :: parse_next tl' | Netstring_str.Text name :: Netstring_str.Delim "=" :: Netstring_str.Delim "&" :: tl' -> (decode name, "") :: parse_after_amp tl' | Netstring_str.Text name :: Netstring_str.Delim "=" :: [] -> [decode name, ""] | _ -> failwith "Netencoding.Url.dest_url_encoded_parameters" and parse_next tl = match tl with [] -> [] | Netstring_str.Delim "&" :: tl' -> parse_after_amp tl' | _ -> failwith "Netencoding.Url.dest_url_encoded_parameters" in let toklist = Netstring_str.full_split url_split_re parstr in match toklist with [] -> [] | _ -> parse_after_amp toklist ;; let mk_url_encoded_parameters params = String.concat "&" (List.map (fun (name, value) -> encode name ^ "=" ^ encode value) params) end module Html = struct let etable = [ "lt", 60; "gt", 62; "amp", 38; "quot", 34; (* Note: " is new in HTML-4.0, but it has been widely used * much earlier. *) "apos", 39; (* Only used if contained in unsafe_chars *) (* ISO-8859-1: *) "nbsp", 160; "iexcl", 161; "cent", 162; "pound", 163; "curren", 164; "yen", 165; "brvbar", 166; "sect", 167; "uml", 168; "copy", 169; "ordf", 170; "laquo", 171; "not", 172; "shy", 173; "reg", 174; "macr", 175; "deg", 176; "plusmn", 177; "sup2", 178; "sup3", 179; "acute", 180; "micro", 181; "para", 182; "middot", 183; "cedil", 184; "sup1", 185; "ordm", 186; "raquo", 187; "frac14", 188; "frac12", 189; "frac34", 190; "iquest", 191; "Agrave", 192; "Aacute", 193; "Acirc", 194; "Atilde", 195; "Auml", 196; "Aring", 197; "AElig", 198; "Ccedil", 199; "Egrave", 200; "Eacute", 201; "Ecirc", 202; "Euml", 203; "Igrave", 204; "Iacute", 205; "Icirc", 206; "Iuml", 207; "ETH", 208; "Ntilde", 209; "Ograve", 210; "Oacute", 211; "Ocirc", 212; "Otilde", 213; "Ouml", 214; "times", 215; "Oslash", 216; "Ugrave", 217; "Uacute", 218; "Ucirc", 219; "Uuml", 220; "Yacute", 221; "THORN", 222; "szlig", 223; "agrave", 224; "aacute", 225; "acirc", 226; "atilde", 227; "auml", 228; "aring", 229; "aelig", 230; "ccedil", 231; "egrave", 232; "eacute", 233; "ecirc", 234; "euml", 235; "igrave", 236; "iacute", 237; "icirc", 238; "iuml", 239; "eth", 240; "ntilde", 241; "ograve", 242; "oacute", 243; "ocirc", 244; "otilde", 245; "ouml", 246; "divide", 247; "oslash", 248; "ugrave", 249; "uacute", 250; "ucirc", 251; "uuml", 252; "yacute", 253; "thorn", 254; "yuml", 255; (* Other: *) "fnof", 402; "Alpha", 913; "Beta", 914; "Gamma", 915; "Delta", 916; "Epsilon", 917; "Zeta", 918; "Eta", 919; "Theta", 920; "Iota", 921; "Kappa", 922; "Lambda", 923; "Mu", 924; "Nu", 925; "Xi", 926; "Omicron", 927; "Pi", 928; "Rho", 929; "Sigma", 931; "Tau", 932; "Upsilon", 933; "Phi", 934; "Chi", 935; "Psi", 936; "Omega", 937; "alpha", 945; "beta", 946; "gamma", 947; "delta", 948; "epsilon", 949; "zeta", 950; "eta", 951; "theta", 952; "iota", 953; "kappa", 954; "lambda", 955; "mu", 956; "nu", 957; "xi", 958; "omicron", 959; "pi", 960; "rho", 961; "sigmaf", 962; "sigma", 963; "tau", 964; "upsilon", 965; "phi", 966; "chi", 967; "psi", 968; "omega", 969; "thetasym", 977; "upsih", 978; "piv", 982; "bull", 8226; "hellip", 8230; "prime", 8242; "Prime", 8243; "oline", 8254; "frasl", 8260; "weierp", 8472; "image", 8465; "real", 8476; "trade", 8482; "alefsym", 8501; "larr", 8592; "uarr", 8593; "rarr", 8594; "darr", 8595; "harr", 8596; "crarr", 8629; "lArr", 8656; "uArr", 8657; "rArr", 8658; "dArr", 8659; "hArr", 8660; "forall", 8704; "part", 8706; "exist", 8707; "empty", 8709; "nabla", 8711; "isin", 8712; "notin", 8713; "ni", 8715; "prod", 8719; "sum", 8721; "minus", 8722; "lowast", 8727; "radic", 8730; "prop", 8733; "infin", 8734; "ang", 8736; "and", 8743; "or", 8744; "cap", 8745; "cup", 8746; "int", 8747; "there4", 8756; "sim", 8764; "cong", 8773; "asymp", 8776; "ne", 8800; "equiv", 8801; "le", 8804; "ge", 8805; "sub", 8834; "sup", 8835; "nsub", 8836; "sube", 8838; "supe", 8839; "oplus", 8853; "otimes", 8855; "perp", 8869; "sdot", 8901; "lceil", 8968; "rceil", 8969; "lfloor", 8970; "rfloor", 8971; "lang", 9001; "rang", 9002; "loz", 9674; "spades", 9824; "clubs", 9827; "hearts", 9829; "diams", 9830; "OElig", 338; "oelig", 339; "Scaron", 352; "scaron", 353; "Yuml", 376; "circ", 710; "tilde", 732; "ensp", 8194; "emsp", 8195; "thinsp", 8201; "zwnj", 8204; "zwj", 8205; "lrm", 8206; "rlm", 8207; "ndash", 8211; "mdash", 8212; "lsquo", 8216; "rsquo", 8217; "sbquo", 8218; "ldquo", 8220; "rdquo", 8221; "bdquo", 8222; "dagger", 8224; "Dagger", 8225; "permil", 8240; "lsaquo", 8249; "rsaquo", 8250; "euro", 8364; ] ;; let quick_etable_html = let ht = Hashtbl.create 50 in List.iter (fun (name,value) -> Hashtbl.add ht name value ) etable; ht ;; let quick_etable_xml = let ht = Hashtbl.create 5 in List.iter (fun name -> let value = List.assoc name etable in Hashtbl.add ht name value ) [ "lt"; "gt"; "amp"; "quot"; "apos"]; ht ;; let rev_etable = (* Only code points 0 to 255: *) let a = Array.make 256 "" in List.iter (fun (name,value) -> if value <= 255 then a.(value) <- "&" ^ name ^ ";" ) etable; a ;; let rev_etable_rest = (* Only code points >= 256: *) let ht = Hashtbl.create 150 in List.iter (fun (name,value) -> if value >= 256 then Hashtbl.add ht value ("&" ^ name ^ ";") ) etable; ht ;; let unsafe_chars_html4 = "<>\"&\000\001\002\003\004\005\006\007\008\011\012\014\015\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031\127" ;; let regexp_ht = Hashtbl.create 7 let regexp_ht_mutex = !Netsys_oothr.provider # create_mutex() let regexp_set s = Netsys_oothr.serialize regexp_ht_mutex (fun () -> try Hashtbl.find regexp_ht s with | Not_found -> let re = Netstring_str.regexp (Netstring_str.quote_set s) in if Hashtbl.length regexp_ht < 100 then (* avoid leak *) Hashtbl.replace regexp_ht s re; re ) () (* The functions [encode_quickly] and [encode_ascii] are special cases of * [encode] that can be implemented by regular expressions. *) let encode_quickly ~prefer_name ~unsafe_chars () = (* Preconditions: in_enc = out_enc, and the encoding must be a single-byte, * ASCII-compatible encoding. *) if unsafe_chars = "" then (fun s -> s) else let unsafe_re = regexp_set unsafe_chars in Netstring_str.global_substitute unsafe_re (fun r s -> let t = Netstring_str.matched_string r s in let p = Char.code (t.[0]) in (* p is an ASCII code point *) let name = rev_etable.(p) in if prefer_name && name <> "" then name else "&#" ^ string_of_int p ^ ";" ) ;; let encode_quickly_poly ~prefer_name ~unsafe_chars ~ops ~out_kind () = Netstring_tstring.polymorph_string_transformation (encode_quickly ~prefer_name ~unsafe_chars ()) ops out_kind let msb_set = ( let s = Bytes.create 128 in for k = 0 to 127 do Bytes.set s k (Char.chr (128+k)) done; Bytes.unsafe_to_string s ) let encode_ascii ~in_enc ~prefer_name ~unsafe_chars () = (* Preconditions: out_enc = `Enc_usascii, and in_enc must be a single-byte, * ASCII-compatible encoding. *) let unsafe_chars1 = unsafe_chars ^ msb_set in let unsafe_re = regexp_set unsafe_chars1 in (* unicode_of.[q] = p: the code point q+128 of in_enc is the same as the * Unicode code point p *) let unicode_of = Array.make 128 (-1) in for i = 0 to 127 do try let s = String.make 1 (Char.chr (i+128)) in let u = Netconversion.uarray_of_ustring in_enc s in match u with [| u0 |] -> unicode_of.(i) <- u0 | _ -> assert false with Netconversion.Malformed_code -> unicode_of.(i) <- (-1) done; Netstring_str.global_substitute unsafe_re (fun r s -> let t = Netstring_str.matched_string r s in (* p is the code point in the encoding ~in_enc; p' is the Unicode * code point: *) let p = Char.code (t.[0]) in let p' = if p < 128 then p else unicode_of.(p - 128) in if p' < 0 then raise Netconversion.Malformed_code; let name = if prefer_name then begin if p' <= 255 then rev_etable.(p') else try Hashtbl.find rev_etable_rest p' with Not_found -> "" end else "" in if name = "" then "&#" ^ string_of_int p' ^ ";" else name ) ;; let encode_ascii_poly ~in_enc ~prefer_name ~unsafe_chars ~ops ~out_kind () = Netstring_tstring.polymorph_string_transformation (encode_ascii ~in_enc ~prefer_name ~unsafe_chars ()) ops out_kind let encode_from_latin1 = (* backwards compatible *) encode_ascii ~in_enc:`Enc_iso88591 ~prefer_name:true ~unsafe_chars:unsafe_chars_html4 () ;; let encode_poly ~in_enc ~in_ops ~out_kind ?(out_enc = `Enc_usascii) ?(prefer_name = true) ?(unsafe_chars = unsafe_chars_html4) () = (* This function implements the general case *) (* Check arguments: *) if not (Netconversion.is_ascii_compatible out_enc) then invalid_arg "Netencoding.Html.encode: out_enc not ASCII-compatible"; for i = 0 to String.length unsafe_chars - 1 do if Char.code(unsafe_chars.[i]) >= 128 then invalid_arg "Netencoding.Html.encode: non-ASCII character in unsafe_chars"; done; (* Are there better implementations than the general one? *) let in_single = Netconversion.is_single_byte in_enc in let in_subset = match in_enc with `Enc_subset(_,_) -> true | _ -> false in if not in_subset && in_enc=out_enc && in_single then encode_quickly_poly ~prefer_name ~unsafe_chars ~ops:in_ops ~out_kind () else if not in_subset && out_enc=`Enc_usascii && in_single then encode_ascii_poly ~in_enc ~prefer_name ~unsafe_chars ~ops:in_ops ~out_kind () else begin (* ... only the general implementation is applicable. *) (* Create the domain function: *) let dom_array = Array.make 128 true in let dom p = p >= 128 || dom_array.(p) in (* Set dom_array from unsafe_chars: *) for i = 0 to String.length unsafe_chars - 1 do let c = Char.code(unsafe_chars.[i]) in dom_array.(c) <- false done; (* Create the substitution function: *) let subst p = let name = if prefer_name then begin if p <= 255 then rev_etable.(p) else try Hashtbl.find rev_etable_rest p with Not_found -> "" end else "" in if name = "" then "&#" ^ string_of_int p ^ ";" else name in (* Recode: *) (fun s -> Netconversion.convert_poly ~in_ops ~out_kind ~subst ~in_enc ~out_enc:(`Enc_subset(out_enc,dom)) s ) end ;; let encode ~in_enc ?out_enc ?prefer_name ?unsafe_chars () = let in_ops = Netstring_tstring.string_ops in let out_kind = Netstring_tstring.String_kind in encode_poly ~in_enc ~in_ops ~out_kind ?out_enc ?prefer_name ?unsafe_chars () let encode_tstring ~in_enc ~out_kind ?out_enc ?prefer_name ?unsafe_chars () = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun in_ops s -> encode_poly ~in_enc ~in_ops ~out_kind ?out_enc ?prefer_name ?unsafe_chars () s ) } type entity_set = [ `Html | `Xml | `Empty ];; let eref_re = Netstring_str.regexp "&\\(\ #\\([0-9]+\\);\\|\ #[xX]\\([0-9a-fA-F]+\\);\\|\ \\([a-zA-Z]+\\);\ \\)" ;; let total_enc = (* every byte must have a corresponding Unicode code point, i.e. the * encoding must be "byte-total" *) function `Enc_iso88591 | `Enc_iso88592 | `Enc_iso88593 | `Enc_iso88594 | `Enc_iso88595 | `Enc_iso88599 | `Enc_iso885910 | `Enc_iso885913 | `Enc_iso885914 | `Enc_iso885915 | `Enc_iso885916 -> true | _ -> false ;; let hex_digit_of_char c = match c with '0'..'9' -> Char.code c - 48 | 'A'..'F' -> Char.code c - 55 | 'a'..'f' -> Char.code c - 87 | _ -> assert false let hex_of_string s = let n = ref 0 in for i = 0 to String.length s - 1 do let d = hex_digit_of_char s.[i] in n := (!n lsl 4) lor d done; !n let search_all re s pos = let rec search p acc = match try Some(Netstring_str.search_forward re s p) with Not_found -> None with | Some (k,r) -> search (k+1) ( (k,r) :: acc ) | None -> List.rev acc in search pos [] let decode_half_poly ~in_enc ~out_kind ~out_enc ?(lookup=fun name -> failwith ("Netencoding.Html.decode: Unknown entity `" ^ name ^ "'")) ?(subst=fun p -> failwith ("Netencoding.Html.decode: Character cannot be represented: " ^ string_of_int p)) ?(entity_base = (`Html : entity_set)) () = (* Argument checks: *) if not (Netconversion.is_ascii_compatible in_enc) then invalid_arg "Netencoding.Html.decode: in_enc not ASCII-compatible"; (* makechar: *) let raw_makechar = Netconversion.makechar out_enc in let makechar p = try raw_makechar p with Not_found -> subst p in (* Entity lookup: *) let lookup_entity = match entity_base with `Html | `Xml -> let ht = if entity_base = `Html then quick_etable_html else quick_etable_xml in ( fun name -> try makechar(Hashtbl.find ht name) with Not_found -> lookup name ) | `Empty -> lookup in (* Recode strings: *) let recode_str = if total_enc in_enc && in_enc = out_enc then (fun s pos len -> if pos=0 && len=(String.length s) then s else String.sub s pos len ) else (fun s range_pos range_len -> Netconversion.convert ~in_enc ~out_enc ~subst ~range_pos ~range_len s) in (fun s -> (* Find all occurrences of &name; or &#num; or &#xnum; *) let occurrences = search_all eref_re s 0 in (* Collect the resulting string in a buffer *) let buf = Netbuffer.create 250 in let n = ref 0 in List.iter (fun (n0,r) -> let n1 = Netstring_str.match_end r in if n0 > !n then Netbuffer.add_string buf (recode_str s !n (n0 - !n)); let replacement = let num = try Netstring_str.matched_group r 2 s with Not_found -> "" in (* Note: Older versions of Pcre return "" when the substring * did not match, newer versions raise Not_found *) if num <> "" then begin let n = int_of_string num in makechar n end else begin let xnum = try Netstring_str.matched_group r 3 s with Not_found -> "" in (* Note: Older versions of Pcre return "" when the substring * did not match, newer versions raise Not_found *) if xnum <> "" then begin let n = hex_of_string xnum in makechar n end else begin let name = try Netstring_str.matched_group r 4 s with Not_found -> "" in (* Note: Older versions of Pcre return "" when the substring * did not match, newer versions raise Not_found *) assert(name <> ""); lookup_entity name end end in Netbuffer.add_string buf replacement; n := n1; ) occurrences; let n0 = String.length s in if n0 > !n then Netbuffer.add_string buf (recode_str s !n (n0 - !n)); (* Return *) Netbuffer.to_tstring_poly buf out_kind ) ;; let decode_poly ~in_enc ~in_ops ~out_kind ~out_enc ?lookup ?subst ?entity_base () s = let open Netstring_tstring in decode_half_poly ~in_enc ~out_kind ~out_enc ?lookup ?subst ?entity_base () (in_ops.string s) let decode ~in_enc ~out_enc ?lookup ?subst ?entity_base () = let out_kind = Netstring_tstring.String_kind in decode_half_poly ~in_enc ~out_kind ~out_enc ?lookup ?subst ?entity_base () let decode_tstring ~in_enc ~out_kind ~out_enc ?lookup ?subst ?entity_base () = Netstring_tstring.with_tstring { Netstring_tstring.with_fun = (fun in_ops s -> decode_poly ~in_enc ~in_ops ~out_kind ~out_enc ?lookup ?subst ?entity_base () s ) } let decode_to_latin1 = decode ~in_enc:`Enc_iso88591 ~out_enc:`Enc_iso88591 ~lookup:(fun s -> "&" ^ s ^ ";") ~subst:(fun p -> "&#" ^ string_of_int p ^ ";") () end ocamlnet-4.1.6/src/netstring/netencoding.mli0000644000175000017500000004411013274252310017553 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) (** Base64, Quoted Printable, URL encoding, HTML escaping *) (* *********************************************************************) (* Several encodings important for the net *) (* *********************************************************************) open Netsys_types (* *********************************************************************) (* Base 64 encoding *) (* *********************************************************************) (* See RFC 2045 for a description of Base 64 encoding. *) (* THREAD-SAFETY: * All Base64 functions are reentrant and thus thread-safe. *) module Base64 : sig (** Base64 encoding as described in RFC 2045 *) val encode : ?pos:int -> ?len:int -> ?linelength:int -> ?crlf:bool -> ?plus:char -> ?slash:char -> string -> string (** Compute the "base 64" encoding of the given string argument. * Note that the result is a string that only contains the characters * a-z, A-Z, 0-9, +, /, =, and optionally spaces, CR and LF characters. * * If [pos] and/or [len] are passed, only the substring starting at * [pos] (default: 0) with length [len] (default: rest of the string) * is encoded. * * The result is divided up into lines not longer than [linelength] * (without counting the line separator); default: do not divide lines. * If [linelength] is smaller than 4, no line division is performed. * If [linelength] is not divisible by 4, the produced lines are a * bit shorter than [linelength]. * * If [crlf] (default: false) the lines are ended by CRLF; otherwise * they are only ended by LF. * (You need the crlf option to produce correct MIME messages.) * * By default, the 63rd character of the alphabet is '+', and the * 64th character is '/'. By passing [plus] and [slash] you can * choose different characters. * *) val encode_tstring : ?pos:int -> ?len:int -> ?linelength:int -> ?crlf:bool -> ?plus:char -> ?slash:char -> tstring -> Bytes.t (** Same for tagged string inputs. The result are always bytes, though *) val encode_poly : ?pos:int -> ?len:int -> ?linelength:int -> ?crlf:bool -> ?plus:char -> ?slash:char -> 's Netstring_tstring.tstring_ops -> 's -> Bytes.t (** Polymorphic version *) val decode : ?pos:int -> ?len:int -> ?accept_spaces:bool -> ?plus:char -> ?slash:char -> string -> string (** Decodes the given string argument. * * If [pos] and/or [len] are passed, only the substring starting at * [pos] (default: 0) with length [len] (default: rest of the string) * is decoded. * * If [accept_spaces] (default: [false]) is set, the function ignores * white space contained in the string to decode (otherwise the * function fails if it finds white space). Furthermore, the character * '>' is considered as "space", too (so you don't have trouble with * mbox mailboxes that accidentally quote "From"). * * By default, the 63rd character of the alphabet is '+', and the * 64th character is '/'. By passing [plus] and [slash] you can * choose different characters. *) val decode_tstring : ?pos:int -> ?len:int -> ?accept_spaces:bool -> ?plus:char -> ?slash:char -> tstring -> Bytes.t (** Same for tagged string inputs. The result are always bytes, though *) val decode_poly : ?pos:int -> ?len:int -> ?accept_spaces:bool -> ?plus:char -> ?slash:char -> 's Netstring_tstring.tstring_ops -> 's -> Bytes.t (** Polymorphic version *) class encoding_pipe : ?linelength:int -> ?crlf:bool -> ?plus:char -> ?slash:char -> unit -> Netchannels.pipe (** This pipe encodes the data written into the pipe. * [linelength] and [crlf] work as in [encode]. *) class decoding_pipe : ?accept_spaces:bool -> ?plus:char -> ?slash:char -> unit -> Netchannels.pipe (** This pipe decodes the data written into the pipe. * [url_variant] and [accept_spaces] work as in [decode]. *) end (* *********************************************************************) (* Quoted printable encoding *) (* *********************************************************************) (* THREAD-SAFETY: * All QuotedPrintable functions are reentrant and thus thread-safe. *) module QuotedPrintable : sig (** This module implements the "Quoted Printable" encoding as * described in RFC 2045. * * This implementation assumes that the encoded string has a text MIME * type. On input both CR/LF and LF are accepted as end-of-line (eol) terminators, * but the output normalizes the eol delimiter as the [crlf] argument * specifies. Note that this implies that * - If [crlf], the output uses CR/LF as line separator as MIME prescribes * - the encoding is not invertible for binary data *) val encode : ?crlf:bool -> ?pos:int -> ?len:int -> string -> string (** Encodes the string and returns it. * * Since OcamlNet 0.98, soft line breaks are added to the output * to ensure that all output lines have a length <= 76 bytes. * * Note unsafe characters: * As recommended by RFC 2045, the characters [!#$\@[]^`|{}~] * and the double quotes * are additionally represented as hex tokens. * Furthermore, the letter 'F' is considered as unsafe if it * occurs at the beginning of the line, so the encoded text * never contains the word "From" at the beginning of a line. * * If [pos] and/or [len] are passed, only the substring starting at * [pos] (default: 0) with length [len] (default: rest of the string) * is encoded. * * If [crlf] is set (the default), the output text uses CR/LF as * line separator. Otherwise only LF is used. *) val encode_tstring : ?crlf:bool -> ?pos:int -> ?len:int -> tstring -> Bytes.t (** Same for tagged string inputs. The result are always bytes, though *) val encode_poly : ?crlf:bool -> ?pos:int -> ?len:int -> 's Netstring_tstring.tstring_ops -> 's -> Bytes.t (** Polymorphic version *) val decode : ?pos:int -> ?len:int -> string -> string (** Decodes the string and returns it. * * Most format errors cause an [Invalid_argument] exception. * * If [pos] and/or [len] are passed, only the substring starting at * [pos] (default: 0) with length [len] (default: rest of the string) * is decoded. *) val decode_tstring : ?pos:int -> ?len:int -> tstring -> Bytes.t (** Same for tagged string inputs. The result are always bytes, though *) val decode_poly : ?pos:int -> ?len:int -> 's Netstring_tstring.tstring_ops -> 's -> Bytes.t (** Polymorphic version *) class encoding_pipe : ?crlf:bool -> unit -> Netchannels.pipe (** This pipe encodes the data written into the pipe. *) class decoding_pipe : unit -> Netchannels.pipe (** This pipe decodes the data written into the pipe. *) end (* *********************************************************************) (* Q encoding *) (* *********************************************************************) (* See RFC 2047. * The functions behave similar to those of QuotedPrintable. *) (* THREAD-SAFETY: * All Q functions are reentrant and thus thread-safe. *) module Q : sig (** The "Q" encoding as described by RFC 2047. *) val encode : ?pos:int -> ?len:int -> string -> string (** Note: * All characters except alphanumeric characters are protected by * hex tokens. * In particular, spaces are represented as "=20", not as "_". *) val encode_tstring : ?pos:int -> ?len:int -> tstring -> Bytes.t (** Same for tagged string inputs. The result are always bytes, though *) val encode_poly : ?pos:int -> ?len:int -> 's Netstring_tstring.tstring_ops -> 's -> Bytes.t (** Polymorphic version *) val decode : ?pos:int -> ?len:int -> string -> string (** Q-decode a string *) val decode_tstring : ?pos:int -> ?len:int -> tstring -> Bytes.t (** Same for tagged string inputs. The result are always bytes, though *) val decode_poly : ?pos:int -> ?len:int -> 's Netstring_tstring.tstring_ops -> 's -> Bytes.t (** Polymorphic version *) end (* *********************************************************************) (* B encoding *) (* *********************************************************************) (* The B encoding of RFC 2047 is the same as Base64. *) (* *********************************************************************) (* URL-encoding *) (* *********************************************************************) (* THREAD-SAFETY: * The Url functions are thread-safe. *) module Url : sig (** Encoding/Decoding within URLs: * * The following two functions perform the '%'-substitution for * characters that may otherwise be interpreted as metacharacters. * * According to: RFC 1738, RFC 1630 * * Option [plus]: This option has been added because there are some * implementations that do not map ' ' to '+', for example Javascript's * [escape] function. The default is [true] because this is the RFC- * compliant definition. *) (** There are no tstring and polymorphic versions of the encode and decode functions, as URLs are comparatively short, and it is considered as acceptable for the user to convert types as needed, even if strings need to be copied for that. *) val decode : ?plus:bool -> ?pos:int -> ?len:int -> string -> string (** Option [plus]: Whether '+' is converted to space. The default * is true. If false, '+' is returned as it is. * * The optional arguments [pos] and [len] may restrict the string * to process to this substring. *) val encode : ?plus:bool -> string -> string (** Option [plus]: Whether spaces are converted to '+'. The default * is true. If false, spaces are converted to "%20", and * only %xx sequences are produced. *) (** URL-encoded parameters: * * The following two functions create and analyze URL-encoded parameters. * Format: [name1=val1&name2=val2&...] *) val mk_url_encoded_parameters : (string * string) list -> string (** The argument is a list of (name,value) pairs. The result is the * single URL-encoded parameter string. *) val dest_url_encoded_parameters : string -> (string * string) list (** The argument is the URL-encoded parameter string. The result is * the corresponding list of (name,value) pairs. * Note: Whitespace within the parameter string is ignored. * If there is a format error, the function fails. *) end (* *********************************************************************) (* HTMLization *) (* *********************************************************************) (* THREAD-SAFETY: * The Html functions are thread-safe. *) module Html : sig (** Encodes characters that need protection by converting them to * entity references. E.g. ["<"] is converted to ["<"]. * As the entities may be named, there is a dependency on the character * set. *) (* OLD ENCODE/DECODE FUNCTIONS: *) (** Legacy functions: *) val encode_from_latin1 : string -> string (* Encodes the characters 0-8, 11-12, 14-31, '<', '>', '"', '&', * 127-255. If the characters have a name, a named entity is * preferred over a numeric entity. *) val decode_to_latin1 : string -> string (* Decodes the string. Unknown named entities are left as they * are (i.e. decode_to_latin1 "&nonsense;" = "&nonsense;"). * The same applies to numeric entities greater than 255. *) (* NEW ENCODE/DECODE FUNCTIONS: *) (** These functions have a more general interface and should be preferred * in new programs. *) val unsafe_chars_html4 : string (** The string contains '<', '>', '"', '&' and the control characters * 0-8, 11-12, 14-31, 127. *) val encode : in_enc:Netconversion.encoding -> ?out_enc:Netconversion.encoding -> (* default: `Enc_usascii *) ?prefer_name:bool -> (* default: true *) ?unsafe_chars:string -> (* default: unsafe_chars_html4 *) unit -> string -> string (** The input string that is encoded as [in_enc] is recoded to * [out_enc], and the following characters are encoded as HTML * entity ([&name;] or [&#num;]): * - The ASCII characters contained in [unsafe_chars] * - The characters that cannot be represented in [out_enc]. By * default ([out_enc=`Enc_usascii]), only ASCII characters can be * represented, and thus all code points >= 128 are encoded as * HTML entities. If you pass [out_enc=`Enc_utf8], all characters * can be represented. * * For example, the string ["(ad)"] is encoded as * ["(a<b) & (c>d)"]. * * It is required that [out_enc] is an ASCII-compatible encoding. * * The option [prefer_name] selects whether named entities (e.g. [<]) * or numeric entities (e.g. [<]) are prefered. * * The efficiency of the function can be improved when the same encoding * is applied to several strings. Create a specialized encoding function * by passing all arguments up to the unit argument, and apply this * function several times. For example: * {[ * let my_enc = encode ~in_enc:`Enc_utf8 () in * let s1' = my_enc s1 in * let s2' = my_enc s2 in ... * ]} *) val encode_tstring : in_enc:Netconversion.encoding -> out_kind:'s Netstring_tstring.tstring_kind -> ?out_enc:Netconversion.encoding -> ?prefer_name:bool -> ?unsafe_chars:string -> unit -> tstring -> 's (** This version takes a tstring argument, and returns the string type chosen by the [out_kind] arg. *) val encode_poly : in_enc:Netconversion.encoding -> in_ops:'s Netstring_tstring.tstring_ops -> out_kind:'t Netstring_tstring.tstring_kind -> ?out_enc:Netconversion.encoding -> ?prefer_name:bool -> ?unsafe_chars:string -> unit -> 's -> 't (** Fully polymorphic version *) type entity_set = [ `Html | `Xml | `Empty ];; val decode : in_enc:Netconversion.encoding -> out_enc:Netconversion.encoding -> ?lookup:(string -> string) -> (* default: see below *) ?subst:(int -> string) -> (* default: see below *) ?entity_base:entity_set -> (* default: `Html *) unit -> string -> string (** The input string is recoded from [in_enc] to [out_enc], and HTML * entities ([&name;] or [&#num;]) are resolved. The input encoding * [in_enc] must be ASCII-compatible. * * By default, the function knows all entities defined for HTML 4 (this * can be changed using [entity_base], see below). If other * entities occur, the function [lookup] is called and the name of * the entity is passed as input string to the function. It is * expected that [lookup] returns the value of the entity, and that this * value is already encoded as [out_enc]. * By default, [lookup] raises a [Failure] exception. * * If a character cannot be represented in the output encoding, * the function [subst] is called. [subst] must return a substitute * string for the character. * By default, [subst] raises a [Failure] exception. * * The option [entity_base] determines which set of entities are * considered as the known entities that can be decoded without * help by the [lookup] function: [`Html] selects all entities defined * for HTML 4, [`Xml] selects only [<], [>], [&], ["], * and ['], * and [`Empty] selects the empty set (i.e. [lookup] is always called). *) val decode_tstring : in_enc:Netconversion.encoding -> out_kind:'s Netstring_tstring.tstring_kind -> out_enc:Netconversion.encoding -> ?lookup:(string -> string) -> (* default: see below *) ?subst:(int -> string) -> (* default: see below *) ?entity_base:entity_set -> (* default: `Html *) unit -> tstring -> 's (** This version takes a tstring argument, and returns the string type chosen by the [out_kind] arg. *) val decode_poly : in_enc:Netconversion.encoding -> in_ops:'s Netstring_tstring.tstring_ops -> out_kind:'t Netstring_tstring.tstring_kind -> out_enc:Netconversion.encoding -> ?lookup:(string -> string) -> (* default: see below *) ?subst:(int -> string) -> (* default: see below *) ?entity_base:entity_set -> (* default: `Html *) unit -> 's -> 't (** Fully polymorphic version *) end (* TODO: module with hex routines *) val to_hex : ?lc:bool -> string -> string ocamlnet-4.1.6/src/netstring/netfs.ml0000644000175000017500000004667313274252310016244 0ustar gerdgerd(* $Id$ *) type read_flag = [ `Skip of int64 | `Binary | `Streaming | `Dummy ] type read_file_flag = [ `Binary | `Dummy ] type write_flag = [ `Create | `Exclusive | `Truncate | `Binary | `Streaming | `Dummy ] type write_file_flag = [ `Create | `Exclusive | `Truncate | `Binary | `Link | `Dummy ] type write_common = [ `Create | `Exclusive | `Truncate | `Binary | `Dummy ] (* The intersection of write_flag and write_file_flag *) type size_flag = [ `Dummy ] type test_flag = [ `Link | `Dummy ] type remove_flag = [ `Recursive | `Dummy ] type rename_flag = [ `Dummy ] type symlink_flag = [ `Dummy ] type readdir_flag = [ `Dummy ] type readlink_flag = [ `Dummy ] type mkdir_flag = [ `Path | `Nonexcl | `Dummy ] type rmdir_flag = [ `Dummy ] type copy_flag = [ `Dummy ] type test_type = [ `N | `E | `D | `F | `H | `R | `W | `X | `S ] class type local_file = object method filename : string method close : unit -> unit end class type stream_fs = object method path_encoding : Netconversion.encoding option method path_exclusions : (int * int) list method nominal_dot_dot : bool method read : read_flag list -> string -> Netchannels.in_obj_channel method read_file : read_file_flag list -> string -> local_file method write : write_flag list -> string -> Netchannels.out_obj_channel method write_file : write_file_flag list -> string -> local_file -> unit method size : size_flag list -> string -> int64 method test : test_flag list -> string -> test_type -> bool method test_list : test_flag list -> string -> test_type list -> bool list method remove : remove_flag list -> string -> unit method rename : rename_flag list -> string -> string -> unit method symlink : symlink_flag list -> string -> string -> unit method readdir : readdir_flag list -> string -> string list method readlink : readlink_flag list -> string -> string method mkdir : mkdir_flag list -> string -> unit method rmdir : rmdir_flag list -> string -> unit method copy : copy_flag list -> string -> string -> unit method cancel : unit -> unit end class empty_fs detail : stream_fs = let enosys path = raise (Unix.Unix_error(Unix.ENOSYS, path, detail)) in object method path_encoding = enosys "" method path_exclusions = enosys "" method nominal_dot_dot = enosys "" method read _ p = enosys p method read_file _ p = enosys p method write _ p = enosys p method write_file _ p _ = enosys p method size _ p = enosys p method test _ p _ = enosys p method test_list _ p _ = enosys p method remove _ p = enosys p method rename _ p _ = enosys p method symlink _ p _ = enosys p method readdir _ p = enosys p method readlink _ p = enosys p method mkdir _ p = enosys p method rmdir _ p = enosys p method copy _ p _ = enosys p method cancel () = enosys "" end let slash_re = Netstring_str.regexp "/+" let drive_re = Netstring_str.regexp "^[a-zA-Z]:$" exception Not_absolute exception Unavailable let list_isect_empty l1 l2 = (* whether intersection is empty *) List.for_all (fun x1 -> not (List.mem x1 l2)) l1 let readdir d = try let l = ref [] in ( try while true do l := (Unix.readdir d) :: !l done; assert false with End_of_file -> () ); Unix.closedir d; List.rev !l with | error -> Unix.closedir d; raise error let copy_prim ~streaming orig_fs orig_name dest_fs dest_name = let sflags = if streaming then [`Streaming] else [] in Netchannels.with_in_obj_channel (orig_fs#read (sflags @ [`Binary]) orig_name) (fun r_ch -> Netchannels.with_out_obj_channel (dest_fs#write (sflags @ [`Binary; `Truncate; `Create]) dest_name) (fun w_ch -> w_ch # output_channel r_ch ) ) let local_fs ?encoding ?root ?(enable_relative_paths=false) () : stream_fs = let enc = match encoding with | None -> ( match Sys.os_type with | "Win32" -> Netconversion.user_encoding() | _ -> None ) | Some e -> Some e in ( match enc with | None -> () | Some e -> if not (Netconversion.is_ascii_compatible e) then failwith "Netfs.local_fs: the encoding is not ASCII-compatible"; ); let excl = match Sys.os_type with | "Win32" | "Cygwin" -> (* http://msdn.microsoft.com/en-us/library/aa365247%28v=VS.85%29.aspx *) [ 0, 31; (* control chars *) 42, 42; (* <, >, :, quotation mark, /, backslash, |, ?, * *) 47, 47; 58, 58; 60, 60; 62, 63; 92, 92; 124, 124 ] | _ -> [ 0, 0; 47, 47 ] in let excl_array_size = List.fold_left (fun mx (from,upto) -> max mx upto) 0 excl + 1 in let excl_array = ( let a = Array.make excl_array_size false in List.iter (fun (from,upto) -> for k = from to upto do a.(k) <- true done ) excl; a) in let check_component path c = let iter f s = match enc with | None -> String.iter (fun c -> f (Char.code c)) s | Some e -> Netconversion.ustring_iter e f s in try iter (fun code -> if code < excl_array_size && excl_array.(code) then raise (Unix.Unix_error(Unix.EINVAL, "Netfs: invalid char in path", path)) ) c with Netconversion.Malformed_code -> raise (Unix.Unix_error(Unix.EINVAL, "Netfs: path does not comply to charset encoding", path)) in let win32_root = root = None && Sys.os_type = "Win32" in let is_drive_letter s = Netstring_str.string_match drive_re s 0 <> None in let is_unc s = String.length s >= 3 && s.[0] = '/' && s.[1] = '/' && s.[2] <> '/' in let check_and_norm_path p = let l = Netstring_str.split_delim slash_re p in List.iter (check_component p) l; try ( match l with | [] -> raise (Unix.Unix_error(Unix.EINVAL, "Netfs: empty path", p)) | "" :: first :: rest -> if win32_root then ( if ((not (is_drive_letter first) || rest=[]) && not (is_unc p)) then raise Not_absolute ) | first :: rest -> if win32_root then ( if not(is_drive_letter first) || rest=[] then raise Not_absolute ) else raise Not_absolute ); let np = String.concat "/" l in if win32_root then ( if is_unc p then "/" ^ np else if np.[0] = '/' then String.sub np 1 (String.length np - 1) (* remove leading / *) else np ) else np with | Not_absolute -> if enable_relative_paths then String.concat "/" l else raise (Unix.Unix_error(Unix.EINVAL, "Netfs: path not absolute", p)) in let real_root = match root with | None -> "" | Some r -> if (Unix.stat r).Unix.st_kind <> Unix.S_DIR then failwith "Netfs.local_fs: root is not a directory"; r in ( object(self) method path_encoding = enc method path_exclusions = excl method nominal_dot_dot = false method read flags filename = let fn = real_root ^ check_and_norm_path filename in let binary = List.mem `Binary flags in let skip_d = try List.find (fun flag -> match flag with | `Skip _ -> true | _ -> false ) flags with Not_found -> `Skip 0L in let skip = match skip_d with | `Skip n -> n | _ -> assert false in (* Use Unix.openfile to open so we get Unix_errors on error *) let fd = Unix.openfile fn [Unix.O_RDONLY] 0 in let st = Unix.fstat fd in if st.Unix.st_kind = Unix.S_DIR then raise(Unix.Unix_error(Unix.EISDIR,"Netfs.read","")); if skip > 0L then ignore(Unix.LargeFile.lseek fd skip Unix.SEEK_SET); let ch = Unix.in_channel_of_descr fd in set_binary_mode_in ch binary; new Netchannels.input_channel ch method read_file flags filename = let fn = real_root ^ check_and_norm_path filename in let st = Unix.stat fn in if st.Unix.st_kind = Unix.S_DIR then raise(Unix.Unix_error(Unix.EISDIR,"Netfs.read_file","")); ( object method filename = fn method close() = () end ) method write flags filename = let fn = real_root ^ check_and_norm_path filename in let binary = List.mem `Binary flags in let create = List.mem `Create flags in let truncate = List.mem `Truncate flags in let exclusive = List.mem `Exclusive flags in let mode = List.flatten [ [Unix.O_WRONLY]; if create then [ Unix.O_CREAT ] else []; if truncate then [ Unix.O_TRUNC ] else []; if exclusive then [ Unix.O_EXCL ] else []; ] in (* Use Unix.openfile to open so we get Unix_errors on error *) let fd = Unix.openfile fn mode 0o666 in let ch = Unix.out_channel_of_descr fd in set_binary_mode_out ch binary; new Netchannels.output_channel ch method write_file flags filename local = (* This is just a copy operation *) let fn = real_root ^ check_and_norm_path filename in let binary = List.mem `Binary flags in let link = List.mem `Link flags in let local_filename = local#filename in let wflags = List.map (function | #write_common as x -> (x :> write_flag) | _ -> `Dummy ) flags in try let do_copy = try not link || ( Unix.link local_filename fn; false ) with | Unix.Unix_error( ( Unix.EACCES | Unix.ELOOP | Unix.ENAMETOOLONG | Unix.ENOENT | Unix.ENOTDIR | Unix.EPERM | Unix.EROFS ), _, _) as e -> (* These errors cannot be fixed by doing copies instead *) raise e | Unix.Unix_error(_,_,_) -> true in if do_copy then ( let fd_local = Unix.openfile local_filename [Unix.O_RDONLY] 0 in let ch_local = Unix.in_channel_of_descr fd_local in set_binary_mode_in ch_local binary; Netchannels.with_in_obj_channel (new Netchannels.input_channel ch_local) (fun obj_local -> Netchannels.with_out_obj_channel (self # write wflags filename) (fun out -> out # output_channel obj_local ) ); ); local#close() with | error -> local#close(); raise error method size flags filename = let fn = real_root ^ check_and_norm_path filename in let fd = Unix.openfile fn [Unix.O_RDONLY] 0 in try let n = Unix.LargeFile.lseek fd 0L Unix.SEEK_END in Unix.close fd; n with | error -> Unix.close fd; raise error (* esp. non-seekable *) method private test_list_NH flags fn = try let st = Unix.LargeFile.lstat fn in if st.Unix.LargeFile.st_kind = Unix.S_LNK then [ `N; `H ] else [ `N ] with | Unix.Unix_error(Unix.ENOENT,_,_) -> [] method private test_list_EDFS flags fn = try let st = if List.mem `Link flags then Unix.LargeFile.lstat fn else Unix.LargeFile.stat fn in let non_empty = st.Unix.LargeFile.st_size <> 0L in let kind_l = match st.Unix.LargeFile.st_kind with | Unix.S_REG -> [ `F ] | Unix.S_DIR -> [ `D ] | _ -> [] in [ `E ] @ kind_l @ (if non_empty then [`S] else []) with | Unix.Unix_error(Unix.ENOENT,_,_) -> [] method private test_list_RWX flags fn = let r_ok = try Unix.access fn [Unix.R_OK]; true with _ -> false in let w_ok = try Unix.access fn [Unix.W_OK]; true with _ -> false in let x_ok = try Unix.access fn [Unix.X_OK]; true with _ -> false in List.flatten [ if r_ok then [`R] else []; if w_ok then [`W] else []; if x_ok then [`X] else [] ] method test flags filename ttype = let fn = real_root ^ check_and_norm_path filename in let l = match ttype with | `N | `H -> self#test_list_NH flags fn | `E | `D | `F | `S -> self#test_list_EDFS flags fn | `R | `W | `X -> self#test_list_RWX flags fn in List.mem ttype l method test_list flags filename tests = let fn = real_root ^ check_and_norm_path filename in let nh = if not(list_isect_empty tests [`N;`H]) then self#test_list_NH flags fn else [] in let edfs = if not(list_isect_empty tests [`E;`D;`F;`S]) then self#test_list_EDFS flags fn else [] in let rwx = if not(list_isect_empty tests [`R;`W;`X]) then self#test_list_RWX flags fn else [] in List.map (fun t -> match t with | `N | `H -> List.mem t nh | `E | `D | `F | `S -> List.mem t edfs | `R | `W | `X -> List.mem t rwx ) tests method remove flags filename = let fn = real_root ^ check_and_norm_path filename in if List.mem `Recursive flags then ( try self#rm_r_safe fn with Unavailable -> self#rm_r_trad fn ) else Unix.unlink fn (* A rename race: while the recursive removal progresses, a second process renames the directory. The removal function suddenly does not find the directory anymore. Even worse, the second process could move a different directory into the place of the old directory being deleted. In this case, the wrong data would be deleted. We can avoid this in the style of rm_r_safe, or by chdir-ing into the directory hierarchy. The latter is incompatible with multi-threading, so we don't do it here. *) method private rm_r_trad fn = (* "traditional" implemenation w/o protection against rename races *) let is_dir fn = try (Unix.stat fn).Unix.st_kind = Unix.S_DIR with _ -> false in let rec recurse fn = if is_dir fn then ( let files = readdir (Unix.opendir fn) in List.iter (fun file -> if file <> "." && file <> ".." then ( recurse (fn ^ "/" ^ file) ) ) files; Unix.rmdir fn; ) else Unix.unlink fn in recurse fn method private rm_r_safe fn = (* safer implemention using openat and fdopendir *) let rec rm_dir_entries fd = let files = readdir (Netsys_posix.fdopendir (Unix.dup fd)) in List.iter (fun file -> if file <> "." && file <> ".." then rm_dir_or_file fd file ) files and rm_dir_or_file fd file = let file_fd = Netsys_posix.openat fd file [Unix.O_RDONLY] 0 in let file_is_dir = try (Unix.fstat file_fd).Unix.st_kind = Unix.S_DIR with _ -> false in if file_is_dir then ( ( try rm_dir_entries file_fd with error -> Unix.close file_fd; raise error ); Unix.close file_fd; Netsys_posix.unlinkat fd file [Netsys_posix.AT_REMOVEDIR] ) else ( Unix.close file_fd; Netsys_posix.unlinkat fd file [] ) in let test_availability() = if not (Netsys_posix.have_at()) then raise Unavailable; try let dir = Netsys_posix.fdopendir(Unix.openfile "." [Unix.O_RDONLY] 0) in Unix.closedir dir with _ -> raise Unavailable in test_availability(); rm_dir_or_file Netsys_posix.at_fdcwd fn method rename flags oldname newname = let oldfn = real_root ^ check_and_norm_path oldname in let newfn = real_root ^ check_and_norm_path newname in Unix.rename oldfn newfn method symlink flags oldpath newpath = let oldfn = real_root ^ check_and_norm_path oldpath in let newfn = real_root ^ check_and_norm_path newpath in Unix.symlink oldfn newfn method readdir flags filename = let fn = real_root ^ check_and_norm_path filename in readdir (Unix.opendir fn) method readlink flags filename = let fn = real_root ^ check_and_norm_path filename in Unix.readlink fn method mkdir flags filename = if List.mem `Path flags then self#mkdir_p filename else ( let fn = real_root ^ check_and_norm_path filename in try Unix.mkdir fn 0o777 with | Unix.Unix_error(Unix.EEXIST,_,_) when List.mem `Nonexcl flags -> () ) method private mkdir_p filename = let rec traverse curdir todo = match todo with | [] -> () | d :: todo' -> let curdir' = curdir @ [d] in let p = String.concat "/" curdir' in let fn = real_root ^ p in ( try Unix.mkdir fn 0o777 with Unix.Unix_error(Unix.EEXIST,_,_) -> () ); traverse curdir' todo' in let fn1 = check_and_norm_path filename in let l = Netstring_str.split_delim slash_re fn1 in traverse [List.hd l] (List.tl l) method rmdir flags filename = let fn = real_root ^ check_and_norm_path filename in Unix.rmdir fn method copy flags srcfilename destfilename = copy_prim ~streaming:false self srcfilename self destfilename method cancel () = () (* This is totally legal here - the user has to invoke close_out anyway as part of the cancellation protocol. *) end ) let convert_path ?subst oldfs newfs oldpath = match oldfs#path_encoding, newfs#path_encoding with | Some oldenc, Some newenc -> Netconversion.convert ?subst ~in_enc:oldenc ~out_enc:newenc oldpath | _ -> oldpath let copy ?(replace=false) ?(streaming=false) orig_fs0 orig_name dest_fs0 dest_name = let orig_fs = (orig_fs0 :> stream_fs) in let dest_fs = (dest_fs0 :> stream_fs) in if replace then dest_fs # remove [] dest_name; try if orig_fs = dest_fs then orig_fs # copy [] orig_name dest_name else raise(Unix.Unix_error(Unix.ENOSYS,"","")) with | Unix.Unix_error(Unix.ENOSYS,_,_) | Unix.Unix_error(Unix.EXDEV,_,_) -> copy_prim ~streaming orig_fs orig_name dest_fs dest_name type file_kind = [ `Regular | `Directory | `Symlink | `Other | `None ] let iter ~pre ?(post=fun _ -> ()) fs0 start = let fs = (fs0 :> stream_fs) in let rec iter_members dir rdir = let files = fs # readdir [] dir in List.iter (fun file -> if file <> "." && file <> ".." then ( let absfile = dir ^ "/" ^ file in let relfile = if rdir="" then file else rdir ^ "/" ^ file in let l0 = fs#test_list [] absfile [`D; `F; `E] in let l1 = fs#test_list [`Link] absfile [`D; `F; `H] in let (is_dir0, is_reg0, is_existing) = match l0 with | [is_dir; is_reg; is_ex] -> (is_dir, is_reg, is_ex) | _ -> assert false in let (is_dir1, is_reg1, is_link) = match l1 with | [is_dir; is_reg; is_link] -> (is_dir, is_reg, is_link) | _ -> assert false in if is_dir1 then ( pre relfile `Directory `Directory; iter_members absfile relfile; post relfile ) else ( let t0 = if is_reg0 then `Regular else if is_dir0 then `Directory else if is_existing then `Other else `None in let t1 = if is_reg1 then `Regular else if is_dir1 then `Directory else if is_link then `Symlink else `Other in pre relfile t0 t1 ) ) ) files in iter_members start "" let copy_into ?(replace=false) ?subst ?streaming orig_fs0 orig_name dest_fs0 dest_name = let orig_fs = (orig_fs0 :> stream_fs) in let dest_fs = (dest_fs0 :> stream_fs) in let orig_base = Filename.basename orig_name in let dest_start = dest_name ^ "/" ^ convert_path ?subst orig_fs dest_fs orig_base in if not(dest_fs # test [] dest_name `D) then raise(Unix.Unix_error (Unix.ENOENT, "Netfs.copy_into: destination directory does not exist", dest_name)); if orig_fs # test [] orig_name `D then ( if replace then dest_fs # remove [ `Recursive ] dest_start; dest_fs # mkdir [ `Nonexcl ] dest_start; iter ~pre:(fun rpath typ link_typ -> let dest_rpath = convert_path ?subst orig_fs dest_fs rpath in match link_typ with | `Regular -> copy ?streaming orig_fs (orig_name ^ "/" ^ rpath) dest_fs (dest_start ^ "/" ^ dest_rpath) | `Directory -> dest_fs # mkdir [ `Nonexcl ] (dest_start ^ "/" ^ dest_rpath) | `Symlink -> dest_fs # symlink [] (orig_fs # readlink [] (orig_name ^ "/" ^ rpath)) (dest_start ^ "/" ^ dest_rpath) | `Other -> () ) orig_fs orig_name ) else copy ~replace ?streaming orig_fs orig_name dest_fs dest_start ocamlnet-4.1.6/src/netstring/netfs.mli0000644000175000017500000004537313274252310016411 0ustar gerdgerd(* $Id$ *) (** Class type [stream_fs] for filesystems with stream access to files *) (** The class type {!Netfs.stream_fs} is an abstraction for both kernel-level and user-level filesystems. It is used as parameter for algorithms (like globbing) that operate on filesystems but do not want to assume any particular filesystem. Only stream access is provided (no seek). {b File paths:} The filesystem supports hierarchical file names. File paths use Unix conventions, i.e. - [/] is the root - Path components are separated by slashes. Several consecutive slashes are allowed but mean the same as a single slash. - [.] is the same directory - [..] is the parent directory All paths need to be absolute (i.e. start with [/]). There can be additional constraints on paths: - Character encoding restriction: A certain ASCII-compatible character encoding is assumed (including UTF-8) - Character exclusion: Certain characters may be excluded Implementations may impose more constraints that cannot be expressed here (case insensitivity, path length, exclusion of special names etc.). {b Virtuality:} There is no assumption that [/] is the real root of the local filesystem. It can actually be anywhere - a local subdirectory, or a remote directory, or a fictive root. There needs not to be any protection against "running beyond root", e.g. with the path [/..]. This class type also supports remote filesystems, and thus there is no concept of file handle (because this would exclude a number of implementations). {b Errors: } Errors should generally be indicated by raising [Unix_error]. For many error codes the interpretation is already given by POSIX. Here are some more special cases: - [EINVAL]: should also be used for invalid paths, or when a flag cannot be supported (and it is non-ignorable) - [ENOSYS]: should also be used if an operation is generally unavailable In case of hard errors (like socket errors when communicating with the remote server) there is no need to stick to [Unix_error], though. {b Subtyping:} The class type {!Netfs.stream_fs} is subtypable, and subtypes can add more features by: - adding more methods - adding more flags to existing methods {b Omitted:} Real filesystems usually provide a lot more features than what is represented here, such as: - Access control and file permissions - Metadata like timestamps - Random access to files This definition here is intentionally minimalistic. In the future this class type will be extended, and more more common filesystem features will be covered. See {!Netfs.empty_fs} for a way how to ensure that your definition of a [stream_fs] can still be built after [stream_fs] has been extended. *) (** {2 The class type [stream_fs]} *) type read_flag = [ `Skip of int64 | `Binary | `Streaming | `Dummy ] type read_file_flag = [ `Binary | `Dummy ] type write_flag = [ `Create | `Exclusive | `Truncate | `Binary | `Streaming | `Dummy ] type write_file_flag = [ `Create | `Exclusive | `Truncate | `Binary | `Link | `Dummy ] type write_common = [ `Create | `Exclusive | `Truncate | `Binary | `Dummy ] (** The intersection of [write_flag] and [write_file_flag] *) type size_flag = [ `Dummy ] type test_flag = [ `Link | `Dummy ] type remove_flag = [ `Recursive | `Dummy ] type rename_flag = [ `Dummy ] type symlink_flag = [ `Dummy ] type readdir_flag = [ `Dummy ] type readlink_flag = [ `Dummy ] type mkdir_flag = [ `Path | `Nonexcl | `Dummy ] type rmdir_flag = [ `Dummy ] type copy_flag = [ `Dummy ] (** Note [`Dummy]: this flag is always ignored. There are two reasons for having it: - Ocaml does not allow empty variants - it is sometimes convenient to have it (e.g. in: [if then `Create else `Dummy]) *) type test_type = [ `N | `E | `D | `F | `H | `R | `W | `X | `S ] (** Tests: - [`N]: the file name exists - [`E]: the file exists - [`D]: the file exists and is a directory - [`F]: the file exists and is regular - [`H]: the file exists and is a symlink (possibly to a non-existing target) - [`R]: the file exists and is readable - [`W]: the file exists and is writable - [`X]: the file exists and is executable - [`S]: the file exists and is non-empty *) class type local_file = object method filename : string (** The filename *) method close : unit -> unit (** Indicate that we are done with the file *) end class type stream_fs = object method path_encoding : Netconversion.encoding option (** The encoding must be ASCII-compatible ({!Netconversion.is_ascii_compatible}). If [None] the ASCII encoding is assumed for codes 0-127, and no meaning is defined for byte codes 128-255. *) method path_exclusions : (int * int) list (** Code points that must not occur in path components between slashes. This is given as ranges [(from,to)]. The code points are interpreted as Unicode code points if an encoding is available, and as byte codes otherwise. For example, for Unix the code points 0 and 47 (slash) are normally the only excluded code points. *) method nominal_dot_dot : bool (** Whether the effect of [..] can be obtained by stripping off the last path component, i.e. whether [Filename.dirname path <=> path ^ "/.."] *) method read : read_flag list -> string -> Netchannels.in_obj_channel (** [read flags filename]: Opens the file [filename] for reading, and returns the input stream. Flags: - [`Skip n]: Skips the first [n] bytes of the file. On many filesystems this is more efficient than reading [n] bytes and dropping them; however, there is no guarantee that this optimization exists. - [`Binary]: Opens the file in binary mode (if there is such a distinction) - [`Streaming] for network filesystems: If possible, open the file in streaming mode, and avoid to copy the whole file to the local disk before returning the {!Netchannels.in_obj_channel}. Streaming mode is faster, but has also downsides. Especially, the implementation of [read] can do less to recover from transient network problems (like retrying the whole download). Support for this flag is optional, and it is ignored if there is no extra streaming mode. *) method read_file : read_file_flag list -> string -> local_file (** [read_file flags filename]: Opens the file [filename] for reading, and returns the contents as a [local_file]. Use the method [filename] to get the file name of the local file. The file may be temporary, but this is not required. The method [close] of the returned object should be called when the file is no longer needed. In case of a temporary file, the file can then be deleted. Flags: - [`Binary]: Opens the file in binary mode (if there is such a distinction) *) method write : write_flag list -> string -> Netchannels.out_obj_channel (** [write flags filename]: Opens (and optionally creates) the [filename] for writing, and returns the output stream. Flags: - [`Create]: If the file does not exist, create it - [`Truncate]: If the file exists, truncate it to zero before writing - [`Exclusive]: The [`Create] is done exclusively - [`Binary]: Opens the file in binary mode (if there is such a distinction) - [`Streaming]: see [read] (above) for explanations Some filesystems refuse this operation if neither [`Create] nor [`Truncate] is specified because overwriting an existing file is not supported. There are also filesystems that cannot even modify files by truncating them first, but only allow to write to new files. It is unspecified whether the file appears in the directory directly after calling [write] or first when the stream is closed. *) method write_file : write_file_flag list -> string -> local_file -> unit (** [write_file flags filename localfile]: Opens the file [filename] for writing, and copies the contents of the [localfile] to it. It is ensured that the method [close] of [localfile] is called once the operation is finished (whether successful or not). Flags: - [`Create]: If the (remote) file does not exist, create it - [`Truncate]: If the file exists, truncate it to zero before writing - [`Exclusive]: The [`Create] is done exclusively - [`Binary]: Opens the file in binary mode (if there is such a distinction) - [`Link]: Allows that the destination file is created as a hard link of the original file. This is tried whatever other mode is specified. If not successful, a copy is done instead. *) method size : size_flag list -> string -> int64 (** Returns the size of a file. Note that there is intentionally no distinction between text and binary mode - implementations must always assume binary mode. *) method test : test_flag list -> string -> test_type -> bool (** Returns whether the test is true. For filesystems that know symbolic links, the test operation normally follows symlinks (except for the [`N] and [`H] tests). By specifying the [`Link] flag symlinks are not followed. *) method test_list : test_flag list -> string -> test_type list -> bool list (** Similar to [test] but this function performs all tests in the list at once, and returns a bool for each test. *) method remove : remove_flag list -> string -> unit (** Removes the file or symlink. Implementation are free to also support the removal of empty directories. Flags: - [`Recursive]: Remove the contents of the non-empty directory recursively. This is an optional feature. There needs not to be any protection against operations done by other processes that affect the directory tree being deleted. *) method rename : rename_flag list -> string -> string -> unit (** Renames the file. There is no guarantee that a rename is atomic *) method symlink : symlink_flag list -> string -> string -> unit (** [symlink flags oldpath newpath]: Creates a symlink. This is an exclusive create, i.e. the operation fails if [newpath] already exists. *) method readdir : readdir_flag list -> string -> string list (** Reads the contents of a directory. Whether "." and ".." are returned is platform-dependent. The entries can be returned in any order. *) method readlink : readlink_flag list -> string -> string (** Reads the target of a symlink *) method mkdir : mkdir_flag list -> string -> unit (** Creates a new directory. Flags: - [`Path]: Creates missing parent directories. This is an optional feature. (If not supported, ENOENT is reported.) - [`Nonexcl]: Non-exclusive create. *) method rmdir : rmdir_flag list -> string -> unit (** Removes an empty directory *) method copy : copy_flag list -> string -> string -> unit (** Copies a file to a new name. This does not descent into directories. Also, symlinks are resolved, and the linked file is copied. *) method cancel : unit -> unit (** Cancels any ongoing [write]. The user must also call the [close_out] method after cancelling. The effect is that after the close no more network activity will occur. *) end class empty_fs : string -> stream_fs (** This is a class where all methods fail with [ENOSYS]. The string argument is the detail in the [Unix_error], normally the module name of the user of this class. [empty_fs] is intended as base class for implementations of [stream_fs] outside Ocamlnet. When [stream_fs] is extended by new methods, these methods are at least defined, and no build error occurs. So the definition should look like {[ class my_fs ... = object inherit Netfs.empty_fs "my_fs" method read flags name = ... (* Add here all methods you can define, and omit the rest *) end ]} *) val local_fs : ?encoding:Netconversion.encoding -> ?root:string -> ?enable_relative_paths:bool -> unit -> stream_fs (** [local_fs()]: Returns a filesystem object for the local filesystem. - [encoding]: Specifies the character encoding of paths. The default is system-dependent. - [root]: the root of the returned object is the directory [root] of the local filesystem. If omitted, the root is the root of the local filesystem (i.e. / for Unix, and see comments for Windows below). Use [root="."] to make the current working directory the root. Note that "." like other relative paths are interpreted at the time when the access method is executed. - [enable_relative_paths]: Normally, only absolute paths can be passed to the access methods like [read]. By setting this option to [true] one can also enable relative paths. These are taken relative to the working directory, and not relative to [root]. Relative names are off by default because there is usually no counterpart in network filesystems. *) (** {2 OS Notes} *) (** {b Unix} in general: There is no notion of character encoding of paths. Paths are just bytes. Because of this, the default encoding is [None]. If a different encoding is passed to [local_fs], these bytes are just interpreted in this encoding. There is no conversion. For desktop programs, though, usually the character encoding of the locale is taken for filenames. You can get this by passing {[ let encoding = Netconversion.user_encoding() ]} as [encoding] argument. *) (** {b Windows}: If the [root] argument is {b not} passed to [local_fs] it is possible to access the whole filesystem: - Paths starting with drive letters like [c:/] are also considered as absolute - Additionally, paths starting with slashes like [/c:/] mean the same - UNC paths starting with two slashes like [//hostname] are supported However, when a [root] directory is passed, these additional notations are not possible anymore - paths must start with [/], and there is neither support for drive letters nor for UNC paths. The [encoding] arg defaults to current ANSI codepage, and it is not supported to request a different encoding. (The difficulty is that the Win32 bindings of the relevant OS functions always assume the ANSI encoding.) There is no support for backslashes as path separators (such paths will be rejected), for better compatibility with other platforms. *) (** {2:links Other impementations of [stream_fs]} *) (** List: - {!Nethttp_fs} allows one to access HTTP-based filesystems - {!Netftp_fs} allows on to access filesystems via FTP - {!Shell_fs} allows one to access filesystems by executing shell commands. This works locally and via ssh. There are even some implementations outside Ocamlnet: - {{:http://projects.camlcity.org/projects/webdav.html} Webdav} provides an extension of {!Nethttp_fs} for the full WebDAV set of filesystem operations *) (** {2 Algorithms} *) val copy : ?replace:bool -> ?streaming:bool -> #stream_fs -> string -> #stream_fs -> string -> unit (** [copy orig_fs orig_name dest_fs dest_name]: Copies the file [orig_name] from [orig_fs] to the file [dest_name] in [dest_fs]. By default, the destination file is truncated and overwritten if it already exists. If [orig_fs] and [dest_fs] are the same object, the [copy] method is called to perform the operation. Otherwise, the data is read chunk by chunk from the file in [orig_fs] and then written to the destination file in [dest_fs]. Symlinks are resolved, and the linked file is copied, not the link as such. The copy does not preserve ownerships, file permissions, or timestamps. (The [stream_fs] object does not represent these.) There is no protection against copying an object to itself. - [replace]: If set, the destination file is removed and created again if it already exists - [streaming]: use streaming mode for reading and writing files *) val copy_into : ?replace:bool -> ?subst:(int->string) -> ?streaming:bool -> #stream_fs -> string -> #stream_fs -> string -> unit (** [copy_into orig_fs orig_name dest_fs dest_name]: Like [copy], but this version also supports recursive copies. The [dest_name] must be an existing directory, and the file or tree at [orig_name] is copied into it. Symlinks are copied as symlinks. If [replace] and the destination file/directory already exists, it is deleted before doing the copy. - [subst]: See {!Netfs.convert_path} - [streaming]: use streaming mode for reading and writing files *) type file_kind = [ `Regular | `Directory | `Symlink | `Other | `None ] val iter : pre:(string -> file_kind -> file_kind -> unit) -> ?post:(string -> unit) -> #stream_fs -> string -> unit (** [iter pre fs start]: Iterates over the file hierarchy at [start]. The function [pre] is called for every filename. The filenames passed to [pre] are relative to [start]. The [start] must be a directory. For directories, the [pre] function is called for the directory before it is called for the members of the directories. The function [post] can additionally be passed. It is only called for directories, but after the members. [pre] is called as [pre rk lk] where [rk] is the file kind after following symlinks and [lk] the file kind without following symlinks (the link itself). Example: [iter pre fs "/foo"] would call - [pre "dir" `Directory `Directory] (meaning the directory "/foo/dir") - [pre "dir/file1" `File `File] - [pre "dir/file2" `File `Symlink] - [post "dir"] Note: symlinks to non-existing files are reported as [pre name `None `Symlink]. *) val convert_path : ?subst:(int -> string) -> #stream_fs -> #stream_fs -> string -> string (** [convert_path oldfs newfs oldpath]: The encoding of [oldpath] (which is assumed to reside in [oldfs]) is converted to the encoding of [newfs] and returned. It is possible that the conversion is not possible, and the function [subst] is then called with the problematic code point as argument (in the encoding of [oldfs]). The default [subst] function just raises {!Netconversion.Cannot_represent}. If one of the filesystem objects does not specify an encoding, the file name is not converted, but simply returned as-is. This may result in errors when [newfs] has an encoding while [oldfs] does not have one because the file name might use byte representations that are illegal in [newfs]. *) ocamlnet-4.1.6/src/netstring/netglob.ml0000644000175000017500000006144013274252310016544 0ustar gerdgerd(* $Id$ *) open Netglob_lex open Printf type glob_expr = glob_expr_atom list and glob_expr_atom = [ `Literal of string | `Star | `Qmark | `Bracket of (bool * glob_set) | `Brace of glob_expr list | `Tilde of string ] and glob_set = < set : (int * int) list > type valid_glob_expr = { pat : glob_expr; encoding : Netconversion.encoding; } exception Bad_glob_expr of string exception Unsupported_expr of string class type user_info = object method path_encoding : Netconversion.encoding option method home_directory : string -> string end class type glob_fsys = object method path_encoding : Netconversion.encoding option method read_dir : string -> string list method file_is_dir : string -> bool method file_exists : string -> bool end type glob_mode = [ `Existing_paths | `All_paths | `All_words ] type pattern = [ `String of string | `Expr of valid_glob_expr ] let literal_glob_expr enc s = { pat = [ `Literal s ]; encoding = enc } let reparse_bracket_expr enc l = (* In order to support multi-byte encodings, reparse the expression now. For simplifying this, we require that ranges (like c-d) are purely ASCII. So only the chars outside ranges need to be reparsed *) let rec collect buf toks = match toks with | Bracket_char c :: toks' -> Buffer.add_char buf c; collect buf toks' | Bracket_range(c1,c2) as tok :: toks' -> let new_toks = reparse buf in new_toks @ [tok] @ collect (Buffer.create 80) toks' | Bracket_code _ :: _ -> assert false | Bracket_end :: _ | [] -> reparse buf and reparse buf = let s = Buffer.contents buf in let codes = ref [] in ( try Netconversion.ustring_iter enc (fun i -> codes := i :: !codes) s with _ -> raise Lexing_Error ); List.rev_map (fun i -> Bracket_code i) !codes in collect (Buffer.create 80) l let parse_glob_expr ?(encoding = `Enc_iso88591) ?(enable_star = true) ?(enable_qmark = true) ?(enable_brackets = true) ?(enable_braces = true) ?(enable_tilde = true) ?(enable_escape = true) s = if not (Netconversion.is_ascii_compatible encoding) then failwith "Netglob.parse_glob_expr: the encoding is not ASCII-compatible"; let feat = { enable_star = enable_star; enable_qmark = enable_qmark; enable_brackets = enable_brackets; enable_braces = enable_braces; enable_tilde = enable_tilde; enable_escape = enable_escape; escaped = false; } in let rec collect_until lexbuf = let tok = glob_expr feat lexbuf in if tok = Glob_end then [] else tok :: (collect_until lexbuf) in let rec process_brace_list current list = match list with | Brace_literal s :: list' -> let gl = collect_until (Lexing.from_string s) in process_brace_list (current @ gl) list' | Brace_braces l :: list' -> process_brace_list (current @ [Glob_braces l]) list' | Brace_comma :: list' -> let ge = process_glob_list [] current in ge :: process_brace_list [] list' | Brace_end :: _ -> assert false | [] -> let ge = process_glob_list [] current in [ ge ] and process_glob_list acc list = match list with | Glob_star :: list' -> ( match acc with | `Star :: acc' -> (* Ignore the second star! *) process_glob_list acc list' | _ -> process_glob_list (`Star :: acc) list' ) | Glob_qmark :: list' -> process_glob_list (`Qmark :: acc) list' | Glob_brackets (neg,btoks) :: list' -> let set = List.map (function | Bracket_char c -> assert false | Bracket_range (c1,c2) -> (* c1, c2 are ASCII *) (Char.code c1, Char.code c2) | Bracket_code i -> (i, i) | Bracket_end -> assert false ) (reparse_bracket_expr encoding btoks) in let set_obj = ( object method set = set end ) in process_glob_list (`Bracket(neg,set_obj) :: acc) list' | Glob_braces btoks :: list' -> let alts = process_brace_list [] btoks in process_glob_list (`Brace alts :: acc) list' | Glob_literal s :: list' -> if s <> "" then ( match acc with | `Literal s' :: acc' -> process_glob_list (`Literal(s' ^ s) :: acc') list' | _ -> process_glob_list (`Literal s :: acc) list' ) else process_glob_list acc list' | Glob_tilde(s,slash) :: list' -> let atoms = if slash then [ `Literal "/"; `Tilde s ] else [ `Tilde s ] in process_glob_list ( atoms @ acc ) list' | Glob_end :: _ -> assert false | [] -> List.rev acc in try let glob_list = collect_until (Lexing.from_string s) in let glob_expr = process_glob_list [] glob_list in { pat = glob_expr; encoding = encoding } with | Bracket_Unsupported -> raise (Unsupported_expr s) | Lexing_Error -> raise (Bad_glob_expr s) let validate_glob_expr enc expr = let checkenc s = try Netconversion.verify enc s with _ -> failwith "Netglob.validate_glob_expr: literal does not conform \ to selected pattern encoding" in let rec validate ge = match ge with | `Literal s :: ge' -> if s = "" then failwith "Netglob.validate_glob_expr: empty literal"; checkenc s; validate ge' | `Bracket(_,set) :: ge' -> List.iter (fun (j,k) -> if j < 0 || k < 0 || j > k then failwith "Netglob.validate_glob_expr: bad bracket set"; ) set#set | `Brace l :: ge' -> List.iter validate l; validate ge' | `Tilde s :: ge' -> checkenc s; validate ge' | _ :: ge' -> validate ge' | [] -> () in if not (Netconversion.is_ascii_compatible enc) then failwith "Netglob.validate_glob_expr: the encoding is not ASCII-compatible"; validate expr; { pat = expr; encoding = enc } let recover_glob_expr expr = expr.pat let encoding_of_glob_expr expr = expr.encoding (* A more efficient representation for sets: *) type eff_set = { ascii : bool array; non_ascii : (int, unit) Hashtbl.t } let to_eset set = let ascii = Array.make 128 false in let non_ascii = Hashtbl.create 13 in List.iter (fun (k0,k1) -> assert(k0 <= k1); for p = k0 to k1 do if p < 128 then ascii.(p) <- true else Hashtbl.replace non_ascii p () done ) set; { ascii = ascii; non_ascii = non_ascii } let rec mem_eset code eset = if code >= 0 && code < 128 then eset.ascii.(code) else Hashtbl.mem eset.non_ascii code let size_eset eset = let n = ref 0 in for k = 0 to 127 do if eset.ascii.(k) then incr n done; !n + Hashtbl.length eset.non_ascii let ascii_ranges eset = let ranges = ref [] in let inrange = ref None in for k = 0 to 127 do let p = eset.ascii.(k) in match !inrange with | None -> if p then inrange := Some k | Some q -> if not p then ( ranges := (q, k-1) :: !ranges; inrange := None; ) done; ( match !inrange with | None -> () | Some q -> ranges := (q, 127) :: !ranges ); List.rev !ranges let rec exclude_set codes set = match set with [] -> [] | (x,y) :: set' -> let x' = if List.mem x codes then x+1 else x in let y' = if List.mem y codes then y-1 else y in if x = x' && y = y' && x <= y then (x,y) :: exclude_set codes set' else if x' <= y' then exclude_set codes ( (x',y') :: set') else exclude_set codes set' let print_set buf encoding neg_char negated set = (* Always produce a portable expression: *) let eset = to_eset set in (* Check for special characters: *) let want_minus = mem_eset (Char.code '-') eset in let want_rbracket = mem_eset (Char.code ']') eset in let want_circum = mem_eset (Char.code '^') eset in let want_exclam = mem_eset (Char.code '!') eset in let size = size_eset eset in (* Check for very special sets: *) if not negated && want_circum && size = 1 then Buffer.add_string buf "^" (* "[^]" would not be portable enough *) else if not negated && want_exclam && size = 1 then Buffer.add_string buf "!" (* "[!]" would not be portable enough *) else if not negated && want_circum && want_exclam && size = 2 then failwith "print_glob_expr" (* There is no portable representation *) else ( (* First create a set expression where the special characters * '-', ']', '^', and '!' do not occur literally. *) let empty = ref true in let buf' = Buffer.create 200 in let ascii_part = ascii_ranges eset in let ascii_part' = exclude_set (List.map Char.code ['-'; ']'; '^'; '!']) ascii_part in let ascii_part'_eset = to_eset ascii_part' in List.iter (fun (x0,x1) -> if x0 = x1 then ( Buffer.add_char buf' (Char.chr x0); empty := false; ) else if x0 <= x1 then ( Buffer.add_char buf' (Char.chr x0); Buffer.add_char buf' '-'; Buffer.add_char buf' (Char.chr x1); empty := false; ) ) ascii_part'; (* The non-ascii part is easy: *) Hashtbl.iter (fun code _ -> let encoded = Netconversion.ustring_of_uarray encoding [| code |] in Buffer.add_string buf' encoded ) eset.non_ascii; (* Check which of the special characters are already covered * by ranges: *) let done_minus = mem_eset (Char.code '-') ascii_part'_eset in let done_rbracket = mem_eset (Char.code ']') ascii_part'_eset in let done_circum = mem_eset (Char.code '^') ascii_part'_eset in let done_exclam = mem_eset (Char.code '!') ascii_part'_eset in (* Begin with printing *) Buffer.add_string buf (if negated then "[" ^ String.make 1 neg_char else "["); (* ']' must always be the first character of the set: *) if want_rbracket && not done_rbracket then ( Buffer.add_string buf "]"; empty := false; ); Buffer.add_buffer buf buf'; (* '-' must be the first or the last character; '^' and '!' must * not be the first character. So we usually print these * characters in the order "^!-". One case is special: We have * not yet printed any character. Then, "-" must be printed * first (if member of the set), or we have one of the very * special cases already tested above. *) if !empty then ( if want_minus && not done_minus then Buffer.add_char buf '-'; if want_circum && not done_circum then Buffer.add_char buf '^'; if want_exclam && not done_exclam then Buffer.add_char buf '!'; ) else ( if want_circum && not done_circum then Buffer.add_char buf '^'; if want_exclam && not done_exclam then Buffer.add_char buf '!'; if want_minus && not done_minus then Buffer.add_char buf '-'; ); Buffer.add_char buf ']'; ) let esc_re = Netstring_str.regexp "[][*?{},\\~]";; let esc_subst m s = "\\" ^ Netstring_str.matched_group m 0 s let print_glob_expr ?(escape_in_literals=true) expr = let buf = Buffer.create 200 in let rec print gl = match gl with | `Literal s :: gl' -> Buffer.add_string buf (if escape_in_literals then Netstring_str.global_substitute esc_re esc_subst s else s ); print gl' | `Star :: gl' -> Buffer.add_string buf "*"; print gl' | `Qmark :: gl' -> Buffer.add_string buf "?"; print gl' | `Bracket (negated,set) :: gl' -> print_set buf expr.encoding '!' negated set#set; print gl' | `Brace ge_list :: gl' -> Buffer.add_string buf "{"; let first = ref true in List.iter (fun ge -> if not !first then Buffer.add_string buf ","; print ge; ) ge_list; Buffer.add_string buf "}"; print gl' | `Tilde s :: gl' -> Buffer.add_char buf '~'; Buffer.add_string buf s; print gl' | [] -> () in print expr.pat; Buffer.contents buf class local_user_info() = let pe = match Sys.os_type with | "Win32" -> Netconversion.user_encoding() | _ -> None in object method path_encoding = pe method home_directory name = (* Win32: only the HOME method works *) try if name = "" then ( try Sys.getenv "HOME" with Not_found -> let pw = Unix.getpwuid(Unix.getuid()) in pw.Unix.pw_dir ) else (Unix.getpwnam name).Unix.pw_dir with | _ -> raise Not_found end let local_user_info = new local_user_info let rec product f l1 l2 = match l1 with [] -> [] | x1 :: l1' -> List.map (fun x2 -> f x1 x2) l2 @ product f l1' l2 let rec expand_braces ge = match ge with | [] -> [ [] ] | `Brace gelist :: ge' -> let gelist' = List.flatten (List.map expand_braces gelist) in let ge_alts' = expand_braces ge' in product ( @ ) gelist' ge_alts' | any :: ge' -> let ge_alts' = expand_braces ge' in List.map (fun ge_alt' -> any :: ge_alt') ge_alts' let rec expand_tildes encoding user_info ge = match ge with | [] -> [] | `Tilde name :: ge' -> let atom = try let dir = user_info#home_directory name in if dir="" then raise Not_found; (* empty literals not allowed *) ( match user_info#path_encoding with | None -> `Literal dir | Some ui_enc -> if ui_enc = encoding then `Literal dir else `Literal (Netconversion.convert ~in_enc:ui_enc ~out_enc:encoding dir) ) with Not_found -> `Literal ("~" ^ name) in atom :: expand_tildes encoding user_info ge' | any :: ge' -> any :: expand_tildes encoding user_info ge' let expand_glob_expr ?(user_info=local_user_info()) ?(expand_brace=true) ?(expand_tilde=true) expr = let pat' = if expand_tilde then expand_tildes expr.encoding user_info expr.pat else expr.pat in let pat_l = if expand_brace then expand_braces pat' else [pat'] in List.map (fun p -> { expr with pat = p }) pat_l let period = Char.code '.' let slash = Char.code '/' let match_glob_expr ?(protect_period=true) ?(protect_slash=true) ?encoding expr s = let esets = Hashtbl.create 5 in let get_eset set = try Hashtbl.find esets set with Not_found -> let eset = to_eset set#set in Hashtbl.add esets set eset; eset in let u = Netconversion.uarray_of_ustring ( match encoding with | None -> expr.encoding | Some e -> e ) s in let n = Array.length u in let leading_period p = u.(p) = period && (p = 0 || (protect_slash && u.(p - 1) = slash)) in let rec match_at c ge = match ge with | `Literal lit :: ge' -> let lit_u = Netconversion.uarray_of_ustring expr.encoding lit in let lit_n = Array.length lit_u in let ok = try for k = 0 to lit_n - 1 do if c+k >= n then raise Not_found; let code = u.(c+k) in if code <> lit_u.(k) then raise Not_found; done; true with | Not_found -> false in ok && match_at (c+lit_n) ge' | `Star :: ge' -> let k = ref 0 in let cont = ref true in let found = ref false in while c + !k <= n && not !found && !cont do found := match_at (c + !k) ge'; if c + !k < n then cont := (not protect_period || not (leading_period (c + !k))) && (not protect_slash || u.(c + !k) <> slash); incr k; done; !found | `Qmark :: ge' -> let ok = c < n && (not protect_period || not (leading_period c)) && (not protect_slash || u.(c) <> slash) in ok && match_at (c+1) ge' | `Bracket(neg,set) :: ge' -> let ok = c < n && ( let code = u.(c) in (not protect_slash || code <> slash) && (not protect_period || not (leading_period c)) && ( let eset = get_eset set in let is_mem = mem_eset code eset in (neg <> is_mem) ) ) in ok && match_at (c+1) ge' | `Brace _ :: _ -> failwith "Netglob.match_glob_expr: found `Brace subpattern" | `Tilde _ :: _ -> failwith "Netglob.match_glob_expr: found `Tilde subpattern" | [] -> c = n in match_at 0 expr.pat let skip_slashes s k = let l = String.length s in let j = ref k in while !j < l && s.[!j] = '/' do incr j done; !j let rev_skip_slashes s k = let j = ref k in while !j >= 0 && s.[!j] = '/' do decr j done; !j let search_slash s = let k = String.index s '/' in let j = skip_slashes s (k+1) in (k, j) let split_glob_expr expr = let rec split_loop is_first acc ge = (* acc: accumulates the current component *) match ge with | [] -> [ List.rev acc ] | (`Literal s as atom) :: ge' -> assert(s <> ""); ( try let (k,j) = search_slash s in (* or Not_found *) let l = String.length s in let s1 = String.sub s 0 k in (* part before '/' *) let s2 = String.sub s j (l - j) in (* part after '/' *) if is_first && k = 0 then ( (* Case: rooted expression *) let ge'' = if s2 <> "" then (`Literal s2) :: ge' else ge' in let comps = split_loop false [] ge'' in (* N.B. comps is a list of lists... *) match comps with | ( (`Literal s3) :: r ) :: l -> ( `Literal("/" ^ s3) :: r) :: l | r :: l -> (`Literal "/" :: r) :: l | [] -> [ [ `Literal "/" ] ] ) else if ge' = [] && s2 = "" then ( (* Case: component matches only directory *) [ List.rev (`Literal (s1 ^ "/") :: acc) ] ) else ( let acc' = if s1 <> "" then (`Literal s1)::acc else acc in let ge'' = if s2 <> "" then (`Literal s2) :: ge' else ge' in (List.rev acc') :: split_loop false [] ge'' ) with | Not_found -> split_loop false (atom::acc) ge' ) | (`Star | `Qmark | `Bracket(_,_) as atom) :: ge' -> split_loop false (atom::acc) ge' | `Brace _ :: _ -> failwith "Netglob.split_glob_expr: brace expression found" | `Tilde _ :: _ -> failwith "Netglob.split_glob_expr: tilde expression found" in List.map (fun p -> { expr with pat = p }) (split_loop true [] expr.pat) let check_rooted_glob_expr expr = match expr.pat with | (`Literal s) :: r -> assert(s <> ""); if s.[0] = '/' then ( let j = skip_slashes s 1 in let l = String.length s in let s' = String.sub s j (l - j) in (* part after '/' *) if s' = "" then Some { expr with pat = r } else Some { expr with pat = `Literal s' :: r } ) else None | _ -> None let check_directory_glob_expr expr = match List.rev expr.pat with | (`Literal s) :: r -> assert(s <> ""); ( try let l = String.length s in if s.[l-1] <> '/' then raise Not_found; let k = rev_skip_slashes s (l-1) + 1 in let s' = String.sub s 0 k in (* the part before '/' *) if s' = "" then Some { expr with pat = List.rev r } else Some { expr with pat = List.rev (`Literal s' :: r) } with Not_found -> None ) | _ -> None class of_dual_stream_fs (abs_fs:Netfs.stream_fs) rel_fs = let is_abs name = name <> "" && name.[0] = '/' in let fix name = if is_abs name then (abs_fs, name) else (rel_fs, "/" ^ name) in object method path_encoding = abs_fs#path_encoding method read_dir name = let (fs,name) = fix name in try fs#readdir [] name with _ -> [] method file_is_dir name = let (fs,name) = fix name in try fs#test [] name `D with _ -> false method file_exists name = let (fs,name) = fix name in try fs#test [] name `E with _ -> false end class of_stream_fs fs0 = let fs = (fs0 : #Netfs.stream_fs :> Netfs.stream_fs) in of_dual_stream_fs fs fs let of_stream_fs = new of_stream_fs class local_fsys ?encoding () = let abs_fs = Netfs.local_fs ?encoding () in let rel_fs = Netfs.local_fs ?encoding ~root:"." () in of_dual_stream_fs abs_fs rel_fs let local_fsys = new local_fsys let fn_concat d f = let l = String.length d in if l = 0 || d.[l-1] = '/' then d ^ f else d ^ "/" ^ f let glob1 ?base_dir ?(protect_period=true) ?(fsys = local_fsys()) ?user_info ?(mode = `Existing_paths) expr = (* File names and paths are encoded as [fsys] demands it. The encoding of the pattern can be different! *) let rec collect_and_match base_dir generated_prefix components = match components with | [] -> if generated_prefix <> "" then [ generated_prefix ] else [] | comp :: components' -> let full_path file = match base_dir with | Some d -> fn_concat d file | None -> file in let dir_ge = check_directory_glob_expr comp in let comp' = match dir_ge with | Some ge' -> ge' | None -> comp in let check_for_match only_dirs e file = (* file is encoded in fsys#path_encoding. For matching, we need to convert it to the encoding of the pattern. *) try let pe = match fsys#path_encoding with | None -> `Enc_iso88591 (* so no conv errors possible *) | Some pe -> pe in match_glob_expr ~protect_period ~encoding:pe e file && (not only_dirs || fsys#file_is_dir (full_path file)) with | Netconversion.Cannot_represent _ -> false in let files = match comp'.pat with | [ `Literal s ] -> (* s is encoded in expr.encoding. We need it here in the fsys#encoding *) ( try let s' = match fsys#path_encoding with | None -> s | Some pe -> Netconversion.convert ~in_enc:expr.encoding ~out_enc:pe s in match mode with | `Existing_paths -> let path = full_path s' in if fsys # file_exists path then [ s' ] else [] | _ -> [ s' ] with Netconversion.Cannot_represent _ when mode = `Existing_paths -> [] ) | _ -> let only_dirs = components' <> [] || dir_ge <> None in let file_list = fsys#read_dir (full_path ".") in (*eprintf "Files in %s: %s\n%!" (full_path ".") (String.concat "," file_list);*) List.filter (check_for_match only_dirs comp') file_list in List.flatten (List.map (fun file -> let prefixed_file = fn_concat generated_prefix file ^ (if dir_ge <> None then "/" else "") in collect_and_match (Some(full_path file)) prefixed_file components' ) files ) in let collect_and_match_0 components = match components with | comp :: components' -> ( match check_rooted_glob_expr comp with | None -> collect_and_match base_dir "" components | Some comp' -> if comp'.pat = [] then (* Special case "/" *) [ "/" ] else collect_and_match (Some "/") "/" (comp' :: components') ) | [] -> [] in let e_list = expand_glob_expr ?user_info expr in List.flatten (List.map (fun e' -> let l = collect_and_match_0 (split_glob_expr e') in if mode = `All_words && l = [] && e'.pat <> [] then [print_glob_expr e'] else l ) e_list ) let glob ?encoding ?base_dir ?protect_period ?fsys ?user_info ?mode pat = match pat with | `Expr e -> glob1 ?base_dir ?protect_period ?fsys ?user_info ?mode e | `String s -> let e = parse_glob_expr ?encoding s in glob1 ?base_dir ?protect_period ?fsys ?user_info ?mode e ocamlnet-4.1.6/src/netstring/netglob.mli0000644000175000017500000005131713274252310016717 0ustar gerdgerd(* $Id$ *) (** Globbing *) (** Globbing resolves shell wildcards like "*" and "?". For example, {[ let files = Netglob.glob (`String "*.cm[iox]") ]} would return all files matching this pattern (e.g. module.cmi, module.cmo). The main user function is {!Netglob.glob}. Globbing accesses the local filesystem by default, but one can also run the globbing algorithm on any other filesystem, provided the access primitives of {!Netglob.glob_fsys} are available. *) (** {2 Types and exceptions} *) type glob_expr = glob_expr_atom list and glob_expr_atom = [ `Literal of string | `Star | `Qmark | `Bracket of (bool * glob_set) | `Brace of glob_expr list | `Tilde of string ] (** Atoms: - [`Literal s]: Matches the string literally. The string must not be empty. The backslash is not an escape character, but matches the backslash character. - [`Star]: The "*" operator - [`Qmark]: The "?" operator - [`Bracket(negated,set)]: The [[...]] operator. The [set] argument describes the characters that are matched. The [negated] argument is true when the expression is negated (i.e. [[^...]]). - [`Brace l]: The [{e1,e2,...}] operator - [`Tilde t]: The [~username] operator. If [t=""] the current user is meant. The [`Tilde] atom may only occur at the beginning of the list. The [`Tilde] atom always matches a directory, and must be followed by a literal slash (if anything follows). Compatibility: Conforms to POSIX with extensions (braces). Shells often implement brace expressions in a slightly different way (braces are parsed and expanded in a separate step before the other pattern constructors are handled). The cases where this leads to different results are quite exotic (e.g. ["{~g,~h}1"] would mean ["~g1 ~h1"], but this implementation rejects the pattern). *) and glob_set = < set : (int * int) list > (** A set of code points is given as a list of ranges [(from,to)], with [from <= to]. It is allowed that ranges overlap. *) type valid_glob_expr (** A validated [glob_expr] *) (** Access to the user database *) class type user_info = object method path_encoding : Netconversion.encoding option (** Paths of filesystems may be encoded *) method home_directory : string -> string (** Returns the home directory of the passed user, or the home directory of the current user for the empty string. Raises [Not_found] if the lookup fails. *) end (** Filesystem primitives. This is intentionally not the same as {!Netfs.stream_fs} because only a few access functions are needed here, and because the functions here should also be capable of accessing relative paths (not starting with /). It is possible to turn a {!Netfs.stream_fs} into {!Netglob.glob_fs} by calling {!Netglob.of_stream_fs}. *) class type glob_fsys = object method path_encoding : Netconversion.encoding option (** Paths of filesystems may be encoded *) method read_dir : string -> string list (** Returns the file names contained in the directory, without path. The names "." and ".." should be returned. It is acceptable to return the empty list for an unreadable directory. *) method file_is_dir : string -> bool (** Whether the file name is valid and a directory, or a symlink to a directory. *) method file_exists : string -> bool (** Whether the file name is valid and refers to an existing file, or to a symlink pointing to an existing file. *) end type glob_mode = [ `Existing_paths | `All_paths | `All_words ] (** Modes: - [`Existing_paths]: Only paths are returned that really exist - [`All_paths]: Generated paths not including [*], [?] and bracket expressions are returned even if they do not exist. For example, globbing for ["fictive{1,2,3}"] would return [["ficitve1";"fictive2";"fictive3"]] independent of whether these files exist. - [`All_words]: Patterns that cannot be resolved are returned as-is (like the shell does) *) type pattern = [ `String of string | `Expr of valid_glob_expr ] (** Input for {!Netglob.glob} *) exception Bad_glob_expr of string (** An syntax error in the glob expression; the argument is the bad expression *) exception Unsupported_expr of string (** The notations [:class:], [.symbol.], [=eqclass=] inside [...] are * not supported by this implementation. If they are found, this exception * will be raised, and the argument is the whole glob expression *) (** {2 Parsing and printing} *) val parse_glob_expr : ?encoding:Netconversion.encoding -> ?enable_star:bool -> (* Recognize "*" *) ?enable_qmark:bool -> (* Recognize "?" *) ?enable_brackets:bool -> (* Recognize "[set]" *) ?enable_braces:bool -> (* Recognize "{alt,...}" *) ?enable_tilde:bool -> (* recognize ~ *) ?enable_escape:bool -> (* Recognize backslash as escape char *) string -> valid_glob_expr (** Parses the glob expression. By default, all syntax features are enabled. * May raise [Bad_glob_expr] or [Unsupported_expr]. * * The glob expressions are POSIX-compliant with the extension of * brace expressions, and tildes, and the omission of internationalized * bracket expressions: * - [*]: Matches a sequence of zero or more arbitrary characters * - [?]: Matches one arbitrary character * - [[abc]]: Matches one of the mentioned characters * - [[a-z]]: Matches one of the characters of the range. This is here * only permitted when the range falls into the ASCII set. (Otherwise * the interpretation would be dependent on the encoding.) Note that * the ASCII restriction does not comply to POSIX. * - [[!expr]] or [[^expr]]: Negates the bracket expression * - [{expr,expr,...}]: Generates a string for each of the alternatives. * A brace expression is even recognized if there is no comma, or even * no contents (i.e. ["{expr}"] and ["{}"]). The elements of brace expressions * may be again glob expressions; nested brace expressions are allowed. * - [~username]: Generates the home directory of this user * - [~]: Generates the home directory of the current user * - If enabled, the backslash character is the escape character. Within * bracket expressions, the backslash character never escapes. * - Not supported: Collating symbols [[.a.]], equivalence classes * [[=a=]], and character classes [[:name:]]. If they are found, the * exception [Unsupported_expr] will be raised. * * Glob expressions have a character [encoding]. This defaults to * [`Enc_iso88591]. Encodings must be ASCII-compatible. *) val validate_glob_expr : Netconversion.encoding -> glob_expr -> valid_glob_expr (** Checks whether the passed expression is syntactically valid. If so, a validated expression is returned. Otherwise, this function fails. *) val recover_glob_expr : valid_glob_expr -> glob_expr (** Returns the explicit representation *) val encoding_of_glob_expr : valid_glob_expr -> Netconversion.encoding (** Returns the encoding *) val literal_glob_expr : Netconversion.encoding -> string -> valid_glob_expr (** Returns an expression that matches literally the passed string *) val print_glob_expr : ?escape_in_literals:bool -> valid_glob_expr -> string (** Prints the glob expression as string. Meta characters are * escaped by a backslash when possible. Meta characters are: * ["*"], ["?"], ["["], ["]"], ["{"], ["}"], [","], ["~"] and ["\\"] * * - [escape_in_literals]: Whether meta characters in [`Literal] * subexpressions are escaped. This is true by default. *) (** {2 Operations on [valid_glob_expr]} *) val expand_glob_expr : ?user_info:user_info -> ?expand_brace:bool -> ?expand_tilde:bool -> valid_glob_expr -> valid_glob_expr list (** Resolve generative sub expressions by expanding them. The returned * list of glob expr no longer contains the expanded constructions. * * - [expand_brace]: Expands [`Brace] subexpressions. * - [expand_tilde]: Expands [`Tilde] subexpressions. * - [user_info]: The subset of file system operations needed for tilde * expansion. Defaults to {!Netglob.local_user_info} (see below). * * Both [expand_*] options are enabled by default. *) val match_glob_expr : ?protect_period:bool -> (* Protect leading dots; default: true *) ?protect_slash:bool -> (* Protect slashes; default: true *) ?encoding:Netconversion.encoding -> valid_glob_expr -> string -> bool (** Matches the glob_expr against a string. * * The input must neither contain brace expressions nor tildes (i.e. call * [expand_glob_expr] first). The function fails if it encounters such an * expression. * * - [protect_period]: If true, a leading period cannot be not matched by * [*], [?], [[...]], but only by a literal [.]. A leading period is * a [.] at the beginning of the string to be matched against, or * if also [protect_slash] a [.] after a [/] * - [protect_slash]: If true, a slash cannot be matched by [*], [?], [[...]], * but only by a literal [/] * * Both options are enabled by default. * * - [encoding]: The encoding of the string argument. Defaults to the * encoding of the glob pattern. *) val split_glob_expr : valid_glob_expr -> valid_glob_expr list (** Splits the glob expression into filename components separated by * literal [/] characters. For example, for the glob expression * ["a*b/c/d?"], the list [["a*b"; "c"; "d?"]] is returned. * * If the first component begins with a slash, the slash is not removed * from the first returned list element, e.g. for ["/ab/c*"], the list * [[ "/ab"; "c*" ]] is computed. Use [check_rooted_glob_expr] to test this * case. * * Several adjacent slashes are handled like a single slash. E.g. * for ["a//b"], the list [["a"; "b"]] is returned. * * If the last component ends with a slash, it is not removed from the * returned list element, e.g. for ["a/b/"], the list [[ "a"; "b/" ]] is * returned. Use [check_directory_glob_expr] to test this case. * * The glob expression passed to this function must not contain brace * or tilde expressions. *) val check_rooted_glob_expr : valid_glob_expr -> valid_glob_expr option (** If the glob expression matches the root directory (i.e. the expression * begins with a literal [/]), the function returns [Some expr'], where * [expr'] matches the path relative to the root directory (i.e. the * expression without the [/] at the beginning). * * Otherwise, [None] is returned. * * Example: For ["/a/b*"], the expression ["a/b*"] is returned. * * Special case: for ["/"], the expression [""] (only matching the empty * string) is returned. * * The glob expression passed to this function must not contain brace * or tilde expressions. *) val check_directory_glob_expr : valid_glob_expr -> valid_glob_expr option (** If the last component of the glob expression matches only directories * because it ends with a literal [/] character, the value [Some expr'] is * returned where [expr'] matches the same path without the trailing [/]. * * Otherwise, [None] is returned. * * Example: For ["a/b*/"], the expression ["a/b*"] is returned. * * Special case: for ["/"], the expression [""] (only matching the empty * string) is returned. * * The glob expression passed to this function must not contain brace * or tilde expressions. *) (** {2 Globbing} *) val glob : ?encoding:Netconversion.encoding -> (* default: `Enc_iso88591 *) ?base_dir:string -> (* default: current directory *) ?protect_period:bool -> (* default: true *) ?fsys:glob_fsys -> (* default: access real file system *) ?user_info:user_info -> ?mode:glob_mode -> (* default: `Existing_paths *) pattern -> string list (** Forms a set of filenames as described below, and matches this set * against the pattern. The pattern can be given as a [`String s] * in which case [s] is parsed (with all features enabled, and * it is assumed it has the passed [encoding]). Alternatively, * an already parsed [`Expr e] can be given. (Note that [encoding] * is ignored in this case.) * * {b Slashes must be explicitly matched:} * "/" must literally occur in order to be a candidate for matching. * It is not matched by [*] or [?] or a bracket expression. * * {b Periods:} The leading period is protected if [protect_period]. * It must then also literally occur to be matched. * * {b Anchoring:} If the [glob_expr] begins with a literal "/", the set * of filenames is * anchored at the root directory; otherwise the set is anchored at * the current directory or, if [base_dir] is passed, at this directory. * (If [fsys] is passed, it is required to also set [base_dir].) * * Initially, the set contains all files of the anchor * directory (for the root directory, a "/" is prepended). * * After that, the set is extended by adding the paths of * subdirectories relative to the anchor directory. Note that the * constructed set is always infinite, because "." and ".." are not * handled specially, and are also regarded as "subdirectories". However, * after applying the matching criterion, the returned list is always * finite. * * Note that the anchor directory itself is not part of the generated * set. For example, for the expression "/*" the root directory "/" is * not returned. As an exception of this rule, for the glob expression * "/" the file "/" is returned. * * {b Braces:} Brace expressions are handled by expanding them first, even * before filename generation starts. * * {b Mode:} By default, only existing paths are returned * ([mode=`Existing_paths]). * If no files match, the empty list is returned (and not the pattern * as the shell does). By passing a different [mode], this can be changed: * - [`All_paths]: It is allowed that non-existing paths * are returned when the paths do not contain *, ?, or \[ * metacharacters after the brace expansion. Path expressions * with these metacharacters are still checked for existence. * - [`All_words]: When an expression does not refer to existing * paths, it is returned as such, leaving the metacharacters *, ?, \[ * unexpanded (i.e., what the Bourne shell does). Note that * either all metacharacters are resolved, or none, but not * a subset of them. * * {b Encodings:} Often, only the pattern has an encoding, but not * the filesystem (as in Unix). In this case, no conversion is attempted, * and the byte representation of the pattern is matched with the * byte representation of the filenames. Good luck. * * If the filesystem has an encoding, however, conversions may * be required, and this can cause problems. Usually, network filesystems * provide an encoding, and the Win32 local filesystem. (For Unix, * one can pass a custom [fsys] with encoding knowledge.) Conversion * problems can be avoided if (1) the encoding of the pattern is a superset * of the filename encoding. Also, (2) one should not use literals * in the pattern that cannot be represented in the filename encoding. * If (2) cannot be satisfied, ensure you have at least * [mode=`Existing_paths], i.e. the default mode (this removes results * from the returned list when a conversion problem occurs). * * The return value of [glob] is encoded in the encoding of the filesystem * if the filesystem provides an encoding. (If you want to check this * encoding, pass [fsys], e.g. as [local_fsys()], and call the * [path_encoding] method of [fsys].) *) (** {2 Remarks} *) (** {b Examples demonstrating the effect of encodings:} (Linux) {[ let fsys = local_fsys ~encoding:`Enc_utf8() let l = glob ~fsys (`String "\214*") ]} The byte 214 is O-umlaut in ISO-8859-1 (the default encoding for patterns). By passing an [fsys] argument we change the encoding for filenames to UTF-8. For example, if "\195\150ffentlich" was a file in the current directory, it would be found and returned in [l]. Conversions: For example, assume we have a file "\226\130\172uro" (EUR-uro in UTF-8). The glob {[ let fsys = local_fsys ~encoding:`Enc_utf8() let l = glob ~fsys (`String "*") ]} finds it although the euro sign cannot be represented in ISO-8859-1, the default pattern encoding. We run into a problem, however, if we want to generate the euro sign even if the file is not present, and the filesystem uses an encoding that does not include this sign: {[ let fsys = local_fsys ~encoding:`Enc_iso88591() let l = glob ~fsys ~encoding:`Enc_utf8 ~mode:`All_paths (`String "\226\130\172uro") ]} This raises an exception [Netconversion.Cannot_represent 8364]. *) (** {b Notes for Win32:} - Globbing only supports forward slashes, not backslashes as path separators - Globbing does neither recognize drive letters nor UNC paths as special cases. This may lead to subtle bugs. Glob expressions like "c:/file.*" may or may not work depending on the context. - The usually case-insensitive file system is not taken into account. (To be fixed.) *) (** {2 Default access objects} *) class local_user_info : unit -> user_info val local_user_info : unit -> user_info (** Get the home directory of a user from the local user database. *) class local_fsys : ?encoding:Netconversion.encoding -> unit -> glob_fsys val local_fsys : ?encoding:Netconversion.encoding -> unit -> glob_fsys (** Accesses the local filesystem *) class of_stream_fs : #Netfs.stream_fs -> glob_fsys val of_stream_fs : #Netfs.stream_fs -> glob_fsys (** Use an arbitrary network filesystem for globbing *) (** {2 Compatibility} This implementation is not fully compatible with the POSIX specs. The differences: - Missing support for character classes, equivalence classes and collating symbols. - Ranges in brackets are restricted to ASCII. - Unparseable patterns are indicated by exceptions. POSIX, however, requires that such patterns are taken literally. E.g. a pattern "\[" would match a left bracket in POSIX, but this module throws a syntax error. - If the slash character is protected, it is still allowed inside brackets. POSIX, however, requires that the pattern is scanned for slashes before brackets. For instance, the pattern "\[a/b*\]" is scanned as [ [`Literal "[a/b]"; `Star] ] following the POSIX rules while this implementation sees a bracket expression with "a", "b", "/" and "*" characters. - The "^" character negates the set if used at the beginning of bracket expressions. POSIX leaves this unspecified. - Brace expresions are an extension (although commonly implemented in shells). - The default globbing mode is [`Existing_paths] which is not defined by POSIX. Use [`All_paths] for getting POSIX behavior. Compared with popular shells, there are some subtle differences in how the various syntax elements (wildcards, braces, tildes) are parsed and processed. Shells do it in this order: - Parse and expand brace expressions - Parse and expand tildes - Split the paths at slashes into path components - Parse and expand wildcards For example, after expanding braces it is possible to see totally new tilde or wildcard expressions, e.g. ["~user{1,2}/file"] would be legal. This implementation here does not support this - we first parse the expression, and then interpret it. However, users interested in a higher degree of compatibility can call the {!Netglob} parsing, processing and printing functions in the required order, and emulate the shell behavior. For example, {[ let alt_glob pat = let g1 = parse_glob_expr ~enable_star:false ~enable_qmark:false ~enable_brackets:false ~enable_tilde:false (* only braces remain enabled *) pat in let g2_list = expand_glob_expr g1 in let pat2_list = List.map (print_glob_expr ~escape_in_literals:false) g2_list in let g3_list = List.map (fun pat2 -> parse_glob_expr ~enable_braces:false pat2) pat2_list in List.flatten (List.map (fun g3 -> glob (`Expr g3)) g3_list) ]} would parse and expand brace expressions in a separate step before running [glob] on the remaining syntactic elements. *) ocamlnet-4.1.6/src/netstring/netglob_lex.mll0000644000175000017500000001476313274252310017576 0ustar gerdgerd(* $Id$ *) { exception Bracket_Unsupported exception Lexing_Error type bracket_token = Bracket_char of char | Bracket_range of (char * char) | Bracket_code of int (* see Netglob.reparse_bracket_expr *) | Bracket_end type brace_token = Brace_literal of string | Brace_comma | Brace_braces of brace_token list (* inner braces *) | Brace_end type glob_features = { enable_star : bool; enable_qmark : bool; enable_brackets : bool; enable_braces : bool; enable_tilde : bool; enable_escape : bool; mutable escaped : bool; (* after a backslash *) } type glob_token = Glob_literal of string | Glob_star | Glob_qmark | Glob_brackets of (bool * bracket_token list) | Glob_braces of brace_token list | Glob_tilde of string * bool (* whether there is a slash *) | Glob_end type exploded_char = C of char (* An unescaped character *) | E of char (* An escaped character *) | Delim of char (* delimiter *) let rec collect_until end_token parse_fun lexbuf = let tok = parse_fun lexbuf in if tok = end_token then [] else tok :: (collect_until end_token parse_fun lexbuf) let string_of_exploded l = String.concat "" (List.map (function | C c -> String.make 1 c | E c -> String.make 1 c | Delim _ -> "" ) l ) let have_delim l = List.exists (function Delim _ -> true | _ -> false) l } (* bracket_rest: Scans a bracket expression beginning at the second * character (where ']' is always the terminating character) *) rule bracket_rest = parse "[:" [^ ':' ] ":]" { raise Bracket_Unsupported } | "[." [^ '.' ] ".]" { raise Bracket_Unsupported } | "[=" [^ '=' ] "=]" { raise Bracket_Unsupported } | "]" { Bracket_end } | [ ^ ']' ] "-" [^ ']' ] { let c0 = Lexing.lexeme_char lexbuf 0 in let c1 = Lexing.lexeme_char lexbuf 2 in if c0 > '\127' || c1 > '\127' then raise Lexing_Error; if c0 > c1 then raise Lexing_Error; Bracket_range(c0,c1) } | eof { raise Lexing_Error } | [ ^ ']' ] { Bracket_char (Lexing.lexeme_char lexbuf 0) } (* bracket_first: Scans the first token of a bracket expression * (after "[", "[^", or "[!"). * Here, ']' is not recognized as terminating character. *) and bracket_first = parse "[:" [^ ':' ] ":]" { raise Bracket_Unsupported } | "[." [^ '.' ] ".]" { raise Bracket_Unsupported } | "[=" [^ '=' ] "=]" { raise Bracket_Unsupported } | _ "-" [^ ']' ] { let c0 = Lexing.lexeme_char lexbuf 0 in let c1 = Lexing.lexeme_char lexbuf 2 in if c0 > '\127' || c1 > '\127' then raise Lexing_Error; if c0 > c1 then raise Lexing_Error; Bracket_range(c0,c1) } | eof { raise Lexing_Error } | _ { Bracket_char (Lexing.lexeme_char lexbuf 0) } (* brace: Collects material within brace expressions (case: backslash * is escape character *) and brace = parse "}" { Brace_end } | "," { Brace_comma } | "{" { let l = collect_until Brace_end brace lexbuf in Brace_braces l } | '\\' _ { Brace_literal (Lexing.lexeme lexbuf) } | [^ '}' ',' '\\' '{' ] { Brace_literal (Lexing.lexeme lexbuf) } | eof { raise Lexing_Error } | _ { raise Lexing_Error } (* brace_noescape: Used for the case that backslash is not an escape * character *) and brace_noescape = parse "}" { Brace_end } | "," { Brace_comma } | "{" { let l = collect_until Brace_end brace_noescape lexbuf in Brace_braces l } | [^ '}' ',' '{'] { Brace_literal (Lexing.lexeme lexbuf) } | eof { raise Lexing_Error } | _ { raise Lexing_Error } and glob_expr feat = parse "*" { if feat.enable_star && not feat.escaped then Glob_star else ( feat.escaped <- false; Glob_literal "*" ) } | "?" { if feat.enable_qmark && not feat.escaped then Glob_qmark else ( feat.escaped <- false; Glob_literal "?" ) } | "[" [ '!' '^' ]? { if feat.enable_brackets && not feat.escaped then ( let negated = String.length(Lexing.lexeme lexbuf) > 1 in let t0 = bracket_first lexbuf in let l = collect_until Bracket_end bracket_rest lexbuf in Glob_brackets (negated, t0 :: l) ) else ( feat.escaped <- false; Glob_literal (Lexing.lexeme lexbuf) ) } | "{" { if feat.enable_braces && not feat.escaped then ( let p = if feat.enable_escape then brace else brace_noescape in let l = collect_until Brace_end p lexbuf in Glob_braces l ) else ( feat.escaped <- false; Glob_literal "{" ) } | "~" { if (feat.enable_tilde && not feat.escaped && Lexing.lexeme_start lexbuf = 0) then ( let p = if feat.enable_escape then generic_lex_until '/' else generic_lex_noescape_until '/' in let l = p lexbuf in let s = string_of_exploded l in let slash = have_delim l in Glob_tilde(s,slash) ) else ( feat.escaped <- false; Glob_literal "~" ) } | "\\" { if feat.enable_escape && not feat.escaped then ( feat.escaped <- true; Glob_literal "" ) else ( feat.escaped <- false; Glob_literal "\\" ) } | [ ^ '*' '?' '[' '{' '\\' '~' ]+ { feat.escaped <- false; Glob_literal (Lexing.lexeme lexbuf) } | eof { if feat.escaped then raise Lexing_Error; Glob_end } and generic_lex_until c = parse '\\' _ { let char = E (Lexing.lexeme_char lexbuf 1) in char :: generic_lex_until c lexbuf } | _ { let lc = Lexing.lexeme_char lexbuf 0 in if c = lc then [ Delim c ] else ( let char = C lc in char :: generic_lex_until c lexbuf ) } | eof { [] } and generic_lex_noescape_until c = parse | _ { let lc = Lexing.lexeme_char lexbuf 0 in if c = lc then [ Delim c ] else ( let char = C lc in char :: generic_lex_noescape_until c lexbuf ) } | eof { [] } ocamlnet-4.1.6/src/netstring/netgssapi_auth.ml0000644000175000017500000002745113274252310020134 0ustar gerdgerd(* $Id$ *) module type CONFIG = sig val raise_error : string -> 'a end module Manage(G:Netsys_gssapi.GSSAPI) = struct let delete_context ctx_opt () = match ctx_opt with | None -> () | Some ctx -> G.interface # delete_sec_context ~context:ctx ~out:(fun ~minor_status ~major_status () -> ()) () let format_status ?fn ?minor_status ((calling_error,routine_error,_) as major_status) = if calling_error <> `None || routine_error <> `None then ( let error = Netsys_gssapi.string_of_major_status major_status in let minor_s = match minor_status with | None -> "" | Some n -> G.interface # display_minor_status ~mech_type:[||] ~status_value:n ~out:(fun ~status_strings ~minor_status ~major_status () -> " (details: " ^ String.concat "; " status_strings ^ ")" ) () in let s1 = match fn with | None -> "" | Some n -> " for " ^ n in "GSSAPI error" ^ s1 ^ ": " ^ error ^ minor_s ) else let s1 = match fn with | None -> "" | Some n -> " " ^ n in "GSSAPI call" ^ s1 ^ " is successful" end module Auth (G:Netsys_gssapi.GSSAPI)(C:CONFIG) = struct module M = Manage(G) let check_status ?fn ?minor_status ((calling_error,routine_error,_) as major_status) = if calling_error <> `None || routine_error <> `None then C.raise_error(M.format_status ?fn ?minor_status major_status) let get_initiator_name (config:Netsys_gssapi.client_config) = match config#initiator_name with | None -> G.interface # no_name (* means: default credential *) | Some(cred_string, cred_name_type) -> G.interface # import_name ~input_name:cred_string ~input_name_type:cred_name_type ~out:(fun ~output_name ~minor_status ~major_status () -> check_status ~fn:"import_name" ~minor_status major_status; output_name ) () let get_acceptor_name (config:Netsys_gssapi.server_config) = match config#acceptor_name with | None -> G.interface # no_name (* means: default credential *) | Some(cred_string, cred_name_type) -> G.interface # import_name ~input_name:cred_string ~input_name_type:cred_name_type ~out:(fun ~output_name ~minor_status ~major_status () -> check_status ~fn:"import_name" ~minor_status major_status; output_name ) () let acquire_initiator_cred ~initiator_name (config:Netsys_gssapi.client_config) = let mech_type = config#mech_type in G.interface # acquire_cred ~desired_name:initiator_name ~time_req:`Indefinite ~desired_mechs:(if mech_type = [| |] then [] else [mech_type]) ~cred_usage:`Initiate ~out:(fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status () -> check_status ~fn:"acquire_cred" ~minor_status major_status; cred ) () let get_initiator_cred ~initiator_name (config:Netsys_gssapi.client_config) = (* let mech_type = config#mech_type in *) match config#initiator_cred with | Some(G.Credential cred) -> (* Check that this is the cred for init_name *) if not(G.interface # is_no_name initiator_name) then ( G.interface # inquire_cred ~cred ~out:(fun ~name ~lifetime ~cred_usage ~mechanisms ~minor_status ~major_status () -> check_status ~fn:"inquire_cred" ~minor_status major_status; G.interface # compare_name ~name1:name ~name2:initiator_name ~out:(fun ~name_equal ~minor_status ~major_status () -> check_status ~fn:"compare_name" ~minor_status major_status; if not name_equal then C.raise_error "The user name does not \ match the credential" ) () ) () ); cred | _ -> acquire_initiator_cred ~initiator_name config let get_acceptor_cred ~acceptor_name (config:Netsys_gssapi.server_config) = G.interface # acquire_cred ~desired_name:acceptor_name ~time_req:`Indefinite ~desired_mechs:config#mech_types ~cred_usage:`Accept ~out:(fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status () -> check_status ~fn:"acquire_cred" ~minor_status major_status; cred ) () let get_target_name ?default (config:Netsys_gssapi.client_config) = if config#target_name=None && default=None then G.interface#no_name else let (name_string, name_type) = match config#target_name with | Some(n,t) -> (n,t) | None -> ( match default with | None -> assert false | Some(n,t) -> (n,t) ) in G.interface # import_name ~input_name:name_string ~input_name_type:name_type ~out:(fun ~output_name ~minor_status ~major_status () -> check_status ~fn:"import_name" ~minor_status major_status; output_name ) () let get_client_flags config = let flags1 = [ `Conf_flag, config#privacy; `Integ_flag, config#integrity ] @ config#flags in List.map fst (List.filter (fun (n,lev) -> lev <> `None) flags1) let get_server_flags = get_client_flags type t1 = < flags : (Netsys_gssapi.ret_flag * Netsys_gssapi.support_level) list; integrity : Netsys_gssapi.support_level; privacy : Netsys_gssapi.support_level; > let check_flags (config : t1) act_flags = let flags1 = [ `Conf_flag, config#privacy; `Integ_flag, config#integrity ] @ config#flags in let needed = List.map fst (List.filter (fun (n,lev) -> lev = `Required) flags1) in let missing = List.filter (fun flag -> not (List.mem flag act_flags) ) needed in if missing <> [] then C.raise_error ("GSSAPI error: the security mechanism could not \ grant the following required context flags: " ^ String.concat ", " (List.map Netsys_gssapi.string_of_flag missing)) let check_client_flags config act_flags = check_flags (config :> t1) act_flags let check_server_flags config act_flags = check_flags (config :> t1) act_flags let get_display_name name = G.interface # display_name ~input_name:name ~out:(fun ~output_name ~output_name_type ~minor_status ~major_status () -> check_status ~fn:"display_name" ~minor_status major_status; output_name, output_name_type ) () let get_exported_name name = G.interface # export_name ~name:name ~out:(fun ~exported_name ~minor_status ~major_status () -> check_status ~fn:"export_name" ~minor_status major_status; exported_name ) () let init_sec_context ~initiator_cred ~context ~target_name ~req_flags ~chan_bindings ~input_token config = let mech_type = config#mech_type in G.interface # init_sec_context ~initiator_cred ~context ~target_name ~mech_type ~req_flags ~time_req:None ~chan_bindings ~input_token ~out:(fun ~actual_mech_type ~output_context ~output_token ~ret_flags ~time_rec ~minor_status ~major_status () -> try check_status ~fn:"init_sec_context" ~minor_status major_status; let ctx = match output_context with | None -> assert false | Some ctx -> ctx in let (_,_,suppl) = major_status in let cont_flag = List.mem `Continue_needed suppl in if cont_flag then ( assert(output_token <> ""); (ctx, output_token, ret_flags, None) ) else ( check_client_flags config ret_flags; let props = ( object method mech_type = actual_mech_type method flags = ret_flags method time = time_rec end ) in (ctx, output_token, ret_flags, Some props) ) with | error -> M.delete_context output_context (); raise error ) () let accept_sec_context ~acceptor_cred ~context ~chan_bindings ~input_token config = G.interface # accept_sec_context ~context ~acceptor_cred ~input_token ~chan_bindings ~out:(fun ~src_name ~mech_type ~output_context ~output_token ~ret_flags ~time_rec ~delegated_cred ~minor_status ~major_status () -> try check_status ~fn:"accept_sec_context" ~minor_status major_status; let ctx = match output_context with | None -> assert false | Some ctx -> ctx in let (_,_,suppl) = major_status in let cont_flag = List.mem `Continue_needed suppl in if cont_flag then ( assert(output_token <> ""); (ctx, output_token, ret_flags, None) ) else ( check_server_flags config ret_flags; let (props : Netsys_gssapi.server_props) = ( object method mech_type = mech_type method flags = ret_flags method time = time_rec method initiator_name = get_display_name src_name method initiator_name_exported = get_exported_name src_name method deleg_credential = if List.mem `Deleg_flag ret_flags then let t = G.interface # inquire_cred ~cred:delegated_cred ~out:(fun ~name ~lifetime ~cred_usage ~mechanisms ~minor_status ~major_status () -> check_status ~fn:"inquire_cred" ~minor_status major_status; lifetime ) () in Some(G.Credential delegated_cred, t) else None end ) in (ctx, output_token, ret_flags, Some props) ) with | error -> M.delete_context output_context (); raise error ) () end ocamlnet-4.1.6/src/netstring/netgssapi_auth.mli0000644000175000017500000000574213274252310020304 0ustar gerdgerd(* $Id$ *) (** Authentication helpers for GSSAPI *) open Netsys_gssapi module type CONFIG = sig val raise_error : string -> 'a end module Manage(G:GSSAPI) : sig (** General management *) val delete_context : G.context option -> unit -> unit (** Deletes the context, ignoring any error *) val format_status : ?fn:string -> ?minor_status:int32 -> major_status -> string end module Auth (G:GSSAPI)(C:CONFIG) : sig (** Status *) val check_status : ?fn:string -> ?minor_status:int32 -> major_status -> unit (** If the [major_status] indicates an error, an error string is formed, optionally including the function name [fn] and the detailed information derived from [minor_status]. Then, the function [C.raise_error] is called with the string as argument. *) (** Client configuration *) val get_initiator_name : client_config -> G.name val get_initiator_cred : initiator_name:G.name -> client_config -> G.credential val acquire_initiator_cred : initiator_name:G.name -> client_config -> G.credential val get_target_name : ?default:(string * oid) -> client_config -> G.name val get_client_flags : client_config -> req_flag list val check_client_flags : client_config -> ret_flag list -> unit val init_sec_context : initiator_cred:G.credential -> context:G.context option -> target_name:G.name -> req_flags:req_flag list -> chan_bindings:channel_bindings option -> input_token:token option -> client_config -> (G.context * token * ret_flag list * client_props option) (** Calls [G.init_sec_context], and returns [(out_context,out_token,flags,props_opt)]. If [props_opt] is returned the context setup is done. Checks already for errors, and client flags. *) (** Server configuration *) val get_acceptor_name : server_config -> G.name val get_acceptor_cred : acceptor_name:G.name -> server_config -> G.credential val get_server_flags : server_config -> req_flag list val check_server_flags : server_config -> ret_flag list -> unit val accept_sec_context : acceptor_cred:G.credential -> context:G.context option -> chan_bindings:channel_bindings option -> input_token:token -> server_config -> (G.context * token * ret_flag list * server_props option) (** Calls [G.accept_sec_context], and returns [(out_context,out_token,flags,props_opt)]. If [props_opt] is returned the context setup is done. Checks already for errors, and server flags. *) (** Helpers *) val get_display_name : G.name -> string * oid val get_exported_name : G.name -> string end ocamlnet-4.1.6/src/netstring/netgssapi_support.ml0000644000175000017500000003571013274252310020704 0ustar gerdgerd(* $Id$ *) open Printf (* Encodings *) let encode_subidentifier buf n = (* See 8.19 of ITU.T X.690 *) let rec encode n = if n < 128 then [ n ] else (n land 127) :: encode (n lsr 7) in if n < 0 then failwith "Netgssapi_support.encode_subidentifier"; let l = List.rev(encode n) in let len = List.length l in let l = List.mapi (fun i k -> if i < len-1 then Char.chr(k lor 128) else Char.chr k ) l in List.iter (Buffer.add_char buf) l let decode_subidentifier s cursor = let n = ref 0 in let s_len = String.length s in while !cursor < s_len && s.[ !cursor ] >= '\x80' do let c = Char.code (s.[ !cursor ]) - 128 in n := (!n lsl 7) lor c; incr cursor done; if !cursor < s_len then ( let c = Char.code (s.[ !cursor ]) in n := (!n lsl 7) lor c; incr cursor; !n ) else failwith "Netgssapi_support.decode_subidentifier" let encode_definite_length buf n = (* See 8.1.3 of ITU-T X.690 *) let rec encode n = if n < 256 then [ n ] else (n land 255) :: encode (n lsr 8) in if n < 128 then ( Buffer.add_char buf (Char.chr n) ) else ( let l = List.map Char.chr (List.rev(encode n)) in Buffer.add_char buf (Char.chr (List.length l + 128)); List.iter (Buffer.add_char buf) l ) let decode_definite_length s cursor = let s_len = String.length s in if !cursor < s_len then ( let c = s.[ !cursor ] in incr cursor; if c < '\x80' then ( Char.code c ) else ( let p = Char.code c - 128 in let n = ref 0 in for q = 1 to p do if !cursor < s_len then ( let c = s.[ !cursor ] in incr cursor; n := (!n lsl 8) lor Char.code c; ) else failwith "Netgssapi_support.decode_definite_length" done; !n ) ) else failwith "Netgssapi_support.decode_definite_length" let oid_to_der_value oid = match Array.to_list oid with | [] -> failwith "Netgssapi_support.oid_to_der: empty OID" | [ _ ] -> failwith "Netgssapi_support.oid_to_der: invalid OID" | top :: second :: subids -> if top < 0 || top > 5 then (* actually only 0..2 possible *) failwith "Netgssapi_support.oid_to_der: invalid OID"; if second < 0 || second > 39 then failwith "Netgssapi_support.oid_to_der: invalid OID"; let subids_buf = Buffer.create 50 in List.iter (encode_subidentifier subids_buf) subids; let buf = Buffer.create 50 in Buffer.add_char buf (Char.chr (top * 40 + second)); Buffer.add_buffer buf subids_buf; Buffer.contents buf let oid_to_der oid = let buf = Buffer.create 50 in let s = oid_to_der_value oid in Buffer.add_char buf '\x06'; encode_definite_length buf (String.length s); Buffer.add_string buf s; Buffer.contents buf let der_value_to_oid der cursor oid_len = try let lim = !cursor + oid_len in let c = Char.code der.[ !cursor ] in incr cursor; let top = c / 40 in let second = c mod 40 in let oid = ref [ second; top ] in while !cursor < lim do let subid = decode_subidentifier der cursor in oid := subid :: !oid; done; if !cursor <> lim then raise Not_found; Array.of_list (List.rev !oid) with | _ -> failwith "Netgssapi_support.der_value_to_oid" let der_to_oid der cursor = try let der_len = String.length der in if !cursor >= der_len then raise Not_found; let c = der.[ !cursor ] in incr cursor; if c <> '\x06' then raise Not_found; let oid_len = decode_definite_length der cursor in let lim = !cursor + oid_len in if lim > der_len then raise Not_found; if oid_len = 0 then raise Not_found; der_value_to_oid der cursor oid_len with | _ -> failwith "Netgssapi_support.der_to_oid" let wire_encode_token oid token = try let buf = Buffer.create (50 + String.length token) in Buffer.add_char buf '\x60'; let oid_as_der = oid_to_der oid in let len = String.length oid_as_der + String.length token in encode_definite_length buf len; Buffer.add_string buf oid_as_der; Buffer.add_string buf token; Buffer.contents buf with | _ -> failwith "Netgssapi_support.wire_encode_token" let wire_decode_token s cursor = try let s_len = String.length s in if !cursor > s_len then raise Not_found; let c = s.[ !cursor ] in incr cursor; if c <> '\x60' then raise Not_found; let len = decode_definite_length s cursor in let lim = !cursor + len in if lim > s_len then raise Not_found; let oid = der_to_oid s cursor in if !cursor > lim then raise Not_found; let token = String.sub s !cursor (lim - !cursor) in cursor := lim; (oid, token) with | _ -> failwith "Netgsspi.wire_decode_token" let encode_exported_name mech_oid name = let buf = Buffer.create (50 + String.length name) in Buffer.add_string buf "\x04\x01"; let mech_oid_der = oid_to_der mech_oid in let mech_oid_len = String.length mech_oid_der in if mech_oid_len > 65535 then failwith "Netgssapi_support.encode_exported_name: OID too long"; Buffer.add_char buf (Char.chr (mech_oid_len / 256)); Buffer.add_char buf (Char.chr (mech_oid_len mod 256)); Buffer.add_string buf mech_oid_der; let name_len = String.length name in let n3 = (name_len lsr 24) land 0xff in let n2 = (name_len lsr 16) land 0xff in let n1 = (name_len lsr 8) land 0xff in let n0 = name_len land 0xff in Buffer.add_char buf (Char.chr n3); Buffer.add_char buf (Char.chr n2); Buffer.add_char buf (Char.chr n1); Buffer.add_char buf (Char.chr n0); Buffer.add_string buf name; Buffer.contents buf let decode_exported_name s cursor = try let s_len = String.length s in if !cursor + 4 > s_len then raise Not_found; let c0 = s.[ !cursor ] in incr cursor; let c1 = s.[ !cursor ] in incr cursor; let c2 = s.[ !cursor ] in incr cursor; let c3 = s.[ !cursor ] in incr cursor; if c0 <> '\x04' || c1 <> '\x01' then raise Not_found; let mech_oid_len = (Char.code c2 lsl 8) + Char.code c3 in let mech_start = !cursor in if mech_start + mech_oid_len > s_len then raise Not_found; let mech_oid = der_to_oid s cursor in if !cursor <> mech_start + mech_oid_len then raise Not_found; if !cursor + 4 > s_len then raise Not_found; let n0 = Char.code s.[ !cursor ] in incr cursor; let n1 = Char.code s.[ !cursor ] in incr cursor; let n2 = Char.code s.[ !cursor ] in incr cursor; let n3 = Char.code s.[ !cursor ] in incr cursor; let name_len = (n0 lsl 24) lor (n1 lsl 16) lor (n2 lsl 8) lor (n3) in if !cursor + name_len > s_len then raise Not_found; let name = String.sub s !cursor name_len in cursor := !cursor + name_len; (mech_oid, name) with | _ -> failwith "Netgssapi_support.decode_exported_name" let comma_equals_re = Netstring_str.regexp "[,=]" let rev_comma_equals_re = Netstring_str.regexp "\\(=2C\\|=3D\\|=\\|,\\)" let gs2_encode_saslname s = ( try Netconversion.verify `Enc_utf8 s; if String.contains s '\000' then raise Not_found; with _ -> failwith "gs2_encode_saslname" ); Netstring_str.global_substitute comma_equals_re (fun r s -> match Netstring_str.matched_string r s with | "," -> "=2C" | "=" -> "=3D" | _ -> assert false ) s let gs2_decode_saslname s = let s' = Netstring_str.global_substitute rev_comma_equals_re (fun r s -> match Netstring_str.matched_string r s with | "=2C" -> "," | "=3D" -> "=" | "=" | "," -> failwith "gs2_decode_saslname" | _ -> assert false ) s in ( try Netconversion.verify `Enc_utf8 s'; if String.contains s' '\000' then raise Not_found; with _ -> failwith "gs2_decode_saslname" ); s' let encode_seq_nr x = let n7 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 56) 0xffL) in let n6 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 48) 0xffL) in let n5 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 40) 0xffL) in let n4 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 32) 0xffL) in let n3 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 24) 0xffL) in let n2 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 16) 0xffL) in let n1 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 8) 0xffL) in let n0 = Int64.to_int (Int64.logand x 0xffL) in let s = Bytes.create 8 in Bytes.set s 0 (Char.chr n7); Bytes.set s 1 (Char.chr n6); Bytes.set s 2 (Char.chr n5); Bytes.set s 3 (Char.chr n4); Bytes.set s 4 (Char.chr n3); Bytes.set s 5 (Char.chr n2); Bytes.set s 6 (Char.chr n1); Bytes.set s 7 (Char.chr n0); Bytes.unsafe_to_string s let decode_seq_nr s = assert(String.length s = 8); let n7 = Int64.of_int (Char.code s.[0]) in let n6 = Int64.of_int (Char.code s.[1]) in let n5 = Int64.of_int (Char.code s.[2]) in let n4 = Int64.of_int (Char.code s.[3]) in let n3 = Int64.of_int (Char.code s.[4]) in let n2 = Int64.of_int (Char.code s.[5]) in let n1 = Int64.of_int (Char.code s.[6]) in let n0 = Int64.of_int (Char.code s.[7]) in Int64.logor (Int64.shift_left n7 56) (Int64.logor (Int64.shift_left n6 48) (Int64.logor (Int64.shift_left n5 40) (Int64.logor (Int64.shift_left n4 32) (Int64.logor (Int64.shift_left n3 24) (Int64.logor (Int64.shift_left n2 16) (Int64.logor (Int64.shift_left n1 8) n0)))))) let parse_kerberos_name s = (* http://web.mit.edu/kerberos/krb5-latest/doc/appdev/refs/api/krb5_parse_name.html *) let l = String.length s in let rec parse_nc prev_nc buf k = if k >= l then (prev_nc @ [Buffer.contents buf], None) else match s.[k] with | '/' -> parse_nc (prev_nc @ [Buffer.contents buf]) (Buffer.create 20) (k+1) | '@' -> let realm = String.sub s (k+1) (l-k-1) in (prev_nc @ [Buffer.contents buf], Some realm) | '\\' -> if k+1 >= l then failwith "parse_kerberos_name"; ( match s.[k+1] with | '\\' -> Buffer.add_char buf '\\' | '/' -> Buffer.add_char buf '/' | '@' -> Buffer.add_char buf '@' | 'n' -> Buffer.add_char buf '\n' | 't' -> Buffer.add_char buf '\t' | 'b' -> Buffer.add_char buf '\b' | '0' -> Buffer.add_char buf '\000' | _ -> failwith "parse_kerberos_name" ); parse_nc prev_nc buf (k+2) | c -> Buffer.add_char buf c; parse_nc prev_nc buf (k+1) in parse_nc [] (Buffer.create 20) 0 let create_mic_token ~sent_by_acceptor ~acceptor_subkey ~sequence_number ~get_mic ~message = let header = sprintf "\x04\x04%c\xff\xff\xff\xff\xff%s" (Char.chr ( (if sent_by_acceptor then 1 else 0) lor (if acceptor_subkey then 4 else 0) ) ) (encode_seq_nr sequence_number) in let mic = get_mic (message @ [Netxdr_mstring.string_to_mstring header] ) in header ^ mic let parse_mic_token_header s = try if String.length s < 16 then raise Not_found; if s.[0] <> '\x04' || s.[1] <> '\x04' then raise Not_found; if String.sub s 3 5 <> "\xff\xff\xff\xff\xff" then raise Not_found; let flags = Char.code s.[2] in if flags land 7 <> flags then raise Not_found; let sent_by_acceptor = (flags land 1) <> 0 in let acceptor_subkey = (flags land 4) <> 0 in let sequence_number = decode_seq_nr (String.sub s 8 8) in (sent_by_acceptor, acceptor_subkey, sequence_number) with Not_found -> failwith "Netgssapi_support.parse_mic_token_header" let verify_mic_token ~get_mic ~message ~token = try ignore(parse_mic_token_header token); let header = String.sub token 0 16 in let mic = get_mic (message @ [Netxdr_mstring.string_to_mstring header]) in mic = (String.sub token 16 (String.length token - 16)) with | _ -> false let create_wrap_token_conf ~sent_by_acceptor ~acceptor_subkey ~sequence_number ~get_ec ~encrypt_and_sign ~message = let ec = get_ec (Netxdr_mstring.length_mstrings message + 16) in let header = sprintf "\x05\x04%c\xff%c%c\000\000%s" (Char.chr ( (if sent_by_acceptor then 1 else 0) lor (if acceptor_subkey then 4 else 0) lor 2 ) ) (Char.chr ((ec lsr 8) land 0xff)) (Char.chr (ec land 0xff)) (encode_seq_nr sequence_number) in let filler = String.make ec '\000' in let encrypted = encrypt_and_sign (message @ [ Netxdr_mstring.string_to_mstring (filler ^ header) ] ) in Netxdr_mstring.string_to_mstring header :: encrypted let parse_wrap_token_header m = try let l = Netxdr_mstring.length_mstrings m in if l < 16 then raise Not_found; let s = Netxdr_mstring.prefix_mstrings m 16 in if s.[0] <> '\x05' || s.[1] <> '\x04' then raise Not_found; if s.[3] <> '\xff' then raise Not_found; let flags = Char.code s.[2] in if flags land 7 <> flags then raise Not_found; let sent_by_acceptor = (flags land 1) <> 0 in let sealed = (flags land 2) <> 0 in let acceptor_subkey = (flags land 4) <> 0 in let sequence_number = decode_seq_nr (String.sub s 8 8) in (sent_by_acceptor, sealed, acceptor_subkey, sequence_number) with Not_found -> failwith "Netgssapi_support.parse_wrap_token_header" let unwrap_wrap_token_conf ~decrypt_and_verify ~token = let (_, sealed, _, _) = parse_wrap_token_header token in if not sealed then failwith "Netgssapi_support.unwrap_wrap_token_conf: not sealed"; let s = Netxdr_mstring.prefix_mstrings token 16 in let ec = ((Char.code s.[4]) lsl 8) lor (Char.code s.[5]) in let rrc = ((Char.code s.[6]) lsl 8) lor (Char.code s.[7]) in let l_decrypt = Netxdr_mstring.length_mstrings token - 16 in let rrc_eff = rrc mod l_decrypt in let u = if rrc = 0 then Netxdr_mstring.shared_sub_mstrings token 16 l_decrypt else ( Netxdr_mstring.shared_sub_mstrings token (rrc_eff+16) (l_decrypt - rrc_eff) @ Netxdr_mstring.shared_sub_mstrings token 16 rrc_eff ) in (* let u = String.create l_decrypt in String.blit token (rrc_eff+16) u 0 (l_decrypt - rrc_eff); String.blit token 16 u (l_decrypt - rrc_eff) rrc_eff; *) let decrypted = try decrypt_and_verify u with _ -> failwith "Netgssapi_support.unwrap_wrap_token_conf: cannot decrypt" in let l_decrypted = Netxdr_mstring.length_mstrings decrypted in if l_decrypted < ec + 16 then failwith "Netgssapi_support.unwrap_wrap_token_conf: bad EC"; let h1 = Netxdr_mstring.prefix_mstrings token 16 in let h2 = Netxdr_mstring.concat_mstrings (Netxdr_mstring.shared_sub_mstrings decrypted (l_decrypted - 16) 16) in if h1 <> h2 then failwith "Netgssapi_support.unwrap_wrap_token_conf: header integrity mismatch"; Netxdr_mstring.shared_sub_mstrings decrypted 0 (l_decrypted - ec - 16) ocamlnet-4.1.6/src/netstring/netgssapi_support.mli0000644000175000017500000001072213274252310021051 0ustar gerdgerd(* $Id$ *) (** Support functions for GSS-API *) open Netsys_gssapi (** {2 Encodings} *) val oid_to_der : oid -> string val der_to_oid : string -> int ref -> oid (** Convert OID's to/from DER. [der_to_oid] takes a cursor as second arg. *) val oid_to_der_value : oid -> string val der_value_to_oid : string -> int ref -> int -> oid (** Convert OID's to/from DER. This variant does not include the header (hex 06 plus length). [der_value_to_oid] takes a cursor and the length in bytes. *) val wire_encode_token : oid -> token -> string val wire_decode_token : string -> int ref -> oid * token (** Encode tokens as described in section 3.1 of RFC 2078. This is usually only done for the initiating token. *) val encode_exported_name : oid -> string -> string val decode_exported_name : string -> int ref -> oid * string (** Encode names as described in section 3.2 of RFC 2078 *) val gs2_encode_saslname : string -> string val gs2_decode_saslname : string -> string (** Encodes "," and "=" characters, and forbids null bytes, and checks whether the names are UTF-8-encoded (as required for the "saslname" production in section 4 of RFC 5801). Fails if something is wrong. *) val parse_kerberos_name : string -> string list * string option (** [let (name_components, realm_opt) = parse_kerberos_name s]: Returns the slash-separated name components as [name_components], and the realm following "@" as [realm_opt]. Fails on parse error. *) (** {2 Create tokens} *) (** Format of the tokens: see RFC 4121 *) val create_mic_token : sent_by_acceptor:bool -> acceptor_subkey:bool -> sequence_number:int64 -> get_mic:(message -> string) -> message:message -> string (** Create a MIC token: - [sent_by_acceptor]: whether this token comes from the acceptor - [acceptor_subkey]: see RFC - [sequence_number]: a sequence number - [get_mic]: the checksum function (e.g. {!Netmech_scram.Cryptosystem.get_mic}) - [message]: the message to be signed The function returns the MIC token *) val parse_mic_token_header : string -> (bool * bool * int64) (** Returns the triple ([sent_by_acceptor], [acceptor_subkey], [sequence_number]) from the header of a MIC token that is passed to this function as string. Fails if not parsable *) val verify_mic_token : get_mic:(message -> string) -> message:message -> token:string -> bool (** Verifies the MIC [token] with [get_mic], and returns true if the verification is successful *) val create_wrap_token_conf : sent_by_acceptor:bool -> acceptor_subkey:bool -> sequence_number:int64 -> get_ec:(int -> int) -> encrypt_and_sign:(message -> message) -> message:message -> message (** Wraps a [message] so that it is encrypted and signed (confidential). - [sent_by_acceptor]: whether this token comes from the acceptor - [acceptor_subkey]: see RFC - [sequence_number]: a sequence number - [get_ec]: This function returns the "extra count" number for the size of the plaintext w/o filler (e.g. use {!Netmech_scram.Cryptosystem.get_ec}). - [encrypt_and_sign]: the encryption function from the cryptosystem. The plaintext is passed to this function, and the ciphertext with the appended signature must be returned in the string. - [message]: the payload message The function returns the token wrapping the message. *) val parse_wrap_token_header : message -> (bool * bool * bool * int64) (** [let (sent_by_acceptor, sealed, acceptor_subkey, sequence_number) = parse_wrap_token_header token] Fails if the [token] cannot be parsed. *) val unwrap_wrap_token_conf : decrypt_and_verify:(message -> message) -> token:message -> message (** Unwraps the [token] using the decryption function [decrypt_and_verify] from the cryptosystem. The functions fails if there is a format error, or the integrity check fails. Non-confidential messages cannot be unwrapped with this function. *) (** Token functions for non-confidential messages are still missing *) ocamlnet-4.1.6/src/netstring/nethtml.ml0000644000175000017500000005471713274252310016576 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) open Nethtml_scanner;; type document = Element of (string * (string*string) list * document list) | Data of string ;; exception End_of_scan;; exception Found;; type element_class = (* What is the class of an element? *) [ `Inline | `Block | `Essential_block | `None | `Everywhere ] ;; type model_constraint = (* The constraint the subelements must fulfill *) [ `Inline | `Block | `Flow (* = `Inline or `Block *) | `Empty | `Any | `Special | `Elements of string list (* Enumeration of allowed elements *) | `Or of (model_constraint * model_constraint) | `Except of (model_constraint * model_constraint) | `Sub_exclusions of (string list * model_constraint) ] ;; type simplified_dtd = (string * (element_class * model_constraint)) list let ( |. ) a b = `Or(a,b);; let ( -. ) a b = `Except(a,b);; let block_elements = (* Only used for exclusions *) [ "p"; "dl"; "div"; "center"; "noscript"; "noframes"; "blockquote"; "form"; "isindex"; "hr"; "table"; "fieldset"; "address"; "h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "pre"; "ul"; "ol"; "dir"; "menu" ];; let html40_dtd = [ (* --------- INLINE ELEMENTS ------------ *) (* %fontstyle; *) "tt", (`Inline, `Inline); "i", (`Inline, `Inline); "b", (`Inline, `Inline); "big", (`Inline, `Inline); "small", (`Inline, `Inline); (* transitional: *) "u", (`Inline, `Inline); "s", (`Inline, `Inline); "strike", (`Inline, `Inline); (* %phrase; *) "em", (`Inline, `Inline); "strong", (`Inline, `Inline); "dfn", (`Inline, `Inline); "code", (`Inline, `Inline); "samp", (`Inline, `Inline); "kbd", (`Inline, `Inline); "var", (`Inline, `Inline); "cite", (`Inline, `Inline); "abbr", (`Inline, `Inline); "acronym", (`Inline, `Inline); (* %special; *) "sup", (`Inline, `Inline); "sub", (`Inline, `Inline); "span", (`Inline, `Inline); "bdo", (`Inline, `Inline); "br", (`Inline, `Empty); "a", (`Inline, `Sub_exclusions(["a"],`Inline)); "img", (`Inline, `Empty); "object", (`Inline, (`Flow |. `Elements ["param"])); "script", (`Inline, `Special); "map", (`Inline, (`Flow |. `Elements ["area"])); "q", (`Inline, `Inline); (* transitional: *) "applet", (`Inline, (`Flow |. `Elements ["param"])); "font", (`Inline, `Inline); "basefont", (`Inline, `Empty); "iframe", (`Inline, `Flow); (* %formctrl; *) "input", (`Inline, `Empty); "select", (`Inline, `Elements ["optgroup"; "option"]); "textarea", (`Inline, `Elements []); (* #PCDATA *) "label", (`Inline, `Sub_exclusions( ["label"], `Inline)); "button", (`Inline, `Sub_exclusions( ["a"; "input"; "select"; "textarea"; "label"; "button"; "form"; "fieldset"; "isindex"; "iframe"], `Flow)); (* ------------ BLOCK ELEMENTS ----------*) "p", (`Block, `Inline); (* %heading; *) "h1", (`Block, `Inline); "h2", (`Block, `Inline); "h3", (`Block, `Inline); "h4", (`Block, `Inline); "h5", (`Block, `Inline); "h6", (`Block, `Inline); (* %list; *) "ul", (`Block, `Elements ["li"]); "ol", (`Block, `Elements ["li"]); (* transitional: *) "dir", (`Block, `Sub_exclusions( block_elements, `Elements ["li"])); "menu", (`Block, `Sub_exclusions( block_elements, `Elements ["li"])); (* %preformatted; *) "pre", (`Block, `Sub_exclusions( [ "img"; "object"; "applet"; "big"; "small"; "sub"; "sup"; "font"; "basefont"], `Inline )); (* other: *) "dl", (`Block, `Elements ["dt"; "dd"]); "div", (`Block, `Flow); "noscript", (`Block, `Flow); "blockquote", (`Block, (`Flow |. `Elements ["script"])); (* strict DTD has `Block here *) "form", (`Block, `Sub_exclusions( ["form"], `Flow |. `Elements ["script"])); (* strict DTD has `Block here *) "hr", (`Block, `Empty); "table", (`Block, `Elements ["caption"; "col"; "colgroup"; "thead"; "tfoot"; "tbody"; "tr"]); "fieldset", (`Block, (`Flow |. `Elements ["legend"])); "address", (`Block, `Inline); (* transitional: *) "center", (`Block, `Flow); "noframes", (`Block, `Flow); "isindex", (`Block, `Empty); (* ------------ OTHER ELEMENTS ----------*) "body", (`None, (`Flow |. `Elements ["script"])); (* strict DTD has `Block here *) "area", (`None, `Empty); "link", (`None, `Empty); "param", (`None, `Empty); "ins", (`Everywhere, `Flow); "del", (`Everywhere, `Flow); "dt", (`None, `Inline); "dd", (`None, `Flow); "li", (`None, `Flow); "optgroup", (`None, `Elements ["option"]); "option", (`None, `Elements []); (* #PCDATA *) "legend", (`None, `Inline); "caption", (`None, `Inline); "thead", (`None, `Elements ["tr"]); "tbody", (`None, `Elements ["tr"]); "tfoot", (`None, `Elements ["tr"]); "colgroup", (`None, `Elements ["col"]); "col", (`None, `Empty); "tr", (`None, `Elements ["th"; "td"]); "th", (`None, `Flow); "td", (`None, `Flow); "head", (`None, `Elements ["title"; "base"; "script"; "style"; "meta"; "link"; "object"]); "title", (`None, `Elements []); (* #PCDATA *) "base", (`None, `Empty); "meta", (`None, `Empty); "style", (`None, `Special); "html", (`None, (`Flow |. `Elements ["head"; "title"; "base"; "script"; "style"; "meta"; "link"; "object"; "body"; "frameset"])); (* transitional: *) "frameset", (`None, `Elements ["frameset"; "frame"; "noframes"]); "frame", (`None, `Empty); ] ;; let relax_dtd dtd = (* Changes (`Inline, `Inline) constraints into (`Inline, `Flow). *) let rec relax_model m = match m with `Inline -> `Flow | `Sub_exclusions(l,m') -> `Sub_exclusions(l,relax_model m') | other -> other in List.map (fun (name, (elclass, elconstr)) -> match elclass with `Inline -> (name, (elclass, relax_model elconstr)) | other -> (name, (elclass, elconstr)) ) dtd ;; let essential_blocks dtd elements = (* Changes the passed block elements into essential block elements *) List.map (fun (name, (elclass, elconstr)) -> match elclass with `Block when List.mem name elements -> (name, ( `Essential_block, elconstr)) | other -> (name, (elclass, elconstr)) ) dtd ;; let relaxed_html40_dtd = essential_blocks (relax_dtd html40_dtd) [ "body"; "table"; "ol"; "ul"; "dl" ] ;; let rec parse_comment buf = let t = scan_comment buf in match t with Mcomment -> let s = Lexing.lexeme buf in s ^ parse_comment buf | Eof -> raise End_of_scan | _ -> (* must be Rcomment *) "" ;; let rec parse_doctype buf = let t = scan_doctype buf in match t with Mdoctype -> let s = Lexing.lexeme buf in s ^ parse_doctype buf | Eof -> raise End_of_scan | _ -> (* must be Rdoctype *) "" ;; let rec parse_pi buf = let t = scan_pi buf in match t with Mpi -> let s = Lexing.lexeme buf in s ^ parse_pi buf | Eof -> raise End_of_scan | _ -> (* must be Rpi *) "" ;; let hashtbl_from_alist l = let ht = Hashtbl.create (List.length l) in List.iter (fun (k, v) -> Hashtbl.add ht k v) l; ht ;; module S = struct type t = string let compare = (Pervasives.compare : string -> string -> int) end module Strset = Set.Make(S);; let parse_document ?(dtd = html40_dtd) ?(return_declarations = false) ?(return_pis = false) ?(return_comments = false) ?(case_sensitive = false) buf = let current_name = ref "" in let current_atts = ref [] in let current_subs = ref [] in let current_excl = ref Strset.empty in (* current exclusions *) let stack = Stack.create() in let dtd_hash = hashtbl_from_alist dtd in let maybe_lowercase = if case_sensitive then (fun s -> s) else STRING_LOWERCASE in let model_of element_name = if element_name = "" then (`Everywhere, `Any) else let extract = function (eclass, `Sub_exclusions(_,m)) -> eclass, m | m -> m in try extract(Hashtbl.find dtd_hash element_name) with Not_found -> (`Everywhere, `Any) in let exclusions_of element_name = if element_name = "" then [] else let extract = function (eclass, `Sub_exclusions(l,_)) -> l | _ -> [] in try extract(Hashtbl.find dtd_hash element_name) with Not_found -> [] in let is_possible_subelement parent_element parent_exclusions sub_element = let (sub_class, _) = model_of sub_element in let rec eval m = match m with `Inline -> sub_class = `Inline | `Block -> sub_class = `Block || sub_class = `Essential_block | `Flow -> sub_class = `Inline || sub_class = `Block || sub_class = `Essential_block | `Elements l -> List.mem sub_element l | `Any -> true | `Or(m1,m2) -> eval m1 || eval m2 | `Except(m1,m2) -> eval m1 && not (eval m2) | `Empty -> false | `Special -> false | `Sub_exclusions(_,_) -> assert false in (sub_class = `Everywhere) || ( (not (Strset.mem sub_element parent_exclusions)) && let (_, parent_model) = model_of parent_element in eval parent_model ) in let unwind_stack sub_name = (* If the current element is not a possible parent element for sub_name, * search the parent element in the stack. * Either the new current element is the parent, or there was no * possible parent. In the latter case, the current element is the * same element as before. *) let backup = Stack.create() in let backup_name = !current_name in let backup_atts = !current_atts in let backup_subs = !current_subs in let backup_excl = !current_excl in try while not (is_possible_subelement !current_name !current_excl sub_name) do (* Maybe we are not allowed to end the current element: *) let (current_class, _) = model_of !current_name in if current_class = `Essential_block then raise Stack.Empty; (* End the current element and remove it from the stack: *) let grant_parent = Stack.pop stack in Stack.push grant_parent backup; (* Save it; may we need it *) let (gp_name, gp_atts, gp_subs, gp_excl) = grant_parent in (* If gp_name is an essential element, we are not allowed to close * it implicitly, even if that violates the DTD. *) let current = Element (!current_name, !current_atts, List.rev !current_subs) in current_name := gp_name; current_atts := gp_atts; current_excl := gp_excl; current_subs := current :: gp_subs done; with Stack.Empty -> (* It did not work! Push everything back to the stack, and * resume the old state. *) while Stack.length backup > 0 do Stack.push (Stack.pop backup) stack done; current_name := backup_name; current_atts := backup_atts; current_subs := backup_subs; current_excl := backup_excl in let parse_atts() = let rec next_no_space p_string = (* p_string: whether string literals in quotation marks are allowed *) let tok = if p_string then scan_element_after_Is buf else scan_element buf in match tok with Space _ -> next_no_space p_string | t -> t in let rec parse_atts_lookahead next = match next with | Relement -> ( [], false ) | Relement_empty -> ( [], true ) | Name n -> ( match next_no_space false with Is -> ( match next_no_space true with Name v -> let toks, is_empty = parse_atts_lookahead (next_no_space false) in ( (maybe_lowercase n, v) :: toks, is_empty ) | Literal v -> let toks, is_empty = parse_atts_lookahead (next_no_space false) in ( (maybe_lowercase n,v) :: toks, is_empty ) | Eof -> raise End_of_scan | Relement -> (* Illegal *) ( [], false ) | Relement_empty -> (* Illegal *) ( [], true ) | _ -> (* Illegal *) parse_atts_lookahead (next_no_space false) ) | Eof -> raise End_of_scan | Relement -> (* <==> *) ( [ maybe_lowercase n, maybe_lowercase n ], false) | Relement_empty -> (* <==> *) ( [ maybe_lowercase n, maybe_lowercase n ], true) | next' -> (* assume <==> *) let toks, is_empty = parse_atts_lookahead next' in ( ( maybe_lowercase n, maybe_lowercase n ) :: toks, is_empty) ) | Eof -> raise End_of_scan | _ -> (* Illegal *) parse_atts_lookahead (next_no_space false) in parse_atts_lookahead (next_no_space false) in let rec parse_special name = (* Parse until *) match scan_special buf with | Lelementend n -> if maybe_lowercase n = name then "" else " raise End_of_scan | Cdata s -> s ^ parse_special name | _ -> (* Illegal *) parse_special name in let rec skip_element() = (* Skip until ">" (or "/>") *) match scan_element buf with | Relement | Relement_empty -> () | Eof -> raise End_of_scan | _ -> skip_element() in let rec parse_next() = let t = scan_document buf in match t with | Lcomment -> let comment = parse_comment buf in if return_comments then current_subs := (Element("--",["contents",comment],[])) :: !current_subs; parse_next() | Ldoctype -> let decl = parse_doctype buf in if return_declarations then current_subs := (Element("!",["contents",decl],[])) :: !current_subs; parse_next() | Lpi -> let pi = parse_pi buf in if return_pis then current_subs := (Element("?",["contents",pi],[])) :: !current_subs; parse_next() | Lelement name -> let name = maybe_lowercase name in let (_, model) = model_of name in ( match model with `Empty -> let atts, _ = parse_atts() in unwind_stack name; current_subs := (Element(name, atts, [])) :: !current_subs; parse_next() | `Special -> let atts, is_empty = parse_atts() in unwind_stack name; let data = if is_empty then "" else ( let d = parse_special name in (* Read until ">" *) skip_element(); d ) in current_subs := (Element(name, atts, [Data data])) :: !current_subs; parse_next() | _ -> let atts, is_empty = parse_atts() in (* Unwind the stack until we find an element which can be * the parent of the new element: *) unwind_stack name; if is_empty then ( (* Simple case *) current_subs := (Element(name, atts, [])) :: !current_subs; ) else ( (* Push the current element on the stack, and this element * becomes the new current element: *) let new_excl = exclusions_of name in Stack.push (!current_name, !current_atts, !current_subs, !current_excl) stack; current_name := name; current_atts := atts; current_subs := []; List.iter (fun xel -> current_excl := Strset.add xel !current_excl) new_excl; ); parse_next() ) | Cdata data -> current_subs := (Data data) :: !current_subs; parse_next() | Lelementend name -> let name = maybe_lowercase name in (* Read until ">" *) skip_element(); (* Search the element to close on the stack: *) let found = (name = !current_name) || try Stack.iter (fun (old_name, _, _, _) -> if name = old_name then raise Found; match model_of old_name with `Essential_block, _ -> raise Not_found; (* Don't close essential blocks implicitly *) | _ -> ()) stack; false with Found -> true | Not_found -> false in (* If not found, the end tag is wrong. Simply ignore it. *) if not found then parse_next() else begin (* If found: Remove the elements from the stack, and append * them to the previous element as sub elements *) while !current_name <> name do let old_name, old_atts, old_subs, old_excl = Stack.pop stack in current_subs := (Element (!current_name, !current_atts, List.rev !current_subs)) :: old_subs; current_name := old_name; current_atts := old_atts; current_excl := old_excl done; (* Remove one more element: the element containing the element * currently being closed. *) let old_name, old_atts, old_subs, old_excl = Stack.pop stack in current_subs := (Element (!current_name, !current_atts, List.rev !current_subs)) :: old_subs; current_name := old_name; current_atts := old_atts; current_excl := old_excl; (* Go on *) parse_next() end | Eof -> raise End_of_scan | _ -> parse_next() in try parse_next(); (* never returns. Will get a warning X *) assert false with End_of_scan -> (* Close all remaining elements: *) while Stack.length stack > 0 do let old_name, old_atts, old_subs, old_excl = Stack.pop stack in current_subs := Element (!current_name, !current_atts, List.rev !current_subs) :: old_subs; current_name := old_name; current_atts := old_atts; current_excl := old_excl done; List.rev !current_subs ;; let parse ?dtd ?return_declarations ?return_pis ?return_comments ?case_sensitive ch = let buf = Netchannels.lexbuf_of_in_obj_channel ch in parse_document ?dtd ?return_declarations ?return_comments ?return_pis ?case_sensitive buf ;; type xmap_value = | Xmap_attribute of string * string * string (* elname, attname, attval *) | Xmap_data of string option * string (* elname, pcdata *) let rec xmap f surelem doc = (* surdoc: surrounding element *) match doc with | Element(name,atts,subdocs) -> (match name with | "!" | "?" | "--" -> Element(name,atts,xmap_list f None subdocs) | _ -> let atts' = List.map (fun (aname,aval) -> aname, f (Xmap_attribute(name, aname, aval)) ) atts in let subdocs' = xmap_list f (Some name) subdocs in Element(name,atts',subdocs') ) | Data s -> Data(f (Xmap_data(surelem,s))) and xmap_list f surelem l = List.map (xmap f surelem) l;; let map_list f l = xmap_list (function | Xmap_attribute(_, _, v) -> f v | Xmap_data(_, v) -> f v ) None l let encode ?(enc = `Enc_iso88591) ?(prefer_name = true) ?(dtd = html40_dtd) dl = let enc_string = Netencoding.Html.encode ~in_enc:enc ~out_enc:`Enc_usascii ~prefer_name () in let dtd_hash = hashtbl_from_alist dtd in let enc_node = function | Xmap_attribute(_, _, v) -> enc_string v | Xmap_data(None, v) -> enc_string v | Xmap_data(Some el, v) -> let is_special = try snd(Hashtbl.find dtd_hash el) = `Special with Not_found -> false in if is_special then v else enc_string v in xmap_list enc_node None dl ;; let decode ?(enc = `Enc_iso88591) ?subst ?entity_base ?lookup ?(dtd = html40_dtd) dl = let dec_string = Netencoding.Html.decode ~in_enc:enc ~out_enc:enc ?subst ?entity_base ?lookup () in let dtd_hash = hashtbl_from_alist dtd in let dec_node = function | Xmap_attribute(_, _, v) -> dec_string v | Xmap_data(None, v) -> dec_string v | Xmap_data(Some el, v) -> let is_special = try snd(Hashtbl.find dtd_hash el) = `Special with Not_found -> false in if is_special then v else dec_string v in xmap_list dec_node None dl ;; let quote_quot_re = Netstring_str.regexp "\"";; let write_ ~dtd ~xhtml write_os doc = let quote_quot s = Netstring_str.global_substitute quote_quot_re (fun _ _ -> """) s in let rec trav doc = match doc with Element(name,atts,subdocs) -> ( match name with "!" -> write_os ""; | "?" -> write_os ""; | "--" -> write_os ""; | _ -> let is_empty = try let _, constr = List.assoc name dtd in constr = `Empty with Not_found -> false in write_os "<"; write_os name; List.iter (fun (aname,aval) -> write_os " "; write_os aname; write_os "=\""; write_os (quote_quot aval); write_os "\""; ) atts; if is_empty then (* Ignore subdocs (even if <> []) because they should not be there. *) write_os (if xhtml then "/>" else ">") else begin write_os ">"; List.iter trav subdocs; write_os ""; end ) | Data s -> write_os s in try List.iter trav doc with Not_found -> failwith "write" ;; let write ?(dtd = html40_dtd) ?(xhtml = true) ch doc = write_ ~dtd ~xhtml (ch # output_string) doc ocamlnet-4.1.6/src/netstring/nethtml.mli0000644000175000017500000003771313274252310016744 0ustar gerdgerd(* $Id$ * ---------------------------------------------------------------------- * *) (** Parsing of HTML *) (** The type [document] represents parsed HTML documents: * * {ul * {- [Element (name, args, subnodes)] is an element node for an element of * type [name] (i.e. written [...]) with arguments [args] * and subnodes [subnodes] (the material within the element). The arguments * are simply name/value pairs. Entity references (something like [&xy;]) * occuring in the values are {b not} resolved. * * Arguments without values (e.g. [