ocaml-curses-1.0.3/0000775000076400007640000000000011110320237013472 5ustar rjonesrjonesocaml-curses-1.0.3/functions.c0000664000076400007640000004725311110316645015671 0ustar rjonesrjones/* addch */ ML1(addch,err,chtype) ML2(waddch,err,window,chtype) ML3(mvaddch,err,int,int,chtype) ML4(mvwaddch,err,window,int,int,chtype) ML1(echochar,err,chtype) ML2(wechochar,err,window,chtype) /* addchstr */ #define copie(l,id,ar) int i,c=l,r; \ chtype *t=malloc((c+1)*sizeof(chtype)); \ if(t==NULL) failwith("Out of memory"); \ for(i=0;i0); END ML1(tigetnum,int,string) ML1d(tigetstr,string,string) BEG1 char *s=tigetstr(a_string(aa)); if((s==NULL)||(s==(char * )-1)) failwith("tigetstr"); CAMLreturn(copy_string(s)); END ML3d(tputs,err,string,int,(char->unit)) BEG3 putc_function=ac; r_err(tputs(a_string(aa),a_int(ab),putc_callback)); END ML2d(vidputs,err,chtype,(char->unit)) BEG2 putc_function=ab; r_err(vidputs(a_chtype(aa),putc_callback)); END #ifdef PDCURSES /* RWMJ: PDCurses has a moronic definition of tparm where they * seem to be trying to implement varargs on their own. Prototype * a sensible definition instead, at the cost of a warning: */ static char *(*mlcurses_rpl_tparm) (const char *, ...) = (void *) tparm; #else #define mlcurses_rpl_tparm tparm #endif ML2d(tparm,string,string,int array) BEG2 int t[10],i,n=Wosize_val(ab); if(n>10) n=10; for(i=0;i tr = quote(mlcurses_##f) #define ML1(f,tr,ta) \ external f : ta -> tr = quote(mlcurses_##f) #define ML2(f,tr,ta,tb) \ external f : ta -> tb -> tr = quote(mlcurses_##f) #define ML3(f,tr,ta,tb,tc) \ external f : ta -> tb -> tc -> tr = quote(mlcurses_##f) #define ML4(f,tr,ta,tb,tc,td) \ external f : ta -> tb -> tc -> td -> tr = quote(mlcurses_##f) #define ML5(f,tr,ta,tb,tc,td,te) \ external f : ta -> tb -> tc -> td -> te -> tr = quote(mlcurses_##f) #define ML6(f,tr,ta,tb,tc,td,te,tf) \ external f : ta -> tb -> tc -> td -> te -> tf -> tr \ = quote(mlcurses_##f##_bytecode) quote(mlcurses_##f##_native) #define ML7(f,tr,ta,tb,tc,td,te,tf,tg) \ external f : ta -> tb -> tc -> td -> te -> tf -> tg -> tr \ = quote(mlcurses_##f##_bytecode) quote(mlcurses_##f##_native) #define ML8(f,tr,ta,tb,tc,td,te,tf,tg,th) \ external f : ta -> tb -> tc -> td -> te -> tf -> tg -> th -> tr \ = quote(mlcurses_##f##_bytecode) quote(mlcurses_##f##_native) #define ML9(f,tr,ta,tb,tc,td,te,tf,tg,th,ti) \ external f : ta -> tb -> tc -> td -> te -> tf -> tg -> th -> ti -> tr \ = quote(mlcurses_##f##_bytecode) quote(mlcurses_##f##_native) #define ML0d(f,tr) ML0(f,tr) #define ML1d(f,tr,ta) ML1(f,tr,ta) #define ML2d(f,tr,ta,tb) ML2(f,tr,ta,tb) #define ML3d(f,tr,ta,tb,tc) ML3(f,tr,ta,tb,tc) #define ML4d(f,tr,ta,tb,tc,td) ML4(f,tr,ta,tb,tc,td) #define ML5d(f,tr,ta,tb,tc,td,te) ML5(f,tr,ta,tb,tc,td,te) #define ML6d(f,tr,ta,tb,tc,td,te,tf) ML6(f,tr,ta,tb,tc,td,te,tf) #define ML0_notimpl(f,tr) ML0(f,tr) #define ML1_notimpl(f,tr,ta) ML1(f,tr,ta) #define ML2_notimpl(f,tr,ta,tb) ML2(f,tr,ta,tb) #define BEG (* #define BEG0 BEG #define BEG1 BEG #define BEG2 BEG #define BEG3 BEG #define BEG4 BEG #define BEG5 BEG #define BEG6 BEG #define BEG7 BEG #define BEG8 BEG #define BEG9 BEG #define END *) module Acs = struct type acs = { ulcorner: chtype; llcorner: chtype; urcorner: chtype; lrcorner: chtype; ltee: chtype; rtee: chtype; btee: chtype; ttee: chtype; hline: chtype; vline: chtype; plus: chtype; s1: chtype; s9: chtype; diamond: chtype; ckboard: chtype; degree: chtype; plminus: chtype; bullet: chtype; larrow: chtype; rarrow: chtype; darrow: chtype; uarrow: chtype; board: chtype; lantern: chtype; block: chtype; s3: chtype; s7: chtype; lequal: chtype; gequal: chtype; pi: chtype; nequal: chtype; sterling: chtype } let bssb a = a.ulcorner let ssbb a = a.llcorner let bbss a = a.urcorner let sbbs a = a.lrcorner let sbss a = a.rtee let sssb a = a.ltee let ssbs a = a.btee let bsss a = a.ttee let bsbs a = a.hline let sbsb a = a.vline let ssss a = a.plus end #include "functions.c" (* these two were written separately in ml_curses.c, * to permit proper threading behavior *) ML0(getch,int) ML1(wgetch,int,window) let null_window = null_window () let bool_terminfo_variables = Hashtbl.create 67 let num_terminfo_variables = Hashtbl.create 67 let str_terminfo_variables = Hashtbl.create 601 let () = let rec ins f h n = let (a, b, c) = f n in if a = "" then () else ( Hashtbl.add h c (a, b); ins f h (n + 1) ) in (* These functions do not exist on all curses implementations, * so if they throw Invalid_argument, just ignore it. *) try ins bool_terminfo_variable bool_terminfo_variables 0; ins num_terminfo_variable num_terminfo_variables 0; ins str_terminfo_variable str_terminfo_variables 0 with Invalid_argument _ -> () /* (* Bon, je vais recopier les constantes directement, parceque je n'ai * aucune idée de comment générer ça automatiquement proprement. Si ça ne * marche pas chez vous, il vous suffit de regarder l'include, et de * corriger à la main. Faites-le moi savoir, à tout hasard... *) */ module A = struct let normal = 0 let attributes = 0x7FFFFF00 let chartext = 0x000000FF let color = 0x0000FF00 let standout = 0x00010000 let underline = 0x00020000 let reverse = 0x00040000 let blink = 0x00080000 let dim = 0x00100000 let bold = 0x00200000 let altcharset = 0x00400000 let invis = 0x00800000 let protect = 0x01000000 let horizontal = 0x02000000 let left = 0x04000000 let low = 0x08000000 let right = 0x10000000 let top = 0x20000000 let vertical = 0x40000000 let combine = List.fold_left (lor) 0 let color_pair n = (n lsl 8) land color let pair_number a = (a land color) lsr 8 end (*/* Je sais, c'est moche, mais ça marche */*) module WA = A module Color = struct let black = 0 let red = 1 let green = 2 let yellow = 3 let blue = 4 let magenta = 5 let cyan = 6 let white = 7 end module Key = struct #include "keys.ml" let f n = f0 + n end module Curses_config = struct #include "config.ml" end ocaml-curses-1.0.3/CHANGES0000664000076400007640000000074110720275325014504 0ustar rjonesrjones1.0.3 (unreleased) ===== * get*yx now return coordinates in the right order (thanks Brian Campbell). * Fix possible segfault with get_ripoff (thanks Brian Campbell). * Indicate that we should link with the curses library (thanks Jeff Meister). 1.0.2 (2007-10-09) ===== * Started to add documentation in curses.mli. * Using OCamlMakefile for the makefile, now handles bytecode-only compilation. * Libraries are now named curses.cm(x)a. 1.0.1 (2007-08-25) ===== * Initial release. ocaml-curses-1.0.3/COPYING0000664000076400007640000006347607445240224014562 0ustar rjonesrjones GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 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. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! ocaml-curses-1.0.3/configure.ac0000664000076400007640000001050511110316724015767 0ustar rjonesrjones############################################################################ # configure.ac # # Build configuration script for OCaml curses bindings. # # History: # # 2008-04-08 pjp Derived from Wyrd 1.4.4 build system. ############################################################################ # Check for a particular file from the source tree AC_INIT(config.ml.in) # optional arguments AC_ARG_ENABLE(widec, [ --enable-widec link against a wide-character-enabled ncurses)], [try_widec=$enable_widec], [try_widec=no]) # Find a C compiler AC_PROG_CC AC_PROG_CC_C_O AC_PROG_RANLIB ORIG_LIBS="$LIBS" ORIG_CPPFLAGS="$CPPFLAGS" CPPFLAGS="$CURSES_INCLUDE $ORIG_CPPFLAGS" # Non-required headers. AC_CHECK_HEADERS([termios.h sys/ioctl.h windows.h]) # Check for ncurses, and test a number of different locations for the header AC_MSG_CHECKING(for working ncurses library) if test "$try_widec" != "no" then LIBS="-lncursesw $ORIG_LIBS" AC_TRY_LINK( [#include ], [initscr(); use_default_colors()], [CURSES_LIB=-lncursesw AC_DEFINE(CURSES_HEADER, , [Defined to ncurses header file])]) fi if test -z "$CURSES_LIB" then LIBS="-lncurses $ORIG_LIBS" AC_TRY_LINK( [#include ], [initscr(); use_default_colors()], [CURSES_LIB=-lncurses AC_DEFINE(CURSES_HEADER, , [Defined to ncurses header file])], [ LIBS="-lncurses $ORIG_LIBS" AC_TRY_LINK( [#include ], [initscr(); use_default_colors()], [CURSES_LIB=-lncurses AC_DEFINE(CURSES_HEADER, , [Defined to ncurses header file])], [ LIBS="-lcurses $ORIG_LIBS" AC_TRY_LINK( [#include ], [initscr(); use_default_colors()], [CURSES_LIB=-lcurses AC_DEFINE(CURSES_HEADER, , [Defined to ncurses header file])], [ LIBS="-lncurses $ORIG_LIBS" AC_TRY_LINK( [#include ], [initscr(); use_default_colors()], [CURSES_LIB=-lcurses AC_DEFINE(CURSES_HEADER, , [Defined to ncurses header file])], [ LIBS="-lpdcurses $ORIG_LIBS" AC_TRY_LINK( [#include ], [initscr(); use_default_colors()], [CURSES_LIB=-lpdcurses AC_DEFINE(PDCURSES, 1, [Define if this is PDCurses]) AC_DEFINE(CURSES_HEADER, , [Defined to pdcurses header file])], ) ]) ]) ]) ]) fi if test -n "$CURSES_LIB" then AC_MSG_RESULT([found in $CURSES_LIB]) else AC_MSG_ERROR([not found]) fi # Try to locate term.h, which has a sadly nonstandardized location AC_MSG_CHECKING(for term.h) AC_TRY_COMPILE( [#include ], [TERMINAL __dummy], [TERM_H_STRING="" AC_DEFINE(CURSES_TERM_H, , [Defined to ncurses term.h file])], [ AC_TRY_COMPILE( [#include ], [TERMINAL __dummy], [TERM_H_STRING="" AC_DEFINE(CURSES_TERM_H, , [Defined to ncurses term.h file])], [ AC_TRY_COMPILE( [#include ], [TERMINAL __dummy], [TERM_H_STRING="" AC_DEFINE(CURSES_TERM_H, , [Defined to ncurses term.h file])], ) ]) ]) if test -n "$TERM_H_STRING" then AC_MSG_RESULT([found in $TERM_H_STRING]) else AC_MSG_ERROR([not found]) fi # Determine whether the detected curses has wide character support BOOL_WIDE_CURSES="false" if test -n "$CURSES_LIB" then LIBS="$CURSES_LIB $ORIG_LIBS" if test "$try_widec" != "no" then AC_MSG_CHECKING(for wide character support in ncurses library) AC_TRY_LINK( [#include #include CURSES_HEADER ], [wchar_t wch = 0; addnwstr(&wch, 1);], [AC_MSG_RESULT(yes) AC_DEFINE(HAVE_WIDE_CURSES, 1, [Defined if ncurses library includes wide character support]) BOOL_WIDE_CURSES="true"], [AC_MSG_RESULT(no)]) fi fi # Look for some functions which aren't found in all # curses implementations, eg. PDCurses. These are # optional: we will substitute them where we can. AC_CHECK_FUNCS([resizeterm resize_term]) CURSES_LIB_BASE=`expr "$CURSES_LIB" : '-l\(.*\)'` CPPFLAGS="$ORIG_CPPFLAGS" LIBS="$ORIG_LIBS" # Perform substitutions AC_SUBST(CURSES_HEADER) AC_SUBST(CURSES_TERM_H) AC_SUBST(CURSES_LIB) AC_SUBST(CURSES_LIB_BASE) AC_SUBST(BOOL_WIDE_CURSES) AC_SUBST(DEFS) AC_SUBST(CC) AC_SUBST(CFLAGS) AC_SUBST(CPPFLAGS) AC_SUBST(LDFLAGS) # Generate the Makefile and config module AC_CONFIG_HEADERS([config.h]) AC_CONFIG_FILES(Makefile config.ml) AC_OUTPUT chmod a-w Makefile ocaml-curses-1.0.3/config.ml.in0000664000076400007640000000205311010731420015675 0ustar rjonesrjones(*************************************************************************** * OCaml Curses -- configuration information * Copyright (C) 2008 Paul Pelzl * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ***************************************************************************) (* Did we compile with ncurses wide char support? *) let wide_ncurses = @BOOL_WIDE_CURSES@ ocaml-curses-1.0.3/tmk/0000775000076400007640000000000011110320237014265 5ustar rjonesrjonesocaml-curses-1.0.3/tmk/tmkStyle_l.mll0000664000076400007640000000272407445615623017155 0ustar rjonesrjones{ let strbuf = Buffer.create 128 } let word = ['a'-'z' 'A'-'Z' '0'-'9' '_'] let word_start = ['a'-'z' 'A'-'Z' '_'] rule lexeme = parse [' ' '\n' '\r' '\t'] { lexeme lexbuf } | '=' { TmkStyle_p.Equal } | "!=" { TmkStyle_p.Nequal } | '~' { TmkStyle_p.Tilde } | '[' { TmkStyle_p.LBracket } | ']' { TmkStyle_p.RBracket } | '{' { TmkStyle_p.LBrace } | '}' { TmkStyle_p.RBrace } | '(' { TmkStyle_p.LParen } | ')' { TmkStyle_p.RParen } | ',' { TmkStyle_p.Comma } | '&' '&'? { TmkStyle_p.And } | '|' '|'? { TmkStyle_p.Or } | '!' { TmkStyle_p.Not } | '$' word+ { TmkStyle_p.Env (Lexing.lexeme lexbuf) } | word_start word* { TmkStyle_p.Ident (Lexing.lexeme lexbuf) } | ['0'-'9']+ { TmkStyle_p.Int (int_of_string (Lexing.lexeme lexbuf)) } | ('0' ['x' 'X']) ['0'-'9' 'a'-'f' 'A'-'F']+ { TmkStyle_p.Int (int_of_string ((Lexing.lexeme lexbuf))) } | ('0' ['o' 'O']) ['0'-'7']+ { TmkStyle_p.Int (int_of_string ((Lexing.lexeme lexbuf))) } | '"' { TmkStyle_p.Str (string lexbuf) } | eof { TmkStyle_p.Eof } and string = parse "\\\\" { Buffer.add_char strbuf '\\'; string lexbuf } | "\\\n" { string lexbuf } | "\\\"" { Buffer.add_char strbuf '"'; string lexbuf } | '\\' _ { Buffer.add_char strbuf '\\'; Buffer.add_char strbuf (Lexing.lexeme lexbuf).[1]; string lexbuf } | [^ '\\' '"']* { Buffer.add_string strbuf (Lexing.lexeme lexbuf); string lexbuf } | '"' { let r = Buffer.contents strbuf in Buffer.clear strbuf; r } { } ocaml-curses-1.0.3/tmk/tmkArea.ml0000664000076400007640000000416207445615623016234 0ustar rjonesrjones(************************************************************************** * TmkArea * Class that encloses the global functions curses windows and pads **************************************************************************) class virtual window = object (self) val mutable refresh_queued = false method virtual window : Curses.window (* Sets the viewport (relative to the parent) for this window *) method set_view (_ : int) (_ : int) (_ : int) (_ : int) = () (* Center this window inside its viewport *) method set_center (_ : int) (_ : int) = () method resize (_ : int) (_ : int) = () method destroy () = () (* Returns the screen position given the window coordinates *) method real_position (p : int * int) = p method refresh () = refresh_queued <- false method queue_refresh q = if not refresh_queued then let () = Queue.add self#refresh q in refresh_queued <- true end (* Window used before initialization *) class null_window = object (self) inherit window as super method window = assert false end let null_window = (new null_window :> window) (* Toplevel window *) class toplevel w = object (self) inherit window as super method window = w method refresh () = ignore (Curses.refresh ()); super#refresh () end (* Pad *) (* TODO: allow to be inside another pad *) class pad p w h = object (self) inherit window as super val mutable w = w val mutable h = h val mutable vx = 0 val mutable vy = 0 val mutable vw = 0 val mutable vh = 0 val mutable px = 0 val mutable py = 0 method window = p method refresh () = ignore (Curses.prefresh p py px vy vx (vy + vh - 1) (vx + vw - 1)); ignore (Curses.refresh ()); super#refresh () method set_view nvx nvy nvw nvh = vx <- nvx; vy <- nvy; vw <- nvw; vh <- nvh method set_center x y = px <- max 0 (min (w - vw) (x - vw / 2)); py <- max 0 (min (h - vh) (y - vh / 2)) method resize nw nh = w <- nw; h <- nh; ignore (Curses.wresize p h w) method real_position (x,y) = (x - px + vx, y - py + vy) method destroy () = ignore (Curses.delwin p) end ocaml-curses-1.0.3/tmk/tmkPacking.ml0000664000076400007640000000607207445615623016742 0ustar rjonesrjonesopen TmkStruct type 'a box_element = { mutable base: int; mutable expand: int; element: 'a } let compute_position t l = let (bt, et) = List.fold_left (fun (x,y) e -> (x + e.base, y + e.expand)) (0,0) l in if bt > t then failwith "too small allocation"; let et = if et = 0 then 1 else et in let ep = t - bt in let rec aux xb xe a = function | [] -> [] | h::t -> let a = a + h.expand in let nxe = a * ep / et in ((xb + xe, h.base + nxe - xe) :: (aux (xb + h.base) nxe a t)) in aux 0 0 0 l let real_class_box = Class.create "Box" [TmkContainer.real_class_container] class virtual box parent = object (self) inherit TmkContainer.container as super val mutable children = [] val terminal = parent#terminal method parent = parent method terminal = terminal method children () = let rec aux = function | [] -> [] | { element = None } :: t -> aux t | { element = Some e } :: t -> e :: (aux t) in aux children method add w = children <- children @ [{ base = 0; expand = 0; element = Some w }]; self#signal_add_descendant#emit w method remove w = super#remove w; let rec aux a = function | ({ element = Some c} as h)::t when c == w -> (List.rev a) @ t | h::t -> aux (h::a) t | [] -> raise Not_found in children <- aux [] children method add_glue b e = children <- children @ [{ base = b; expand = e; element = None }] method set_child_expand w e = let aux = function | { element = Some x } -> x == w | _ -> false in let c = List.find aux children in c.expand <- e initializer parent#add self#coerce end let real_class_vbox = Class.create "VBox" [real_class_box] class vbox parent = object (self) inherit box parent as super method real_class = real_class_vbox method class_get_size t = let aux (cw,ch) e = match e.element with | Some w -> let (ew,eh) = w#signal_get_size#emit (0,0) in e.base <- eh; (max cw ew, ch + eh) | None -> (cw, ch + e.base) in List.fold_left aux t children method class_set_geometry ((gx,gy,gw,gh) as g) = super#class_set_geometry g; let ta = compute_position gh children in let aux (y,h) = function | { element = None } -> () | { element = Some w } -> w#signal_set_geometry#emit (gx, gy + y, gw, h) in List.iter2 aux ta children end let real_class_hbox = Class.create "Box" [real_class_box] class hbox parent = object (self) inherit box parent as super method real_class = real_class_hbox method class_get_size t = let aux (cw,ch) e = match e.element with | Some w -> let (ew,eh) = w#signal_get_size#emit (0,0) in e.base <- ew; (cw + ew, max ch eh) | None -> (cw + e.base, ch) in List.fold_left aux t children method class_set_geometry ((gx,gy,gw,gh) as g) = super#class_set_geometry g; let ta = compute_position gw children in let aux (x,l) = function | { element = None } -> () | { element = Some w } -> w#signal_set_geometry#emit (gx + x, gy, l, gh) in List.iter2 aux ta children end ocaml-curses-1.0.3/tmk/tmkMisc.ml0000664000076400007640000000274507445615623016264 0ustar rjonesrjonesopen TmkStruct let real_class_misc = Class.create "Misc" [TmkWidget.real_class_widget] class virtual misc w h = object (self) inherit TmkWidget.widget as super val mutable xalign = 50 val mutable yalign = 50 val mutable width = w val mutable height = h method set_align x y = if x >= 0 && x <= 100 then xalign <- x; if y >= 0 && y <= 100 then yalign <- y method class_get_size (w, h) = (width, height) method class_set_geometry (x, y, w, h) = let wa = w - width and ha = h - height in let g = (x + xalign * wa / 100, y + yalign * ha / 100, width, height) in super#class_set_geometry g end (**************************************************************************************** * La classe Label ****************************************************************************************) let real_class_label = Class.create "Label" [real_class_misc] class label parent t = object (self) inherit misc (String.length t) 1 as super val mutable txt = t val terminal = parent#terminal method real_class = real_class_label method parent = parent method terminal = terminal method class_get_size t = (String.length txt, 1) method class_draw () = super#class_draw (); let l = String.length txt in if l <= geometry.Geom.w then ( Curses.wattrset window attribute; ignore (Curses.mvwaddstr window geometry.Geom.y geometry.Geom.x txt) ) else ( ) initializer parent#add self#coerce; end ocaml-curses-1.0.3/tmk/tmkFrame.ml0000664000076400007640000000526507445615623016423 0ustar rjonesrjonesopen TmkStruct open Curses (**************************************************************************************** * La classe Frame ****************************************************************************************) let real_class_frame = Class.create "Frame" [TmkContainer.real_class_bin] class frame parent text = object (self) inherit TmkContainer.bin as super val acs = parent#terminal#acs method real_class = real_class_frame method parent = parent method terminal = parent#terminal method class_get_size t = match child with | None -> t | Some c -> let (w, h) = c#signal_get_size#emit t in let w = max w (String.length text) in (w + 2, h + 2) method class_set_geometry g = super#class_set_geometry g; match child with | None -> () | Some c -> c#signal_set_geometry#emit (succ geometry.Geom.x, succ geometry.Geom.y, geometry.Geom.w - 2, geometry.Geom.h) method class_draw () = super#class_draw (); let x1 = geometry.Geom.x and y1 = geometry.Geom.y and w = geometry.Geom.w - 2 and h = geometry.Geom.h - 2 in let x2 = succ x1 + w and y2 = succ y1 + h in ignore (wmove window y1 x1); wattrset window attribute; ignore (waddch window acs.Acs.ulcorner); ignore (waddstr window text); ignore (whline window 0 (w - (String.length text))); ignore (mvwaddch window y1 x2 acs.Acs.urcorner); ignore (mvwaddch window y2 x1 acs.Acs.llcorner); ignore (whline window 0 w); ignore (mvwaddch window y2 x2 acs.Acs.lrcorner); ignore (wmove window (succ y1) x1); ignore (wvline window 0 h); ignore (wmove window (succ y1) x2); ignore (wvline window 0 h) initializer parent#add self#coerce; end (**************************************************************************************** * La classe Rule ****************************************************************************************) let real_class_rule = Class.create "Rule" [TmkWidget.real_class_widget] class rule parent direction = object (self) inherit TmkWidget.widget as super val terminal = parent#terminal method real_class = real_class_rule method parent = parent method terminal = terminal method class_get_size t = (1, 1) method class_draw () = super#class_draw (); wattrset window attribute; match direction with | `Vertical -> ignore (wmove window geometry.Geom.y (geometry.Geom.x + geometry.Geom.w / 2)); ignore (wvline window 0 geometry.Geom.h) | `Horizontal -> ignore (wmove window (geometry.Geom.y + geometry.Geom.h / 2) geometry.Geom.x); ignore (whline window 0 geometry.Geom.w) initializer parent#add self#coerce; end ocaml-curses-1.0.3/tmk/hierarchy.txt0000664000076400007640000000107507445615623017035 0ustar rjonesrjones/* I know, this hierarchy looks a lot like the one of Gtk+, it is * normal, it is an imitation, because I know it well, and I find it * good, with some exceptions. */ Container * Bin * Window * TODO: border, shadow Menu Dialog Frame * Button * TODO: themable border CheckButton * RadioButton * OptionMenu MenuItem CheckMenuItem RadioMenuItem Notebook Box * HBox * VBox * Table List * Tree Notebook Label * Editable Entry ± Text Range HRange VRange MenuBar Rule * ocaml-curses-1.0.3/tmk/tmkMain.ml0000664000076400007640000000303007445615623016241 0ustar rjonesrjonesopen TmkStruct exception Exit_run let all_terms = ref [] let try_parse_config_file f () = try let f = open_in f in try let l = Lexing.from_channel f in let r = TmkStyle_p.parse TmkStyle_l.lexeme l in close_in f; r with e -> close_in f; raise e with e -> List.iter prerr_string ["Tmk config: "; f; ": "; Printexc.to_string e]; prerr_newline (); [] let init_raw () = TmkStyle.S.add_config_source (try_parse_config_file "tmkrc"); TmkStyle.S.process_config_sources () let add_terminal t = all_terms := t :: !all_terms let init () = let () = init_raw () in let r = new TmkTerminal.terminal_unique in all_terms := [r]; r let iterate_term (term : TmkWidget.terminal) = term#activate (); let q = term#event_queue in let () = try let k = term#read_key () in if k = 113 then raise Exit_run; if k = -1 then raise Exit; let w = term#current_toplevel () in Queue.add (fun () -> w#signal_toplevel_event#emit (Toplevel.Key k)) q with Exit -> () in let something = ref false in let () = try while true do let t = Queue.take q in t (); something := true done with Queue.Empty -> () in if !something then ( let (x,y) = term#get_cursor () in ignore (Curses.move y x); (*ignore (Curses.refresh ())*) ) let iterate () = List.iter iterate_term !all_terms let run () = try while true do iterate (); Curses.napms 1 done with Exit_run -> () let exit () = List.iter (fun t -> t#exit ()) !all_terms ocaml-curses-1.0.3/tmk/tmkContainer.ml0000664000076400007640000001637607445615623017320 0ustar rjonesrjonesopen TmkStruct (**************************************************************************************** * La classe Container ****************************************************************************************) let real_class_container = Class.create "Container" [TmkWidget.real_class_widget] class virtual container = object (self) inherit TmkWidget.widget as super val mutable redrawing_children = ([] : TmkWidget.widget list) method is_container = true method queue_redraw () = if not need_redraw then ( super#queue_redraw (); redrawing_children <- []; List.iter (fun c -> c#queue_redraw ()) (self#children ()) ) method redraw_register (w : TmkWidget.widget) = if not need_redraw then ( redrawing_children <- w :: redrawing_children; try self#parent#redraw_register self#coerce with Not_found -> Queue.add self#redraw_deliver self#terminal#event_queue ) method redraw_deliver () = if geometry.Geom.w > 0 && geometry.Geom.h > 0 then ( if need_redraw then super#redraw_deliver () else ( List.iter (fun c -> c#redraw_deliver ()) redrawing_children; redrawing_children <- [] ) ) method add w = self#signal_add_descendant#emit w method remove w = TmkWidget.full_tree_do_post (fun d -> self#signal_remove_descendant#emit d) (w :> TmkWidget.widget) method class_map w = super#class_map w; List.iter (fun c -> c#signal_map#emit w) (self#children ()) method class_set_state s = super#class_set_state s; List.iter (fun c -> c#signal_set_state#emit s) (self#children ()) method class_draw () = super#class_draw (); List.iter (fun c -> c#signal_draw#emit ()) (self#children ()) method class_add_descendant (w : TmkWidget.widget) = try self#parent#signal_add_descendant#emit w with Not_found -> assert false method class_remove_descendant (w : TmkWidget.widget) = try self#parent#signal_remove_descendant#emit w with Not_found -> assert false end (**************************************************************************************** * La classe Bin ****************************************************************************************) let real_class_bin = Class.create "Bin" [real_class_container] class virtual bin = object (self) inherit container as super val mutable child : TmkWidget.widget option = None method children () = match child with | Some w -> [w] | None -> [] method add (w : TmkWidget.widget) = match child with | Some _ -> failwith "bin has already a child" | None -> child <- Some w; self#signal_add_descendant#emit w method remove w = match child with | Some c when c == w -> super#remove w; child <- None | _ -> raise Not_found end (**************************************************************************************** * La classe utilitaire Toplevel ****************************************************************************************) let real_class_toplevel = Class.create "Toplevel" [] class virtual toplevel (term : TmkWidget.terminal) = object (self) val mutable focus = (None : TmkWidget.widget option) method toplevel_pass = function | Toplevel.Give_focus (w : TmkWidget.widget) -> assert w#can_focus; let f = match focus with | None -> assert false | Some f -> f in f#signal_lost_focus#emit (); w#signal_got_focus#emit (); focus <- Some w method set_cursor c = term#set_cursor c method class_add_descendant (w : TmkWidget.widget) = if w#can_focus then ( match focus with | Some _ -> () | None -> focus <- Some w ); term#queue_resize () method class_remove_descendant (w : TmkWidget.widget) = let () = match focus with | Some f when f == w -> focus <- TmkWidget.find_first_focusable w self#coerce; (match focus with | Some f -> w#signal_got_focus#emit () | None -> ()) | _ -> () in term#queue_resize () method class_toplevel_event = function | Toplevel.Activate -> let () = match focus with | None -> () | Some w -> w#signal_got_focus#emit () in () | Toplevel.Desactivate -> () | Toplevel.Key k -> let () = match focus with | None -> () | Some w -> ignore (w#signal_key_event#emit k) in () end (**************************************************************************************** * La classe Window ****************************************************************************************) let real_class_window = Class.create "Window" [real_class_bin; real_class_toplevel] class window (term : TmkWidget.terminal) = object (self) inherit bin as super inherit toplevel term as super_toplevel val mutable child_size = (0,0) val mutable child_scroll = false val mutable child_window = TmkArea.null_window val child_geometry = Geom.null () val mutable left_glue = 0 val mutable right_glue = 0 val mutable top_glue = 0 val mutable bottom_glue = 0 method real_class = real_class_window method parent = raise Not_found method terminal = term method set_glue l r t b = if l < 0 || r < 0 || t < 0 || b < 0 || l + r > 100 || t + b > 100 then invalid_arg "Window#set_glue"; left_glue <- l; right_glue <- r; top_glue <- t; bottom_glue <- b method set_cursor ((x,y) as c) = child_window#set_center x y; super_toplevel#set_cursor (child_window#real_position c) method class_map w = super#class_map w; child_window <- w; let s = self#signal_get_size#emit (0,0) in child_size <- s method class_get_size t = match child with | None -> t | Some c -> c#signal_get_size#emit t method class_set_geometry g = super#class_set_geometry g; match child with | None -> () | Some c -> let (w, h) = child_size in let center g1 g2 ew iw = if iw > ew then (0, ew, iw) else let gt = g1 + g2 in let gc = 100 - gt in let rw = iw + gc * (ew - iw) / 100 in let rx = if gt = 0 then 0 else g1 * (ew - rw) / gt in (rx, rw, rw) in let (vx, vw, cw) = center left_glue right_glue geometry.Geom.w w and (vy, vh, ch) = center top_glue bottom_glue geometry.Geom.h h in let cs = w > geometry.Geom.w || h > geometry.Geom.h in let cg = if cs then ( if child_scroll then ( child_window#set_view vx vy vw vh; child_window#resize cw ch ) else ( let pad = Curses.newpad ch cw in child_window <- new TmkArea.pad pad cw ch; child_window#set_view vx vy vw vh; c#signal_map#emit child_window ); (0, 0, cw, ch) ) else ( if child_scroll then ( child_window#destroy (); child_window <- window_info; c#signal_map#emit child_window ); (vx, vy, cw, ch) ) in Geom.record cg child_geometry; c#signal_set_geometry#emit cg; child_scroll <- cs method class_draw () = Curses.wattrset child_window#window attribute; let y = child_geometry.Geom.y in for i = y to y + child_geometry.Geom.h - 1 do ignore (Curses.wmove child_window#window i child_geometry.Geom.x); Curses.whline child_window#window (32 lor attribute) child_geometry.Geom.w done; super#class_draw () initializer term#add_toplevel self#coerce; attributes.(0) <- Curses.A.standout; attribute <- Curses.A.standout end ocaml-curses-1.0.3/tmk/tmkTerminal.ml0000664000076400007640000001734407445615623017145 0ustar rjonesrjonesopen Curses open TmkStruct (*smkx, rmkx *) let key_list = [ Key.backspace, "kbs"; Key.home, "khome";Key.up, "kcuu1"; Key.seol, "kEOL"; Key.sexit, "kEXT"; Key.scopy, "kCPY"; Key.ctab, "kctab";Key.find, "kfnd"; Key.ssuspend, "kSPD"; Key.restart, "krst"; Key.close, "kclo"; Key.redo, "krdo"; Key.smove, "kMOV"; Key.ssave, "kSAV"; Key.npage, "knp"; Key.sundo, "kUND"; Key.a1, "ka1"; Key.a3, "ka3"; Key.sleft, "kLFT"; Key.b2, "kb2"; Key.c1, "kc1"; Key.c3, "kc3"; Key.smessage, "kMSG"; Key.help, "khlp"; Key.replace, "krpl"; Key.eic, "krmir";Key.stab, "khts"; Key.dc, "kdch1";Key.dl, "kdl1"; Key.beg, "kbeg"; Key.create, "kcrt"; Key.sfind, "kFND"; Key.command, "kcmd"; Key.resume, "kres"; Key.mouse, "kmous";Key.end_, "kend"; Key.open_, "kopn"; Key.btab, "kcbt"; Key.eol, "kel"; Key.eos, "ked"; Key.ic, "kich1";Key.il, "kil1"; Key.sredo, "kRDO"; Key.cancel, "kcan"; Key.sdc, "kDC"; Key.sdl, "kDL"; Key.right, "kcuf1";Key.ll, "kll"; Key.options, "kopt"; Key.sic, "kIC"; Key.sreplace, "kRPL"; Key.enter, "kent"; Key.shelp, "kHLP"; Key.shome, "kHOM"; Key.scommand, "kCMD"; Key.sf, "kind"; Key.sr, "kri"; Key.message, "kmsg"; Key.sright, "kRIT"; Key.down, "kcud1"; Key.catab, "ktbc"; Key.refresh, "krfr"; Key.sprevious, "kPRV"; Key.soptions, "kOPT"; Key.mark, "kmrk"; Key.next, "knxt"; Key.previous, "kprv"; Key.reference, "kref"; Key.select, "kslt"; Key.print, "kprt"; Key.exit, "kext"; Key.copy, "kcpy"; Key.ppage, "kpp"; Key.clear, "kclr"; Key.screate, "kCRT"; Key.srsume, "kRES"; Key.suspend, "kspd"; Key.snext, "kNXT"; Key.move, "kmov"; Key.save, "ksav"; Key.scancel, "kCAN"; Key.sprint, "kPRT"; Key.undo, "kund"; Key.sbeg, "kBEG"; Key.left, "kcub1";Key.send, "kEND"; ] @ (let rec f k l = if k < 0 then l else f (k - 1) ((Key.f k, "kf" ^ (string_of_int k)) :: l) in f 63 []) module KeyTree = struct type t = { mutable key: int; mutable subtree: (int, t) Hashtbl.t option; } let create () = { key = -1; subtree = None } let rec add_key tree key = function | [] -> tree.key <- key | h::t -> let s = match tree.subtree with | None -> let h = Hashtbl.create 17 in tree.subtree <- Some h; h | Some h -> h in let n = try Hashtbl.find s h with Not_found -> let n = create () in Hashtbl.add s h n; n in add_key n key t (* TODO: un mode avec temporisation *) let try_key tree key = let rec try_key_aux best tree seq = let sb = if tree.key = -1 then best else (tree.key, seq) in match tree.subtree with | None -> sb | Some ht -> match seq with | [] -> (-1, key) | h::t -> let sto = try Some (Hashtbl.find ht h) with Not_found -> None in match sto with | None -> sb | Some st -> try_key_aux sb st t in match key with | [] -> (-1, []) | h::t -> try_key_aux (h,t) tree key end let get_terminfo_string s = try Some (tigetstr s) with Failure _ -> None let int_list_of_string s = let rec aux a = function | -1 -> a | n -> aux ((int_of_char s.[n]) :: a) (n - 1) in aux [] (String.length s - 1) let construire_arbre_terminfo r = List.iter (fun (x,y) -> match get_terminfo_string y with | Some t -> KeyTree.add_key r x (int_list_of_string t); if t.[0] = '\027' && t.[1] = 'O' then ( t.[1] <- '['; KeyTree.add_key r x (int_list_of_string t) ) | None -> ()) key_list let variables v = if v = "" then "" else if v.[0] = '$' then try Sys.getenv (String.sub v 1 (pred (String.length v))) with Not_found -> "" else "" (**************************************************************************** * The terminal class ****************************************************************************) class virtual ['a] terminal = object (self) val keytree = KeyTree.create () val mutable key_spool = [] val mutable toplevels = [] val event_queue = Queue.create () val mutable cursor = (0, 0) val simplified_configuration = Cache.create (fun () -> TmkStyle.S.simplify_configuration (fun v -> Some (variables v)) None !TmkStyle.S.config_tree) method virtual activate : unit -> unit method virtual exit : unit -> unit method virtual main_window : TmkArea.window method virtual resource : TmkStyle.R.t method virtual get_size : unit -> int * int method virtual acs : Curses.Acs.acs method event_queue = event_queue val mutable resize_queued = false method queue_resize () = if not resize_queued then ( resize_queued <- true; Queue.add self#resize_toplevels event_queue ) method resize_toplevels () = let (h, w) = self#get_size () in ignore (Curses.wclear self#main_window#window); let send t = t#signal_set_geometry#emit (0, 0, w, h) in Queue.add (fun () -> List.iter send (List.rev toplevels)) event_queue; resize_queued <- false method read_key () = let rec all_keys a = match getch () with | -1 -> List.rev a | k -> all_keys (k::a) in let k = all_keys [] in key_spool <- key_spool @ k; let (t,r) = KeyTree.try_key keytree key_spool in key_spool <- r; if t = Curses.Key.resize then ( self#resize_toplevels (); self#read_key () ) else t method private activate_last_toplevel () = match toplevels with | [] -> () | t::_ -> Queue.add (fun () -> t#signal_toplevel_event#emit Toplevel.Activate) event_queue method add_toplevel (t : 'a) = toplevels <- t :: toplevels; Queue.add (fun () -> t#signal_map#emit self#main_window) event_queue; self#queue_resize (); self#activate_last_toplevel () method remove_toplevel () = match toplevels with | [] -> failwith "no toplevel to remove" | h::t -> toplevels <- t; self#queue_resize (); self#activate_last_toplevel () method current_toplevel () = List.hd toplevels method get_cursor () = cursor method set_cursor c = cursor <- c method configuration () = Cache.get simplified_configuration end class ['a] terminal_unique = object inherit ['a] terminal val main_window = let t = Curses.initscr () in if t = Curses.null_window then failwith "screen initialisation"; ignore (cbreak ()); ignore (noecho ()); new TmkArea.toplevel t val acs = Curses.get_acs_codes () method acs = acs method main_window = main_window method activate () = () method exit () = Curses.endwin () val resource = TmkStyle.R.create () method resource = resource method get_size () = let (h,w) as s = Curses.get_size () in ignore (Curses.resizeterm h w); s initializer let w = main_window#window in if not (Curses.raw ()) then failwith "raw mode"; if not (Curses.noecho ()) then failwith "echo mode"; if not (Curses.nodelay w true) then failwith "no delay mode"; Curses.winch_handler_on (); construire_arbre_terminfo keytree end class ['a] terminal_from_fd fdout fdin = let screen = Curses.newterm "xterm" fdin fdout in object inherit ['a] terminal val main_window = let t = Curses.stdscr () in if t = Curses.null_window then failwith "screen initialisation"; new TmkArea.toplevel t val acs = Curses.get_acs_codes () method acs = acs method main_window = main_window method activate () = ignore (Curses.set_term screen) method exit () = Curses.endwin () val resource = TmkStyle.R.create () method resource = resource method get_size () = let (h,w) as s = Curses.get_size_fd fdin in prerr_endline (Printf.sprintf "%dx%d" w h); ignore (Curses.resizeterm h w); s initializer let w = main_window#window in if not (Curses.raw ()) then failwith "raw mode"; if not (Curses.noecho ()) then failwith "echo mode"; if not (Curses.nodelay w true) then failwith "no delay mode"; Curses.winch_handler_on (); construire_arbre_terminfo keytree end ocaml-curses-1.0.3/tmk/tmkEntry.ml0000664000076400007640000000622207445615623016464 0ustar rjonesrjonesopen TmkStruct (**************************************************************************************** * La classe Entry ****************************************************************************************) let real_class_entry = Class.create "Entry" [TmkWidget.real_class_widget] class entry parent = object (self) inherit TmkWidget.widget as super val terminal = parent#terminal val mutable text = String.create 128 val mutable text_length = 0 val mutable text_offset = 0 val mutable cursor = 0 val mutable accept_key = function _ -> true method real_class = real_class_entry method parent = parent method terminal = terminal method can_focus = true method class_get_size _ = (2, 1) method class_draw () = super#class_draw (); Curses.wattrset window attribute; ignore (Curses.wmove window geometry.Geom.y geometry.Geom.x); Curses.whline window 32 geometry.Geom.w; ignore (Curses.waddnstr window text text_offset (min (text_length - text_offset) geometry.Geom.w)); if self#has_focus then self#set_cursor (geometry.Geom.x + cursor - text_offset, geometry.Geom.y) method cursor = cursor method move_cursor pos = let pos = min (max pos 0) text_length in cursor <- pos; if cursor < text_offset || cursor >= text_offset + geometry.Geom.w then ( text_offset <- max 0 (cursor - geometry.Geom.w / 2); self#queue_redraw () ); if self#has_focus then terminal#set_cursor (geometry.Geom.x + cursor - text_offset, geometry.Geom.y) method insert_string string = let len = String.length string in let lt = String.length text in if text_length + len > lt then ( let rec aux t = if t >= text_length + len then t - lt else aux (t * 2) in let t = aux (lt * 2) in text <- text ^ (String.create t) ); String.blit text cursor text (cursor + len) (text_length - cursor); String.blit string 0 text cursor len; text_length <- text_length + len; self#move_cursor (cursor + len); self#queue_redraw () method delete pos len = if pos < 0 || pos + len > text_length then invalid_arg "Entry#delete"; String.blit text (pos + len) text pos (text_length - pos - len); text_length <- text_length - len; if cursor > pos then self#move_cursor (max pos (cursor - len)); self#queue_redraw () method class_key_event key = if key >= 32 && key <= 126 || key >= 160 && key <= 255 then ( let char = char_of_int key in if accept_key char then let string = String.make 1 char in self#insert_string string else ignore (Curses.beep ()); true ) else if key = Curses.Key.right then ( self#move_cursor (succ cursor); true ) else if key = Curses.Key.left then ( self#move_cursor (pred cursor); true ) else if key = Curses.Key.backspace then ( if cursor > 0 then self#delete (pred cursor) 1; true ) else if key = Curses.Key.dc then ( if cursor < text_length then self#delete cursor 1; true ) else super#class_key_event key initializer parent#add self#coerce; String.blit "foobar" 0 text 0 6; text_length <- 6 end ocaml-curses-1.0.3/tmk/tmkStyle.ml0000664000076400007640000002017507445615623016466 0ustar rjonesrjonesmodule R = struct type t = { can_color: bool; mutable color_init: bool; mutable max_pairs: int; mutable num_pairs: int; mutable pairs: string } let create () = { can_color = Curses.has_colors (); color_init = false; max_pairs = 0; num_pairs = 1; pairs = "" } let can_color r = r.can_color let color_init r = assert r.can_color; if not r.color_init then ( ignore (Curses.start_color ()); r.color_init <- true; r.max_pairs <- min (max (Curses.color_pairs ()) 0) 256; r.pairs <- String.make r.max_pairs '\255' ) let color_pair_alloc r f b = if r.can_color then let () = color_init r in let i = f + b * 8 in let t = int_of_char r.pairs.[i] in if t < r.num_pairs then t else let t = r.num_pairs in let () = r.num_pairs <- succ t in let _ = Curses.init_pair t f b in let () = r.pairs.[i] <- char_of_int t in t else 0 let color_pair_query r p = try let c = String.index r.pairs (char_of_int p) in (c land 7, c lsl 3) with Not_found -> (0,0) end module P = struct type t = (bool * int list) array let star = '*' module CSet = Set.Make (struct type t = char let compare = compare end) let compile m = let l = String.length m in let rec transition at oe ne le fb = if ne + oe = l then (true, if fb = ne then [fb lsl 8] else []) :: at else let c = m.[ne + oe] in if m.[ne + oe] = star then transition at (succ oe) ne [ne] ne else let rec etat cc = function | [] -> if fb < 0 then [] else [fb lsl 8] | he::te -> let c = m.[he + oe] in if CSet.mem c cc then etat cc te else (((succ he) lsl 8) + (int_of_char c)) :: (etat (CSet.add c cc) te) in let rec etats = function | [] -> if fb < 0 then [] else [fb] | h::t -> let r = etats t in if m.[h + oe] = c then (succ h) :: r else r in let tr = etat CSet.empty le in transition ((false, tr) :: at) oe (succ ne) (etats le) fb in let tt = transition [] 0 0 [0] (-1) in let l = List.length tt in let r = Array.create l (false, []) in let rec fill i = function | [] -> () | h::t -> r.(i) <- h; fill (pred i) t in fill (pred l) tt; (r : t) let match_string (cp : t) t = let rec find c = function | [] -> raise Not_found | h::_ when h land 255 = c || h land 255 = 0 -> h lsr 8 | _::t -> find c t in let lt = String.length t in let rec aux e i = let (ete,etr) = cp.(e) in if i = lt then ete else let ne = find (int_of_char t.[i]) etr in aux ne (succ i) in try aux 0 0 with Not_found -> false end module S = struct type configuration = specification list and specification = | Def of string * string list option * value | Sub of condition * configuration and value = | Int of int | Str of string and condition = | And of condition * condition | Or of condition * condition | Not of condition | Term of term and term = | Var of string | Pat of P.t | Eq of string * string | Neq of string * string | Match of string * P.t let config_sources = ref [] let add_config_source s = config_sources := s :: !config_sources let config_tree = ref ([] : configuration) let process_config_sources () = let rec aux a = function | [] -> a | h::t -> let a = (h ()) @ a in aux a t in let t = aux [] (List.rev !config_sources) in config_tree := t let eval_bool_string s = (s <> "" ) && (try int_of_string s <> 0 with Failure "int_of_string" -> true) let check_condition var wid cond = let rec aux = function | And (c1, c2) -> (aux c1) && (aux c2) | Or (c1, c2) -> (aux c1) || (aux c2) | Not c -> not (aux c) | Term (Var v) -> eval_bool_string (var v) | Term (Pat p) -> P.match_string p wid | Term (Eq (v,s)) -> var v = s | Term (Neq (v,s)) -> var v <> s | Term (Match (v,p)) -> P.match_string p (var v) in aux cond let relevant_variables var wid cfg = let rec aux a = function | (Def (v,i,d)) :: t -> aux ((v,i,d) :: a) t | (Sub (c,s)) :: t -> let a = if check_condition var wid c then (aux [] s) @ a else a in aux a t | [] -> List.rev a in aux [] cfg type simplified_condition = | True | False | Cond of condition let simplify_condition var wid cond = let rec aux = function | And (c1, c2) -> (match aux c1 with | True -> aux c2 | False -> False | Cond c1 -> match aux c2 with | True -> Cond c1 | False -> False | Cond c2 -> Cond (And (c1, c2))) | Or (c1, c2) -> (match aux c1 with | False -> aux c2 | True -> True | Cond c1 -> match aux c2 with | False -> Cond c1 | True -> True | Cond c2 -> Cond (Or (c1, c2))) | Not c -> (match aux c with | False -> True | True -> False | c -> c) | Term (Var v) as t -> (match var v with | Some v -> if eval_bool_string v then True else False | None -> Cond t) | Term (Pat p) as t -> (match wid with | Some wid -> if P.match_string p wid then True else False | None -> Cond t) | Term (Eq (v,s)) as t -> (match var v with | Some v -> if v = s then True else False | None -> Cond t) | Term (Neq (v,s)) as t -> (match var v with | Some v -> if v <> s then True else False | None -> Cond t) | Term (Match (v,p)) as t -> (match var v with | Some v -> if P.match_string p v then True else False | None -> Cond t) in aux cond let simplify_configuration var wid cfg = let rec aux a = function | (Sub (c,s)) :: t -> (match simplify_condition var wid c with | True -> aux ((aux [] s) @ a) t | False -> aux a t | Cond c -> aux ((Sub (c, aux [] s)) :: a) t) | h::t -> aux (h::a) t | [] -> List.rev a in aux [] cfg end module C = struct let style_comm m c v = if c then v lor m else v land (lnot m) let style_u = style_comm Curses.A.underline let style_r = style_comm Curses.A.reverse let style_l = style_comm Curses.A.blink let style_g = style_comm Curses.A.bold let style_s = style_comm Curses.A.standout let style_color = function | 'r' -> Curses.Color.red | 'g' -> Curses.Color.green | 'y' -> Curses.Color.yellow | 'l' -> Curses.Color.blue | 'm' -> Curses.Color.magenta | 'c' -> Curses.Color.cyan | 'w' -> Curses.Color.white | _ -> Curses.Color.black let style_f c v = (v land (lnot 0x0F)) lor (style_color c) let style_b c v = (v land (lnot 0xF0)) lor ((style_color c) lsl 4) let encode r a = let f = a land Curses.A.attributes land (lnot Curses.A.color) and p = Curses.A.pair_number a in let (fg,bg) = R.color_pair_query r p in f lor (fg land 7) lor ((bg land 7) lsr 4) let decode r a = let f = a land 0x7FFFFF00 and fg = a land 0x07 and bg = (a land 0x70) lsr 4 in let p = R.color_pair_alloc r fg bg in f lor (Curses.A.color_pair p) let parse_style_string r a f = let a = encode r a in let l = String.length f in let rec aux v i = if i = l then v else let i = succ i in match f.[pred i] with | '<' -> aux a i | 'U' -> aux (style_u true v) i | 'u' -> aux (style_u false v) i | 'R' -> aux (style_r true v) i | 'r' -> aux (style_r false v) i | 'L' -> aux (style_l true v) i | 'l' -> aux (style_l false v) i | 'G' -> aux (style_g true v) i | 'g' -> aux (style_g false v) i | 'S' -> aux (style_s true v) i | 's' -> aux (style_s false v) i | 'F' when i < l -> aux (style_f f.[i] v) (succ i) | 'B' when i < l -> aux (style_b f.[i] v) (succ i) | _ -> aux v i in decode r (aux 0 0) let state_names s = let rec aux a = function | "normal"::t -> aux (0::a) t | "focus"::t -> aux (1::a) t | "selected"::t -> aux (2::a) t | "insensitive"::t -> aux (3::a) t | "all"::t -> [0;1;2;3] | _::t -> aux a t | [] -> a in aux [] s end ocaml-curses-1.0.3/tmk/tmkrc0000664000076400007640000000030107445615623015350 0ustar rjonesrjonesstyle[all]="FwBl" style[focus]=" v | None -> let v = f () in Weak.set t 0 (Some v); v let clear ((t,_) : _ t) = Weak.set t 0 None end module Once = struct type t = { mutable already: bool; queue: (unit -> unit) Queue.t; func: (unit -> unit) } let create q = { already = true; queue = q; func = ignore } let deliver o () = () let add o f = if not o.already then ( o.already <- true; Queue.add (deliver o) o.queue ) end ocaml-curses-1.0.3/tmk/tmkList.ml0000664000076400007640000002255207445615623016302 0ustar rjonesrjonesopen TmkStruct (**************************************************************************************** * La classe List ****************************************************************************************) let real_class_list = Class.create "List" [TmkWidget.real_class_widget] type column_width = { mutable min: int; mutable elasticity: int; mutable left_margin: int; mutable right_margin: int; mutable alignment: int; mutable width: int; mutable x: int } let array_insert source target pos length init = let tl = Array.length target and sl = Array.length source in let target = if length + sl <= tl then target else let rec enough t = if t >= length + sl then t else enough (t * 2) in let t = enough (tl * 2) in Array.append target (Array.create (t - tl) init) in Array.blit target pos target (pos + sl) (length - pos); Array.blit source 0 target pos sl; target class list parent columns = object (self) inherit TmkWidget.widget as super val terminal = parent#terminal val widths = Array.init columns (fun _ -> { min = 1; elasticity = 1; left_margin = 0; right_margin = 0; alignment = 0; width = 0; x = 0 }) val mutable total_fixed_width = columns val mutable total_elasticity = columns val mutable lines = Array.create 32 [||] val mutable selection = Array.create 32 false val mutable num_lines = 0 val mutable current_line = -1 val mutable top_line = 0 val mutable scroll_step = 1 val mutable multi_selection = false method real_class = real_class_list method parent = parent method terminal = terminal method can_focus = true method set_multi_selection = function | true -> multi_selection <- true | false -> multi_selection <- true; Array.fill selection 0 (Array.length selection) false; if current_line >= 0 then selection.(current_line) <- true; self#queue_redraw () method set_column ~col ~min ~expand ~left ~right ~align = let width = widths.(col) in total_fixed_width <- total_fixed_width + min + left + right - width.min - width.left_margin - width.right_margin; total_elasticity <- total_elasticity + expand - width.elasticity; width.min <- min; width.elasticity <- expand; width.left_margin <- left; width.right_margin <- right; width.alignment <- align; self#recompute_widths (); self#queue_redraw () method recompute_widths () = let expanding = geometry.Geom.w - total_fixed_width in let rec column i elasticity rigid beam = let width = widths.(i) in let e = elasticity + width.elasticity in let b = expanding * e / total_elasticity in let r = width.min + width.left_margin + width.right_margin in width.width <- width.min + b - beam; width.x <- rigid + beam + width.left_margin; if i < pred columns then column (succ i) e (rigid + r) b in column 0 0 geometry.Geom.x 0 method insert_lines pos more_lines = let pos = if pos < 0 || pos > num_lines then num_lines else pos in let n = Array.length more_lines in for i = 0 to pred n do if Array.length more_lines.(i) < columns then invalid_arg "List#insert_lines: too few columns" done; lines <- array_insert more_lines lines pos num_lines [||]; let more_selection = Array.create n false in selection <- array_insert more_selection selection pos num_lines false; let new_current = if current_line < 0 then 0 else if current_line >= pos then current_line + n else current_line in num_lines <- num_lines + n; self#go_to_line new_current; self#queue_redraw () method append_lines more_lines = self#insert_lines num_lines more_lines method insert_line pos line = self#insert_lines pos [|line|] method append_line line = self#insert_lines num_lines [|line|] method set_variable name subscripts value = match (name, subscripts, value) with | ("scroll_step", None, TmkStyle.S.Int v) -> scroll_step <- v | _ -> super#set_variable name subscripts value method class_get_size _ = (total_fixed_width, 1) method class_set_geometry g = super#class_set_geometry g; self#recompute_widths (); self#realign () method draw_line line = let y = geometry.Geom.y + line - top_line in let line_state = State.set_focus state (State.has_focus state && line = current_line) in let line_state = State.set_selected line_state selection.(line) in let attribute = attributes.(State.to_int line_state) in Curses.wattrset window attribute; ignore (Curses.wmove window y geometry.Geom.x); Curses.whline window 32 geometry.Geom.w; if State.has_focus line_state then self#set_cursor (geometry.Geom.x, y); if line < num_lines then let line = lines.(line) in for i = 0 to pred columns do let string = line.(i) in let length = String.length string in let x_more = widths.(i).width - length in if x_more >= 0 then let x = widths.(i).x + widths.(i).alignment * x_more / 100 in ignore (Curses.mvwaddstr window y x string) else let o = widths.(i).alignment * (-x_more) / 100 in ignore (Curses.mvwaddnstr window y widths.(i).x string o widths.(i).width) done method class_draw () = super#class_draw (); for i = 0 to pred geometry.Geom.h do self#draw_line (top_line + i) done method realign () = if current_line < top_line || current_line >= top_line + geometry.Geom.h then ( top_line <- current_line - geometry.Geom.y / 2; top_line <- max 0 (min (num_lines - geometry.Geom.h) top_line); self#queue_redraw () ) method go_to_line l = let l = max (min l (pred num_lines)) 0 in let emit = l != current_line in let old = if current_line < 0 then l else current_line in current_line <- l; if not multi_selection then ( selection.(old) <- false; selection.(l) <- true ); if geometry.Geom.h > 0 then ( if l >= top_line && l < top_line + geometry.Geom.h then ( self#draw_line old; self#draw_line l ) else ( let t = l - old + top_line in let t = if t < top_line then min t (top_line - scroll_step) else max t (top_line + scroll_step) in let t = max 0 (min (num_lines - geometry.Geom.h) t) in top_line <- t; self#realign (); self#queue_redraw () ) ); self#signal_move_to_line#emit l method set_select_line line value = if not multi_selection then failwith "List#select_line: illegal"; if selection.(line) != value then ( selection.(line) <- value; if value then self#signal_select_line#emit line else self#signal_deselect_line#emit line; self#draw_line line ) method select_line line = self#set_select_line line true method deselect_line line = self#set_select_line line false method current_line = current_line method selected line = selection.(line) method get_line line = lines.(line) method get_lines () = Array.sub lines 0 num_lines method set_line line value = if Array.length value < columns then invalid_arg "List#set_line: too few columns"; lines.(line) <- value; self#draw_line line method delete_lines start num = let stop = start + num in if start < 0 || num <= 0 || stop > num_lines then invalid_arg "List#delete_lines"; Array.blit lines stop lines start (num_lines - stop); Array.blit selection stop selection start (num_lines - stop); num_lines <- num_lines - num; Array.fill lines num_lines num [||]; Array.fill selection num_lines num false; (* TODO: réduire les tableaux *) if current_line >= start then ( let new_line = if current_line >= stop then current_line - num else start in self#realign () ); self#queue_redraw () method class_got_focus () = super#class_got_focus (); self#set_cursor (geometry.Geom.x, geometry.Geom.y + (max current_line 0)) method class_key_event key = if key = 32 || key = 10 && multi_selection && current_line >= 0 then ( self#set_select_line current_line (not selection.(current_line)); true ) else let keys = [ Curses.Key.up, current_line - 1; Curses.Key.down, current_line + 1; Curses.Key.ppage, current_line - geometry.Geom.h; Curses.Key.npage, current_line + geometry.Geom.h; Curses.Key.home, 0; Curses.Key.end_, pred num_lines ] in try let l = List.assoc key keys in if current_line >= 0 then self#go_to_line l; true with Not_found -> super#class_key_event key val signal_select_line = new TmkSignal.signal "select_line" TmkSignal.Marshall.all_unit val signal_deselect_line = new TmkSignal.signal "deselect_line" TmkSignal.Marshall.all_unit val signal_move_to_line = new TmkSignal.signal "move_to_line" TmkSignal.Marshall.all_unit method signal_select_line = signal_select_line method signal_deselect_line = signal_deselect_line method signal_move_to_line = signal_move_to_line method class_select_line line = () method class_deselect_line line = () method class_move_to_line line = () initializer if columns < 1 then invalid_arg "List: too few columns"; self#signal_select_line#connect 101 (fun l -> self#class_select_line l); self#signal_deselect_line#connect 101 (fun l -> self#class_deselect_line l); self#signal_move_to_line#connect 101 (fun l -> self#class_move_to_line l); parent#add self#coerce end ocaml-curses-1.0.3/tmk/tmkWidget.ml0000664000076400007640000002054707445615623016614 0ustar rjonesrjonesopen TmkStruct exception Not_container exception Not_toplevel let rec find_next_widget prop prev cur d = let filtrer_direction = match d with | Direction.Previous | Direction.Left | Direction.Up -> List.rev | Direction.Next | Direction.Right | Direction.Down -> (fun x -> x) in let rec find_next_widget_list = function | [] -> None | h::t -> if prop h then Some h else let c = try h#children () with Not_container -> [] in let c = filtrer_direction c in match find_next_widget_list c with | (Some _) as r -> r | None -> find_next_widget_list t in if prop cur then Some cur else let c = filtrer_direction (cur#children ()) in let rec split_list l = function | h::t when h == prev -> (List.rev (h::l), t) | h::t -> split_list (h::l) t | [] -> assert false in let (l,r) = split_list [] c in match find_next_widget_list r with | (Some _) as r -> r | None -> let r = try find_next_widget prop cur cur#parent d with Not_found -> None in match r with | Some _ -> r | None -> find_next_widget_list l (**************************************************************************************** * La classe Widget ****************************************************************************************) let real_class_widget = Class.create "Widget" [] class virtual widget = object (self) val mutable window = Curses.null_window val mutable window_info = TmkArea.null_window val geometry = Geom.null () val mutable state = State.normal val attributes = Array.create (succ State.to_int_max) Curses.A.normal val mutable attribute = Curses.A.normal val mutable name = "" val mutable need_redraw = false val mutable configured = false method virtual real_class : Class.t method virtual parent : widget method virtual terminal : widget TmkTerminal.terminal method can_focus = false method has_focus = State.has_focus state (* Gasp, I don't know how to write that type safely _and_ without writing all the type. *) method coerce = (Obj.magic self : widget) method set_name n = let p = if n = "" then "" else "." ^ n in let q = try (self#parent#name) ^ p with Not_found -> n in name <- q; if n <> "" then self#do_configuration () method name = name method queue_redraw () = if not need_redraw then ( need_redraw <- true; try self#parent#redraw_register self#coerce with Not_found -> Queue.add self#redraw_deliver self#terminal#event_queue ) method redraw_deliver () = if geometry.Geom.w > 0 && geometry.Geom.h > 0 then ( if need_redraw then self#signal_draw#emit (); need_redraw <- false ) method is_container = false method add (w : widget) = (raise Not_container : unit) method remove (w : widget) = (raise Not_container : unit) method children () = (raise Not_container : widget list) method redraw_register (w : widget) = (raise Not_container : unit) method set_variable name subscripts value = match (name, subscripts, value) with | ("style", Some s, TmkStyle.S.Str v) -> let res = self#terminal#resource in let fixer_style n = let v = TmkStyle.C.parse_style_string res attributes.(n) v in attributes.(n) <- v; if n = State.to_int state then attribute <- v in List.iter fixer_style (TmkStyle.C.state_names s) | _ -> prerr_endline ("Unknown variable or illegal use: " ^ name) method do_configuration () = configured <- true; let v = self#terminal#configuration () in let v = TmkStyle.S.relevant_variables (fun _ -> "") name v in let accept_var (n, s, v) = self#set_variable n s v in List.iter accept_var v method toplevel_pass (m : widget Toplevel.m) = self#parent#toplevel_pass m method set_cursor (c : int * int) = (self#parent#set_cursor c : unit) (* Signals *) val signal_map = new TmkSignal.signal "map" TmkSignal.Marshall.all_unit val signal_get_size = new TmkSignal.signal "get_size" TmkSignal.Marshall.filter val signal_set_geometry = new TmkSignal.signal "set_geometry" TmkSignal.Marshall.all_unit val signal_set_state = new TmkSignal.signal "set_state" TmkSignal.Marshall.all_unit val signal_draw = new TmkSignal.signal "draw" TmkSignal.Marshall.all_unit val signal_got_focus = new TmkSignal.signal "got_focus" TmkSignal.Marshall.all_unit val signal_lost_focus = new TmkSignal.signal "lost_focus" TmkSignal.Marshall.all_unit val signal_key_event = new TmkSignal.signal "key_event" TmkSignal.Marshall.until_true val signal_add_descendant = new TmkSignal.signal "add_descendant" TmkSignal.Marshall.all_unit val signal_remove_descendant = new TmkSignal.signal "remove_descendant" TmkSignal.Marshall.all_unit val signal_toplevel_event = new TmkSignal.signal "toplevel_event" TmkSignal.Marshall.all_unit method signal_map = signal_map method signal_get_size = signal_get_size method signal_set_geometry = signal_set_geometry method signal_set_state = signal_set_state method signal_draw = signal_draw method signal_got_focus = signal_got_focus method signal_lost_focus = signal_lost_focus method signal_key_event = signal_key_event method signal_add_descendant = signal_add_descendant method signal_remove_descendant = signal_remove_descendant method signal_toplevel_event = signal_toplevel_event method class_map w = window_info <- w; window <- w#window; if not configured then self#do_configuration () method virtual class_get_size : int * int -> int * int method class_set_geometry g = Geom.record g geometry; self#queue_redraw () method class_set_state s = state <- s; let n = attributes.(State.to_int s) in if n <> attribute then ( attribute <- n; self#queue_redraw () ) method class_draw () = need_redraw <- false method class_got_focus () = assert self#can_focus; self#signal_set_state#emit (State.set_focus state true) method class_lost_focus () = assert self#can_focus; self#signal_set_state#emit (State.set_focus state false) method class_key_event k = let aux d = let w = match find_next_widget (fun w -> w#can_focus) self#coerce (self#parent) d with | None -> assert false | Some w -> w in let () = self#toplevel_pass (Toplevel.Give_focus w) in true in if k = Curses.Key.up then aux Direction.Up else if k = Curses.Key.down then aux Direction.Down else if k = Curses.Key.left then aux Direction.Left else if k = Curses.Key.right then aux Direction.Right else if k = 9 then aux Direction.Next else try self#parent#signal_key_event#emit k with Not_found -> false method class_add_descendant (w : widget) = () method class_remove_descendant (w : widget) = () method class_toplevel_event (e : Toplevel.t) = raise Not_toplevel initializer let p = TmkStyle.R.color_pair_alloc self#terminal#resource 1 4 in attributes.(1) <- (Curses.A.color_pair p) lor Curses.A.bold; self#set_name ""; self#signal_map#connect 101 (fun w -> self#class_map w); self#signal_get_size#connect 101 (fun t -> self#class_get_size t); self#signal_set_geometry#connect 101 (fun g -> self#class_set_geometry g); self#signal_set_state#connect 101 (fun s -> self#class_set_state s); self#signal_draw#connect 101 (fun () -> self#class_draw ()); self#signal_got_focus#connect 101 (fun () -> self#class_got_focus ()); self#signal_lost_focus#connect 101 (fun () -> self#class_lost_focus ()); self#signal_key_event#connect (-1) (fun k -> self#class_key_event k); self#signal_add_descendant#connect 101 (fun w -> self#class_add_descendant w); self#signal_remove_descendant#connect 101 (fun w -> self#class_remove_descendant w); self#signal_toplevel_event#connect 101 (fun e -> self#class_toplevel_event e) end let warning w t = prerr_string w#name; prerr_string ": "; prerr_endline t let rec full_tree_do_post f (w : widget) = if w#is_container then List.iter (full_tree_do_post f) (w#children ()); f w let rec find_first_focusable ex (w : widget) = if w#can_focus then ( if w == ex then None else Some w ) else if w#is_container then let rec aux = function | [] -> None | h::t -> match find_first_focusable ex h with | None -> aux t | s -> s in aux (w#children ()) else None type terminal = widget TmkTerminal.terminal ocaml-curses-1.0.3/tmk/Makefile0000664000076400007640000000323310664754600015750 0ustar rjonesrjonesOCAMLC=ocamlc.opt OCFLAGS=-I .. -g OBJECTS=tmkStruct.cmo tmkArea.cmo tmkStyle.cmo tmkStyle_p.cmo tmkStyle_l.cmo \ tmkSignal.cmo tmkTerminal.cmo tmkMain.cmo \ tmkWidget.cmo tmkContainer.cmo tmkPacking.cmo \ tmkMisc.cmo tmkButton.cmo tmkList.cmo tmkEntry.cmo tmkFrame.cmo %.cmi: %.mli $(OCAMLC) $(OCFLAGS) -c $< %.cmo %.cmi: %.ml $(OCAMLC) $(OCFLAGS) -w m -c $< tmk.cma: $(OBJECTS) $(OCAMLC) -a -o $@ $^ tmkSignal.cmo tmkSignal.cmi: tmkStruct.cmo tmkStruct.cmi: tmkArea.cmo tmkArea.cmi: tmkStyle.cmo tmkStyle.cmi: tmkMain.cmo tmkMain.cmi: tmkTerminal.cmi tmkWidget.cmi tmkStyle.cmi tmkStyle_l.cmi tmkStyle_p.cmi tmkTerminal.cmo tmkTerminal.cmi: tmkStruct.cmi tmkArea.cmi tmkStyle.cmi tmkWidget.cmo tmkWidget.cmi: tmkSignal.cmi tmkStruct.cmi tmkArea.cmi tmkStyle.cmi tmkTerminal.cmi tmkContainer.cmo tmkContainer.cmi: tmkStruct.cmi tmkArea.cmi tmkWidget.cmi tmkButton.cmo tmkButton.cmi: tmkContainer.cmi tmkStruct.cmi tmkPacking.cmo tmkPacking.cmi: tmkContainer.cmi tmkStruct.cmi tmkMisc.cmo tmkMisc.cmi: tmkStruct.cmi tmkWidget.cmi tmkList.cmo tmkList.cmi: tmkWidget.cmi tmkStruct.cmi tmkEntry.cmo tmkEntry.cmi: tmkWidget.cmi tmkStruct.cmi tmkFrame.cmo tmkFrame.cmi: tmkContainer.cmi tmkStruct.cmi tmkStyle_p.ml tmkStyle_p.mli: tmkStyle_p.mly ocamlyacc tmkStyle_p.mly tmkStyle_l.ml: tmkStyle_l.mll ocamllex tmkStyle_l.mll tmkStyle_p.cmo: tmkStyle_p.ml tmkStyle_p.cmi tmkStyle_p.cmi: tmkStyle_p.mli tmkStyle.cmi tmkStyle_l.cmo tmkStyle_l.cmi: tmkStyle_l.ml tmkStyle_p.cmi tmkStyle.cmi test: test.ml $(INTERFACES) tmk.cma $(OCAMLC) -g -o test -I .. ../mlcurses.cma -custom \ tmk.cma unix.cma test.ml clean: rm -f *.cmo *.cmi *.cma tmkStyle_p.ml tmkStyle_p.mli tmkStyle_l.ml ocaml-curses-1.0.3/tmk/README.tmk0000664000076400007640000000010110660051720015736 0ustar rjonesrjonesNote that the contents of this directory (tmk/) are unmaintained.ocaml-curses-1.0.3/tmk/test.ml0000664000076400007640000000657407445615623015640 0ustar rjonesrjones(*let t = TmkMain.init ()*) (*let fdi = Unix.openfile "/dev/ttyr0" [Unix.O_RDONLY] 0 and fdo = Unix.openfile "/dev/ttyr0" [Unix.O_WRONLY] 0 let () = TmkMain.init_raw () let t = new TmkTerminal.terminal_from_fd fdi fdo let () = TmkMain.add_terminal t*) (*let t = TmkMain.init ()*) let init term = if term = "" then let t = TmkMain.init () in t else let fdi = Unix.openfile term [Unix.O_RDONLY] 0 and fdo = Unix.openfile term [Unix.O_WRONLY] 0 in TmkMain.init_raw (); let t = new TmkTerminal.terminal_from_fd fdi fdo in TmkMain.add_terminal t; t let create_dialog term text buttons = let w = new TmkContainer.window term in w#set_glue 50 50 40 60; w#set_name "window"; let f = new TmkFrame.frame (w :> TmkContainer.container) "" in f#set_name "frame"; let v = new TmkPacking.vbox f in let aux t = let l = new TmkMisc.label (v :> TmkContainer.container) t in l#set_align 0 0 in List.iter aux text; let r = new TmkFrame.rule (v :> TmkContainer.container) `Horizontal in let h = new TmkPacking.hbox (v :> TmkContainer.container) in let aux t = h#add_glue 1 1; let b = new TmkButton.button (h :> TmkContainer.container) in let l = new TmkMisc.label (b :> TmkContainer.container) t in b#set_name "bouton"; l#set_name "label"; b in let b = List.map aux buttons in let callback () = term#remove_toplevel () in List.iter (fun b -> b#signal_activate#connect 0 callback) b; h#add_glue 1 1; w let create_sample_screen t = let w = new TmkContainer.window t in w#set_name "top"; let v = new TmkPacking.vbox (w :> TmkContainer.container) in v#set_name "box"; let entry = new TmkEntry.entry (v :> TmkContainer.container) in entry#set_name "entry"; for i = 1 to 3 do let t = Printf.sprintf "Label n°%d" i in let b = new TmkButton.button (v :> TmkContainer.container) in b#set_name (Printf.sprintf "l%d" i); let l = new TmkMisc.label (b :> TmkContainer.container) t in l#set_name "label"; v#add_glue 0 2; b#signal_activate#connect 0 (fun () -> prerr_endline t) done; let list = new TmkList.list (v :> TmkContainer.container) 2 in v#set_child_expand (list : #TmkWidget.widget :> TmkWidget.widget) 10; list#set_name "liste"; list#set_multi_selection true; let f l = [| Printf.sprintf "Ligne %d" l; Printf.sprintf "Inverse %d" (1000000 / (succ l))|] in list#insert_lines 0 (Array.init 100 f); list#set_column ~col:0 ~min:1 ~expand:2 ~left:1 ~right:1 ~align:100; list#signal_select_line#connect 0 (fun l -> prerr_endline (string_of_int l); list#delete_lines l 3); let h = new TmkPacking.hbox (v :> TmkContainer.container) in h#set_name "hbox"; v#add_glue 0 4; h#add_glue 0 1; let rec aux i g = let t = Printf.sprintf "Bouton %d" i in let b = new TmkButton.radio_button (h :> TmkContainer.container) g in b#set_name (Printf.sprintf "b%d" i); let l = new TmkMisc.label (b :> TmkContainer.container) t in l#set_name "label"; h#add_glue 0 1; if i < 3 then aux (succ i) (Some b#group) in aux 1 None let main () = let tty = if Array.length Sys.argv < 2 then "" else Sys.argv.(1) in let term = init tty in create_sample_screen term; let dialog = create_dialog term ["This is a simple question to test the dialog."; "With two lines of text."] ["Ok"; "Cancel"; "Help"] in TmkMain.run (); TmkMain.exit () let () = main () ocaml-curses-1.0.3/tmk/tmkButton.ml0000664000076400007640000001214007445615623016632 0ustar rjonesrjonesopen TmkStruct (**************************************************************************************** * La classe Button ****************************************************************************************) let real_class_button = Class.create "Button" [TmkContainer.real_class_bin] class button parent = object (self) inherit TmkContainer.bin as super val terminal = parent#terminal val mutable left_margin = 1 val mutable right_margin = 1 val mutable draw_sides = true val mutable left_side = 60 val mutable right_side = 62 method real_class = real_class_button method parent = parent method terminal = terminal method can_focus = true method activate () = self#signal_activate#emit () val signal_activate = new TmkSignal.signal "activate" TmkSignal.Marshall.all_unit method signal_activate = signal_activate method class_get_size t = let (w,h) = match child with | None -> (0,0) | Some w -> w#signal_get_size#emit (0,0) in (w + left_margin + right_margin, min h 1) method class_set_geometry g = super#class_set_geometry g; match child with | None -> () | Some w -> w#signal_set_geometry#emit (geometry.Geom.x + left_margin, geometry.Geom.y, geometry.Geom.w - left_margin - right_margin, geometry.Geom.h) method class_draw () = Curses.wattrset window attribute; for i = geometry.Geom.y to geometry.Geom.y + geometry.Geom.h - 1 do ignore (Curses.wmove window i geometry.Geom.x); Curses.whline window 32 geometry.Geom.w done; super#class_draw (); Curses.wattrset window attribute; if draw_sides then ( ignore (Curses.mvwaddch window geometry.Geom.y geometry.Geom.x left_side); ignore (Curses.mvwaddch window geometry.Geom.y (geometry.Geom.x + geometry.Geom.w - 1) right_side) ) method class_got_focus () = super#class_got_focus (); self#set_cursor (succ geometry.Geom.x, geometry.Geom.y) method class_key_event k = if k = 32 || k = 10 then let () = self#activate () in true else super#class_key_event k method class_activate () = () initializer self#signal_activate#connect 101 (fun () -> self#class_activate ()); parent#add self#coerce end (**************************************************************************************** * La classe ToggleButton ****************************************************************************************) let real_class_toggle_button = Class.create "ToggleButton" [real_class_button] class toggle_button parent = object (self) inherit button parent as super val mutable selected = false val mutable mark = 215 method real_class = real_class_toggle_button method selected = selected method set_selected value = let change = value <> selected in selected <- value; self#queue_redraw (); if change then self#signal_toggle#emit value method class_draw () = super#class_draw (); ignore (Curses.wmove window geometry.Geom.y geometry.Geom.x); ignore (Curses.waddch window left_side); ignore (Curses.waddch window (if selected then mark else 32)); ignore (Curses.waddch window right_side) method class_activate () = self#set_selected (not selected) val signal_toggle = new TmkSignal.signal "toggle" TmkSignal.Marshall.all_unit method signal_toggle = signal_toggle method class_toggle (value : bool) = () initializer left_margin <- 4; right_margin <- 0; left_side <- 91; right_side <- 93; draw_sides <- false; self#signal_toggle#connect 101 (fun v -> self#class_toggle v); end (**************************************************************************************** * La classe RadioButton ****************************************************************************************) let real_class_radio_button = Class.create "RadioButton" [real_class_toggle_button] module Radiogroup = struct type 'a t = { mutable current: 'a option; unset: 'a -> unit } let create unset = { current = None; unset = unset } let set group element = match group.current with | None -> group.current <- Some element | Some e when e == element -> () | Some e -> group.unset e; group.current <- Some element let is_empty group = group.current == None type has_set_selected = < set_selected : bool -> unit > let trivial_unset (element : has_set_selected) = element#set_selected false end class radio_button parent group = object (self) inherit toggle_button parent as super val group = match group with | None -> Radiogroup.create Radiogroup.trivial_unset | Some g -> g method real_class = real_class_radio_button method group = group method class_activate () = self#set_selected true method set_selected value = super#set_selected value; if value then Radiogroup.set group (self :> Radiogroup.has_set_selected) initializer left_side <- 40; right_side <- 41; mark <- 42; draw_sides <- false; self#signal_toggle#connect 101 (fun v -> self#class_toggle v); if Radiogroup.is_empty group then self#set_selected true end ocaml-curses-1.0.3/tmk/tmkStyle_p.mly0000664000076400007640000000246107445615623017174 0ustar rjonesrjones%{ open TmkStyle %} %token Equal Nequal Tilde %token LBracket RBracket %token LBrace RBrace %token LParen RParen %token Comma %token Ident %token Env %token Str %token Int %token And Or Not %token Eof %left Or %left And %nonassoc Not %start parse %type parse %% parse: specification_list Eof { List.rev $1 } ; specification_list: /* empty */ { [] } | specification_list specification { $2::$1 } ; specification: Ident subscript Equal rvalue { S.Def ($1, $2, $4) } | LParen condition RParen LBrace specification_list RBrace { S.Sub ($2, $5) } ; subscript: /* empty */ { None } | LBracket subscript_list RBracket { Some (List.rev $2) } ; subscript_list: Ident { [$1] } | subscript_list Comma Ident { $3::$1 } ; rvalue: Int { S.Int $1 } | Str { S.Str $1 } ; condition: condition And condition { S.And ($1, $3) } | condition Or condition { S.Or ($1, $3) } | Not condition { S.Not $2 } | LParen condition RParen { $2 } | term { S.Term $1 } ; term: Ident { S.Var $1 } | Str { S.Pat (P.compile $1) } | Ident Equal Str { S.Eq ($1, $3) } | Env Equal Str { S.Eq ($1, $3) } | Ident Nequal Str { S.Neq ($1, $3) } | Env Nequal Str { S.Neq ($1, $3) } | Ident Tilde Str { S.Match ($1, P.compile $3) } | Env Tilde Str { S.Match ($1, P.compile $3) } ; %% ocaml-curses-1.0.3/tmk/tmkSignal.ml0000664000076400007640000000157307445615623016604 0ustar rjonesrjonesclass ['a,'b] signal name filter = object (self) val mutable callbacks : (int * ('a -> 'b)) list = [] method emit : 'a -> 'b = function x -> filter x callbacks method connect p f = let rec connect_aux = function | [] -> [p, f] | (ph,_)::_ as q when ph < p -> (p,f)::q | h::t -> h::(connect_aux t) in callbacks <- connect_aux callbacks method disconnect f = let rec disconnect_aux = function | [] -> [] | (_,fh)::t as q when fh == f -> t | h::t -> h::(disconnect_aux t) in callbacks <- disconnect_aux callbacks end module Marshall = struct let rec all_unit a = function | (_,h)::t -> let () = h a in all_unit a t | [] -> () let rec filter a = function | (_,h)::t -> let a = h a in filter a t | [] -> a let rec until_true a = function | (_,h)::t -> (h a) && (until_true a t) | [] -> false end ocaml-curses-1.0.3/OCamlMakefile0000664000076400007640000007726510676424332016110 0ustar rjonesrjones########################################################################### # OCamlMakefile # Copyright (C) 1999-2007 Markus Mottl # # For updates see: # http://www.ocaml.info/home/ocaml_sources.html # ########################################################################### # Modified by damien for .glade.ml compilation # Set these variables to the names of the sources to be processed and # the result variable. Order matters during linkage! ifndef SOURCES SOURCES := foo.ml endif export SOURCES ifndef RES_CLIB_SUF RES_CLIB_SUF := _stubs endif export RES_CLIB_SUF ifndef RESULT RESULT := foo endif export RESULT := $(strip $(RESULT)) export LIB_PACK_NAME ifndef DOC_FILES DOC_FILES := $(filter %.mli, $(SOURCES)) endif export DOC_FILES FIRST_DOC_FILE := $(firstword $(DOC_FILES)) export BCSUFFIX export NCSUFFIX ifndef TOPSUFFIX TOPSUFFIX := .top endif export TOPSUFFIX # Eventually set include- and library-paths, libraries to link, # additional compilation-, link- and ocamlyacc-flags # Path- and library information needs not be written with "-I" and such... # Define THREADS if you need it, otherwise leave it unset (same for # USE_CAMLP4)! export THREADS export VMTHREADS export ANNOTATE export USE_CAMLP4 export INCDIRS export LIBDIRS export EXTLIBDIRS export RESULTDEPS export OCAML_DEFAULT_DIRS export LIBS export CLIBS export CFRAMEWORKS export OCAMLFLAGS export OCAMLNCFLAGS export OCAMLBCFLAGS export OCAMLLDFLAGS export OCAMLNLDFLAGS export OCAMLBLDFLAGS export OCAMLMKLIB_FLAGS ifndef OCAMLCPFLAGS OCAMLCPFLAGS := a endif export OCAMLCPFLAGS ifndef DOC_DIR DOC_DIR := doc endif export DOC_DIR export PPFLAGS export LFLAGS export YFLAGS export IDLFLAGS export OCAMLDOCFLAGS export OCAMLFIND_INSTFLAGS export DVIPSFLAGS export STATIC # Add a list of optional trash files that should be deleted by "make clean" export TRASH ECHO := echo ifdef REALLY_QUIET export REALLY_QUIET ECHO := true LFLAGS := $(LFLAGS) -q YFLAGS := $(YFLAGS) -q endif #################### variables depending on your OCaml-installation ifdef MINGW export MINGW WIN32 := 1 CFLAGS_WIN32 := -mno-cygwin endif ifdef MSVC export MSVC WIN32 := 1 ifndef STATIC CPPFLAGS_WIN32 := -DCAML_DLL endif CFLAGS_WIN32 += -nologo EXT_OBJ := obj EXT_LIB := lib ifeq ($(CC),gcc) # work around GNU Make default value ifdef THREADS CC := cl -MT else CC := cl endif endif ifeq ($(CXX),g++) # work around GNU Make default value CXX := $(CC) endif CFLAG_O := -Fo endif ifdef WIN32 EXT_CXX := cpp EXE := .exe endif ifndef EXT_OBJ EXT_OBJ := o endif ifndef EXT_LIB EXT_LIB := a endif ifndef EXT_CXX EXT_CXX := cc endif ifndef EXE EXE := # empty endif ifndef CFLAG_O CFLAG_O := -o # do not delete this comment (preserves trailing whitespace)! endif export CC export CXX export CFLAGS export CXXFLAGS export LDFLAGS export CPPFLAGS ifndef RPATH_FLAG ifdef ELF_RPATH_FLAG RPATH_FLAG := $(ELF_RPATH_FLAG) else RPATH_FLAG := -R endif endif export RPATH_FLAG ifndef MSVC ifndef PIC_CFLAGS PIC_CFLAGS := -fPIC endif ifndef PIC_CPPFLAGS PIC_CPPFLAGS := -DPIC endif endif export PIC_CFLAGS export PIC_CPPFLAGS BCRESULT := $(addsuffix $(BCSUFFIX), $(RESULT)) NCRESULT := $(addsuffix $(NCSUFFIX), $(RESULT)) TOPRESULT := $(addsuffix $(TOPSUFFIX), $(RESULT)) ifndef OCAMLFIND OCAMLFIND := ocamlfind endif export OCAMLFIND ifndef OCAMLC OCAMLC := ocamlc endif export OCAMLC ifndef OCAMLOPT OCAMLOPT := ocamlopt endif export OCAMLOPT ifndef OCAMLMKTOP OCAMLMKTOP := ocamlmktop endif export OCAMLMKTOP ifndef OCAMLCP OCAMLCP := ocamlcp endif export OCAMLCP ifndef OCAMLDEP OCAMLDEP := ocamldep endif export OCAMLDEP ifndef OCAMLLEX OCAMLLEX := ocamllex endif export OCAMLLEX ifndef OCAMLYACC OCAMLYACC := ocamlyacc endif export OCAMLYACC ifndef OCAMLMKLIB OCAMLMKLIB := ocamlmklib endif export OCAMLMKLIB ifndef OCAML_GLADECC OCAML_GLADECC := lablgladecc2 endif export OCAML_GLADECC ifndef OCAML_GLADECC_FLAGS OCAML_GLADECC_FLAGS := endif export OCAML_GLADECC_FLAGS ifndef CAMELEON_REPORT CAMELEON_REPORT := report endif export CAMELEON_REPORT ifndef CAMELEON_REPORT_FLAGS CAMELEON_REPORT_FLAGS := endif export CAMELEON_REPORT_FLAGS ifndef CAMELEON_ZOGGY CAMELEON_ZOGGY := camlp4o pa_zog.cma pr_o.cmo endif export CAMELEON_ZOGGY ifndef CAMELEON_ZOGGY_FLAGS CAMELEON_ZOGGY_FLAGS := endif export CAMELEON_ZOGGY_FLAGS ifndef OXRIDL OXRIDL := oxridl endif export OXRIDL ifndef CAMLIDL CAMLIDL := camlidl endif export CAMLIDL ifndef CAMLIDLDLL CAMLIDLDLL := camlidldll endif export CAMLIDLDLL ifndef NOIDLHEADER MAYBE_IDL_HEADER := -header endif export NOIDLHEADER export NO_CUSTOM ifndef CAMLP4 CAMLP4 := camlp4 endif export CAMLP4 ifndef REAL_OCAMLFIND ifdef PACKS ifndef CREATE_LIB ifdef THREADS PACKS += threads endif endif empty := space := $(empty) $(empty) comma := , ifdef PREDS PRE_OCAML_FIND_PREDICATES := $(subst $(space),$(comma),$(PREDS)) PRE_OCAML_FIND_PACKAGES := $(subst $(space),$(comma),$(PACKS)) OCAML_FIND_PREDICATES := -predicates $(PRE_OCAML_FIND_PREDICATES) # OCAML_DEP_PREDICATES := -syntax $(PRE_OCAML_FIND_PREDICATES) OCAML_FIND_PACKAGES := $(OCAML_FIND_PREDICATES) -package $(PRE_OCAML_FIND_PACKAGES) OCAML_DEP_PACKAGES := $(OCAML_DEP_PREDICATES) -package $(PRE_OCAML_FIND_PACKAGES) else OCAML_FIND_PACKAGES := -package $(subst $(space),$(comma),$(PACKS)) OCAML_DEP_PACKAGES := endif OCAML_FIND_LINKPKG := -linkpkg REAL_OCAMLFIND := $(OCAMLFIND) endif endif export OCAML_FIND_PACKAGES export OCAML_DEP_PACKAGES export OCAML_FIND_LINKPKG export REAL_OCAMLFIND ifndef OCAMLDOC OCAMLDOC := ocamldoc endif export OCAMLDOC ifndef LATEX LATEX := latex endif export LATEX ifndef DVIPS DVIPS := dvips endif export DVIPS ifndef PS2PDF PS2PDF := ps2pdf endif export PS2PDF ifndef OCAMLMAKEFILE OCAMLMAKEFILE := OCamlMakefile endif export OCAMLMAKEFILE ifndef OCAMLLIBPATH OCAMLLIBPATH := \ $(shell $(OCAMLC) 2>/dev/null -where || echo /usr/lib/ocaml) endif export OCAMLLIBPATH ifndef OCAML_LIB_INSTALL OCAML_LIB_INSTALL := $(OCAMLLIBPATH)/contrib endif export OCAML_LIB_INSTALL ########################################################################### #################### change following sections only if #################### you know what you are doing! # delete target files when a build command fails .PHONY: .DELETE_ON_ERROR .DELETE_ON_ERROR: # for pedants using "--warn-undefined-variables" export MAYBE_IDL export REAL_RESULT export CAMLIDLFLAGS export THREAD_FLAG export RES_CLIB export MAKEDLL export ANNOT_FLAG export C_OXRIDL export SUBPROJS export CFLAGS_WIN32 export CPPFLAGS_WIN32 INCFLAGS := SHELL := /bin/sh MLDEPDIR := ._d BCDIDIR := ._bcdi NCDIDIR := ._ncdi FILTER_EXTNS := %.mli %.ml %.mll %.mly %.idl %.oxridl %.c %.m %.$(EXT_CXX) %.rep %.zog %.glade FILTERED := $(filter $(FILTER_EXTNS), $(SOURCES)) SOURCE_DIRS := $(filter-out ./, $(sort $(dir $(FILTERED)))) FILTERED_REP := $(filter %.rep, $(FILTERED)) DEP_REP := $(FILTERED_REP:%.rep=$(MLDEPDIR)/%.d) AUTO_REP := $(FILTERED_REP:.rep=.ml) FILTERED_ZOG := $(filter %.zog, $(FILTERED)) DEP_ZOG := $(FILTERED_ZOG:%.zog=$(MLDEPDIR)/%.d) AUTO_ZOG := $(FILTERED_ZOG:.zog=.ml) FILTERED_GLADE := $(filter %.glade, $(FILTERED)) DEP_GLADE := $(FILTERED_GLADE:%.glade=$(MLDEPDIR)/%.d) AUTO_GLADE := $(FILTERED_GLADE:.glade=.ml) FILTERED_ML := $(filter %.ml, $(FILTERED)) DEP_ML := $(FILTERED_ML:%.ml=$(MLDEPDIR)/%.d) FILTERED_MLI := $(filter %.mli, $(FILTERED)) DEP_MLI := $(FILTERED_MLI:.mli=.di) FILTERED_MLL := $(filter %.mll, $(FILTERED)) DEP_MLL := $(FILTERED_MLL:%.mll=$(MLDEPDIR)/%.d) AUTO_MLL := $(FILTERED_MLL:.mll=.ml) FILTERED_MLY := $(filter %.mly, $(FILTERED)) DEP_MLY := $(FILTERED_MLY:%.mly=$(MLDEPDIR)/%.d) $(FILTERED_MLY:.mly=.di) AUTO_MLY := $(FILTERED_MLY:.mly=.mli) $(FILTERED_MLY:.mly=.ml) FILTERED_IDL := $(filter %.idl, $(FILTERED)) DEP_IDL := $(FILTERED_IDL:%.idl=$(MLDEPDIR)/%.d) $(FILTERED_IDL:.idl=.di) C_IDL := $(FILTERED_IDL:%.idl=%_stubs.c) ifndef NOIDLHEADER C_IDL += $(FILTERED_IDL:.idl=.h) endif OBJ_C_IDL := $(FILTERED_IDL:%.idl=%_stubs.$(EXT_OBJ)) AUTO_IDL := $(FILTERED_IDL:.idl=.mli) $(FILTERED_IDL:.idl=.ml) $(C_IDL) FILTERED_OXRIDL := $(filter %.oxridl, $(FILTERED)) DEP_OXRIDL := $(FILTERED_OXRIDL:%.oxridl=$(MLDEPDIR)/%.d) $(FILTERED_OXRIDL:.oxridl=.di) AUTO_OXRIDL := $(FILTERED_OXRIDL:.oxridl=.mli) $(FILTERED_OXRIDL:.oxridl=.ml) $(C_OXRIDL) FILTERED_C_CXX := $(filter %.c %.m %.$(EXT_CXX), $(FILTERED)) OBJ_C_CXX := $(FILTERED_C_CXX:.c=.$(EXT_OBJ)) OBJ_C_CXX := $(OBJ_C_CXX:.m=.$(EXT_OBJ)) OBJ_C_CXX := $(OBJ_C_CXX:.$(EXT_CXX)=.$(EXT_OBJ)) PRE_TARGETS += $(AUTO_MLL) $(AUTO_MLY) $(AUTO_IDL) $(AUTO_OXRIDL) $(AUTO_ZOG) $(AUTO_REP) $(AUTO_GLADE) ALL_DEPS := $(DEP_ML) $(DEP_MLI) $(DEP_MLL) $(DEP_MLY) $(DEP_IDL) $(DEP_OXRIDL) $(DEP_ZOG) $(DEP_REP) $(DEP_GLADE) MLDEPS := $(filter %.d, $(ALL_DEPS)) MLIDEPS := $(filter %.di, $(ALL_DEPS)) BCDEPIS := $(MLIDEPS:%.di=$(BCDIDIR)/%.di) NCDEPIS := $(MLIDEPS:%.di=$(NCDIDIR)/%.di) ALLML := $(filter %.mli %.ml %.mll %.mly %.idl %.oxridl %.rep %.zog %.glade, $(FILTERED)) IMPLO_INTF := $(ALLML:%.mli=%.mli.__) IMPLO_INTF := $(foreach file, $(IMPLO_INTF), \ $(basename $(file)).cmi $(basename $(file)).cmo) IMPLO_INTF := $(filter-out %.mli.cmo, $(IMPLO_INTF)) IMPLO_INTF := $(IMPLO_INTF:%.mli.cmi=%.cmi) IMPLX_INTF := $(IMPLO_INTF:.cmo=.cmx) INTF := $(filter %.cmi, $(IMPLO_INTF)) IMPL_CMO := $(filter %.cmo, $(IMPLO_INTF)) IMPL_CMX := $(IMPL_CMO:.cmo=.cmx) IMPL_ASM := $(IMPL_CMO:.cmo=.asm) IMPL_S := $(IMPL_CMO:.cmo=.s) OBJ_LINK := $(OBJ_C_IDL) $(OBJ_C_CXX) OBJ_FILES := $(IMPL_CMO:.cmo=.$(EXT_OBJ)) $(OBJ_LINK) EXECS := $(addsuffix $(EXE), \ $(sort $(TOPRESULT) $(BCRESULT) $(NCRESULT))) ifdef WIN32 EXECS += $(BCRESULT).dll $(NCRESULT).dll endif CLIB_BASE := $(RESULT)$(RES_CLIB_SUF) ifneq ($(strip $(OBJ_LINK)),) RES_CLIB := lib$(CLIB_BASE).$(EXT_LIB) endif ifdef WIN32 DLLSONAME := $(CLIB_BASE).dll else DLLSONAME := dll$(CLIB_BASE).so endif NONEXECS := $(INTF) $(IMPL_CMO) $(IMPL_CMX) $(IMPL_ASM) $(IMPL_S) \ $(OBJ_FILES) $(PRE_TARGETS) $(BCRESULT).cma $(NCRESULT).cmxa \ $(NCRESULT).$(EXT_LIB) $(BCRESULT).cmi $(BCRESULT).cmo \ $(NCRESULT).cmi $(NCRESULT).cmx $(NCRESULT).o \ $(RES_CLIB) $(IMPL_CMO:.cmo=.annot) \ $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo $(LIB_PACK_NAME).cmx $(LIB_PACK_NAME).o ifndef STATIC NONEXECS += $(DLLSONAME) endif ifndef LIBINSTALL_FILES LIBINSTALL_FILES := $(RESULT).mli $(RESULT).cmi $(RESULT).cma \ $(RESULT).cmxa $(RESULT).$(EXT_LIB) $(RES_CLIB) ifndef STATIC ifneq ($(strip $(OBJ_LINK)),) LIBINSTALL_FILES += $(DLLSONAME) endif endif endif export LIBINSTALL_FILES ifdef WIN32 # some extra stuff is created while linking DLLs NONEXECS += $(BCRESULT).$(EXT_LIB) $(BCRESULT).exp $(NCRESULT).exp $(CLIB_BASE).exp $(CLIB_BASE).lib endif TARGETS := $(EXECS) $(NONEXECS) # If there are IDL-files ifneq ($(strip $(FILTERED_IDL)),) MAYBE_IDL := -cclib -lcamlidl endif ifdef USE_CAMLP4 CAMLP4PATH := \ $(shell $(CAMLP4) -where 2>/dev/null || echo /usr/lib/camlp4) INCFLAGS := -I $(CAMLP4PATH) CINCFLAGS := -I$(CAMLP4PATH) endif DINCFLAGS := $(INCFLAGS) $(SOURCE_DIRS:%=-I %) $(OCAML_DEFAULT_DIRS:%=-I %) INCFLAGS := $(DINCFLAGS) $(INCDIRS:%=-I %) CINCFLAGS += $(SOURCE_DIRS:%=-I%) $(INCDIRS:%=-I%) $(OCAML_DEFAULT_DIRS:%=-I%) ifndef MSVC CLIBFLAGS += $(SOURCE_DIRS:%=-L%) $(LIBDIRS:%=-L%) \ $(EXTLIBDIRS:%=-L%) $(OCAML_DEFAULT_DIRS:%=-L%) ifeq ($(ELF_RPATH), yes) CLIBFLAGS += $(EXTLIBDIRS:%=-Wl,$(RPATH_FLAG)%) endif endif ifndef PROFILING INTF_OCAMLC := $(OCAMLC) else ifndef THREADS INTF_OCAMLC := $(OCAMLCP) -p $(OCAMLCPFLAGS) else # OCaml does not support profiling byte code # with threads (yet), therefore we force an error. ifndef REAL_OCAMLC $(error Profiling of multithreaded byte code not yet supported by OCaml) endif INTF_OCAMLC := $(OCAMLC) endif endif ifndef MSVC COMMON_LDFLAGS := $(LDFLAGS:%=-ccopt %) $(SOURCE_DIRS:%=-ccopt -L%) \ $(LIBDIRS:%=-ccopt -L%) $(EXTLIBDIRS:%=-ccopt -L%) \ $(EXTLIBDIRS:%=-ccopt -Wl $(OCAML_DEFAULT_DIRS:%=-ccopt -L%)) ifeq ($(ELF_RPATH),yes) COMMON_LDFLAGS += $(EXTLIBDIRS:%=-ccopt -Wl,$(RPATH_FLAG)%) endif else COMMON_LDFLAGS := -ccopt "/link -NODEFAULTLIB:LIBC $(LDFLAGS:%=%) $(SOURCE_DIRS:%=-LIBPATH:%) \ $(LIBDIRS:%=-LIBPATH:%) $(EXTLIBDIRS:%=-LIBPATH:%) \ $(OCAML_DEFAULT_DIRS:%=-LIBPATH:%) " endif CLIBS_OPTS := $(CLIBS:%=-cclib -l%) $(CFRAMEWORKS:%=-cclib '-framework %') ifdef MSVC ifndef STATIC # MSVC libraries do not have 'lib' prefix CLIBS_OPTS := $(CLIBS:%=-cclib %.lib) endif endif ifneq ($(strip $(OBJ_LINK)),) ifdef CREATE_LIB OBJS_LIBS := -cclib -l$(CLIB_BASE) $(CLIBS_OPTS) $(MAYBE_IDL) else OBJS_LIBS := $(OBJ_LINK) $(CLIBS_OPTS) $(MAYBE_IDL) endif else OBJS_LIBS := $(CLIBS_OPTS) $(MAYBE_IDL) endif # If we have to make byte-code ifndef REAL_OCAMLC BYTE_OCAML := y # EXTRADEPS is added dependencies we have to insert for all # executable files we generate. Ideally it should be all of the # libraries we use, but it's hard to find the ones that get searched on # the path since I don't know the paths built into the compiler, so # just include the ones with slashes in their names. EXTRADEPS := $(addsuffix .cma,$(foreach i,$(LIBS),$(if $(findstring /,$(i)),$(i)))) SPECIAL_OCAMLFLAGS := $(OCAMLBCFLAGS) REAL_OCAMLC := $(INTF_OCAMLC) REAL_IMPL := $(IMPL_CMO) REAL_IMPL_INTF := $(IMPLO_INTF) IMPL_SUF := .cmo DEPFLAGS := MAKE_DEPS := $(MLDEPS) $(BCDEPIS) ifdef CREATE_LIB override CFLAGS := $(PIC_CFLAGS) $(CFLAGS) override CPPFLAGS := $(PIC_CPPFLAGS) $(CPPFLAGS) ifndef STATIC ifneq ($(strip $(OBJ_LINK)),) MAKEDLL := $(DLLSONAME) ALL_LDFLAGS := -dllib $(DLLSONAME) endif endif endif ifndef NO_CUSTOM ifneq "$(strip $(OBJ_LINK) $(THREADS) $(MAYBE_IDL) $(CLIBS) $(CFRAMEWORKS))" "" ALL_LDFLAGS += -custom endif endif ALL_LDFLAGS += $(INCFLAGS) $(OCAMLLDFLAGS) $(OCAMLBLDFLAGS) \ $(COMMON_LDFLAGS) $(LIBS:%=%.cma) CAMLIDLDLLFLAGS := ifdef THREADS ifdef VMTHREADS THREAD_FLAG := -vmthread else THREAD_FLAG := -thread endif ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) ifndef CREATE_LIB ifndef REAL_OCAMLFIND ALL_LDFLAGS := unix.cma threads.cma $(ALL_LDFLAGS) endif endif endif # we have to make native-code else EXTRADEPS := $(addsuffix .cmxa,$(foreach i,$(LIBS),$(if $(findstring /,$(i)),$(i)))) ifndef PROFILING SPECIAL_OCAMLFLAGS := $(OCAMLNCFLAGS) PLDFLAGS := else SPECIAL_OCAMLFLAGS := -p $(OCAMLNCFLAGS) PLDFLAGS := -p endif REAL_IMPL := $(IMPL_CMX) REAL_IMPL_INTF := $(IMPLX_INTF) IMPL_SUF := .cmx override CPPFLAGS := -DNATIVE_CODE $(CPPFLAGS) DEPFLAGS := -native MAKE_DEPS := $(MLDEPS) $(NCDEPIS) ALL_LDFLAGS := $(PLDFLAGS) $(INCFLAGS) $(OCAMLLDFLAGS) \ $(OCAMLNLDFLAGS) $(COMMON_LDFLAGS) CAMLIDLDLLFLAGS := -opt ifndef CREATE_LIB ALL_LDFLAGS += $(LIBS:%=%.cmxa) else override CFLAGS := $(PIC_CFLAGS) $(CFLAGS) override CPPFLAGS := $(PIC_CPPFLAGS) $(CPPFLAGS) endif ifdef THREADS THREAD_FLAG := -thread ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) ifndef CREATE_LIB ifndef REAL_OCAMLFIND ALL_LDFLAGS := unix.cmxa threads.cmxa $(ALL_LDFLAGS) endif endif endif endif export MAKE_DEPS ifdef ANNOTATE ANNOT_FLAG := -dtypes else endif ALL_OCAMLCFLAGS := $(THREAD_FLAG) $(ANNOT_FLAG) $(OCAMLFLAGS) \ $(INCFLAGS) $(SPECIAL_OCAMLFLAGS) ifdef make_deps -include $(MAKE_DEPS) PRE_TARGETS := endif ########################################################################### # USER RULES # Call "OCamlMakefile QUIET=" to get rid of all of the @'s. QUIET=@ # generates byte-code (default) byte-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ REAL_RESULT="$(BCRESULT)" make_deps=yes bc: byte-code byte-code-nolink: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ REAL_RESULT="$(BCRESULT)" make_deps=yes bcnl: byte-code-nolink top: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(TOPRESULT) \ REAL_RESULT="$(BCRESULT)" make_deps=yes # generates native-code native-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ make_deps=yes nc: native-code native-code-nolink: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ make_deps=yes ncnl: native-code-nolink # generates byte-code libraries byte-code-library: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(BCRESULT).cma \ REAL_RESULT="$(BCRESULT)" \ CREATE_LIB=yes \ make_deps=yes bcl: byte-code-library # generates native-code libraries native-code-library: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(NCRESULT).cmxa \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ CREATE_LIB=yes \ make_deps=yes ncl: native-code-library ifdef WIN32 # generates byte-code dll byte-code-dll: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(BCRESULT).dll \ REAL_RESULT="$(BCRESULT)" \ make_deps=yes bcd: byte-code-dll # generates native-code dll native-code-dll: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(NCRESULT).dll \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ make_deps=yes ncd: native-code-dll endif # generates byte-code with debugging information debug-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ REAL_RESULT="$(BCRESULT)" make_deps=yes \ OCAMLFLAGS="-g $(OCAMLFLAGS)" \ OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" dc: debug-code debug-code-nolink: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ REAL_RESULT="$(BCRESULT)" make_deps=yes \ OCAMLFLAGS="-g $(OCAMLFLAGS)" \ OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" dcnl: debug-code-nolink # generates byte-code libraries with debugging information debug-code-library: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(BCRESULT).cma \ REAL_RESULT="$(BCRESULT)" make_deps=yes \ CREATE_LIB=yes \ OCAMLFLAGS="-g $(OCAMLFLAGS)" \ OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" dcl: debug-code-library # generates byte-code for profiling profiling-byte-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ REAL_RESULT="$(BCRESULT)" PROFILING="y" \ make_deps=yes pbc: profiling-byte-code # generates native-code profiling-native-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ PROFILING="y" \ make_deps=yes pnc: profiling-native-code # generates byte-code libraries profiling-byte-code-library: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(BCRESULT).cma \ REAL_RESULT="$(BCRESULT)" PROFILING="y" \ CREATE_LIB=yes \ make_deps=yes pbcl: profiling-byte-code-library # generates native-code libraries profiling-native-code-library: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(NCRESULT).cmxa \ REAL_RESULT="$(NCRESULT)" PROFILING="y" \ REAL_OCAMLC="$(OCAMLOPT)" \ CREATE_LIB=yes \ make_deps=yes pncl: profiling-native-code-library # packs byte-code objects pack-byte-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT).cmo \ REAL_RESULT="$(BCRESULT)" \ PACK_LIB=yes make_deps=yes pabc: pack-byte-code # packs native-code objects pack-native-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(NCRESULT).cmx $(NCRESULT).o \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ PACK_LIB=yes make_deps=yes panc: pack-native-code # generates HTML-documentation htdoc: $(DOC_DIR)/$(RESULT)/html/index.html # generates Latex-documentation ladoc: $(DOC_DIR)/$(RESULT)/latex/doc.tex # generates PostScript-documentation psdoc: $(DOC_DIR)/$(RESULT)/latex/doc.ps # generates PDF-documentation pdfdoc: $(DOC_DIR)/$(RESULT)/latex/doc.pdf # generates all supported forms of documentation doc: htdoc ladoc psdoc pdfdoc ########################################################################### # LOW LEVEL RULES $(REAL_RESULT): $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) $(RESULTDEPS) $(REAL_OCAMLFIND) $(REAL_OCAMLC) \ $(OCAML_FIND_PACKAGES) $(OCAML_FIND_LINKPKG) \ $(ALL_LDFLAGS) $(OBJS_LIBS) -o $@$(EXE) \ $(REAL_IMPL) nolink: $(REAL_IMPL_INTF) $(OBJ_LINK) ifdef WIN32 $(REAL_RESULT).dll: $(REAL_IMPL_INTF) $(OBJ_LINK) $(CAMLIDLDLL) $(CAMLIDLDLLFLAGS) $(OBJ_LINK) $(CLIBS) \ -o $@ $(REAL_IMPL) endif %$(TOPSUFFIX): $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) $(REAL_OCAMLFIND) $(OCAMLMKTOP) \ $(OCAML_FIND_PACKAGES) $(OCAML_FIND_LINKPKG) \ $(ALL_LDFLAGS) $(OBJS_LIBS) -o $@$(EXE) \ $(REAL_IMPL) .SUFFIXES: .mli .ml .cmi .cmo .cmx .cma .cmxa .$(EXT_OBJ) \ .mly .di .d .$(EXT_LIB) .idl %.oxridl .c .m .$(EXT_CXX) .h .so \ .rep .zog .glade ifndef STATIC ifdef MINGW $(DLLSONAME): $(OBJ_LINK) $(CC) $(CFLAGS) $(CFLAGS_WIN32) $(OBJ_LINK) -shared -o $@ \ -Wl,--whole-archive $(wildcard $(foreach dir,$(LIBDIRS),$(CLIBS:%=$(dir)/lib%.a))) \ $(OCAMLLIBPATH)/ocamlrun.a \ -Wl,--export-all-symbols \ -Wl,--no-whole-archive else ifdef MSVC $(DLLSONAME): $(OBJ_LINK) link /NOLOGO /DLL /OUT:$@ $(OBJ_LINK) \ $(wildcard $(foreach dir,$(LIBDIRS),$(CLIBS:%=$(dir)/%.lib))) \ $(OCAMLLIBPATH)/ocamlrun.lib else $(DLLSONAME): $(OBJ_LINK) $(OCAMLMKLIB) $(INCFLAGS) $(CLIBFLAGS) \ -o $(CLIB_BASE) $(OBJ_LINK) $(CLIBS:%=-l%) $(CFRAMEWORKS:%=-framework %) \ $(OCAMLMKLIB_FLAGS) endif endif endif ifndef LIB_PACK_NAME $(RESULT).cma: $(REAL_IMPL_INTF) $(MAKEDLL) $(EXTRADEPS) $(RESULTDEPS) $(REAL_OCAMLFIND) $(REAL_OCAMLC) -a $(ALL_LDFLAGS) $(OBJS_LIBS) -o $@ $(REAL_IMPL) $(RESULT).cmxa $(RESULT).$(EXT_LIB): $(REAL_IMPL_INTF) $(EXTRADEPS) $(RESULTDEPS) $(REAL_OCAMLFIND) $(OCAMLOPT) -a $(ALL_LDFLAGS) $(OBJS_LIBS) -o $@ $(REAL_IMPL) else ifdef BYTE_OCAML $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo: $(REAL_IMPL_INTF) $(REAL_OCAMLFIND) $(REAL_OCAMLC) -pack -o $(LIB_PACK_NAME).cmo $(OCAMLLDFLAGS) $(REAL_IMPL) else $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmx: $(REAL_IMPL_INTF) $(REAL_OCAMLFIND) $(REAL_OCAMLC) -pack -o $(LIB_PACK_NAME).cmx $(OCAMLLDFLAGS) $(REAL_IMPL) endif $(RESULT).cma: $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo $(MAKEDLL) $(EXTRADEPS) $(RESULTDEPS) $(REAL_OCAMLFIND) $(REAL_OCAMLC) -a $(ALL_LDFLAGS) $(OBJS_LIBS) -o $@ $(LIB_PACK_NAME).cmo $(RESULT).cmxa $(RESULT).$(EXT_LIB): $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmx $(EXTRADEPS) $(RESULTDEPS) $(REAL_OCAMLFIND) $(OCAMLOPT) -a $(ALL_LDFLAGS) $(OBJS_LIBS) -o $@ $(LIB_PACK_NAME).cmx endif $(RES_CLIB): $(OBJ_LINK) ifndef MSVC ifneq ($(strip $(OBJ_LINK)),) $(AR) rcs $@ $(OBJ_LINK) endif else ifneq ($(strip $(OBJ_LINK)),) lib -nologo -debugtype:cv -out:$(RES_CLIB) $(OBJ_LINK) endif endif .mli.cmi: $(EXTRADEPS) $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ if [ -z "$$pp" ]; then \ $(ECHO) $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c $(THREAD_FLAG) $(ANNOT_FLAG) \ $(OCAMLFLAGS) $(INCFLAGS) $<; \ $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c $(THREAD_FLAG) $(ANNOT_FLAG) \ $(OCAMLFLAGS) $(INCFLAGS) $<; \ else \ $(ECHO) $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c -pp \"$$pp $(PPFLAGS)\" $(THREAD_FLAG) $(ANNOT_FLAG) \ $(OCAMLFLAGS) $(INCFLAGS) $<; \ $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c -pp "$$pp $(PPFLAGS)" $(THREAD_FLAG) $(ANNOT_FLAG) \ $(OCAMLFLAGS) $(INCFLAGS) $<; \ fi .ml.cmi .ml.$(EXT_OBJ) .ml.cmx .ml.cmo: $(EXTRADEPS) $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ if [ -z "$$pp" ]; then \ $(ECHO) $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c $(ALL_OCAMLCFLAGS) $<; \ $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c $(ALL_OCAMLCFLAGS) $<; \ else \ $(ECHO) $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c -pp \"$$pp $(PPFLAGS)\" $(ALL_OCAMLCFLAGS) $<; \ $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c -pp "$$pp $(PPFLAGS)" $(ALL_OCAMLCFLAGS) $<; \ fi ifdef PACK_LIB $(REAL_RESULT).cmo $(REAL_RESULT).cmx $(REAL_RESULT).o: $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) $(REAL_OCAMLFIND) $(REAL_OCAMLC) -pack $(ALL_LDFLAGS) \ $(OBJS_LIBS) -o $@ $(REAL_IMPL) endif .PRECIOUS: %.ml %.ml: %.mll $(OCAMLLEX) $(LFLAGS) $< .PRECIOUS: %.ml %.mli %.ml %.mli: %.mly $(OCAMLYACC) $(YFLAGS) $< $(QUIET)pp=`sed -n -e 's/.*(\*pp \([^*]*\) \*).*/\1/p;q' $<`; \ if [ ! -z "$$pp" ]; then \ mv $*.ml $*.ml.temporary; \ echo "(*pp $$pp $(PPFLAGS)*)" > $*.ml; \ cat $*.ml.temporary >> $*.ml; \ rm $*.ml.temporary; \ mv $*.mli $*.mli.temporary; \ echo "(*pp $$pp $(PPFLAGS)*)" > $*.mli; \ cat $*.mli.temporary >> $*.mli; \ rm $*.mli.temporary; \ fi .PRECIOUS: %.ml %.ml: %.rep $(CAMELEON_REPORT) $(CAMELEON_REPORT_FLAGS) -gen $< .PRECIOUS: %.ml %.ml: %.zog $(CAMELEON_ZOGGY) $(CAMELEON_ZOGGY_FLAGS) -impl $< > $@ .PRECIOUS: %.ml %.ml: %.glade $(OCAML_GLADECC) $(OCAML_GLADECC_FLAGS) $< > $@ .PRECIOUS: %.ml %.mli %.ml %.mli: %.oxridl $(OXRIDL) $< .PRECIOUS: %.ml %.mli %_stubs.c %.h %.ml %.mli %_stubs.c %.h: %.idl $(CAMLIDL) $(MAYBE_IDL_HEADER) $(IDLFLAGS) \ $(CAMLIDLFLAGS) $< $(QUIET)if [ $(NOIDLHEADER) ]; then touch $*.h; fi .c.$(EXT_OBJ): $(OCAMLC) -c -cc "$(CC)" -ccopt "$(CFLAGS) \ $(CPPFLAGS) $(CPPFLAGS_WIN32) \ $(CFLAGS_WIN32) $(CINCFLAGS) $(CFLAG_O)$@ " $< .m.$(EXT_OBJ): $(CC) -c $(CFLAGS) $(CINCFLAGS) $(CPPFLAGS) \ -I'$(OCAMLLIBPATH)' \ $< $(CFLAG_O)$@ .$(EXT_CXX).$(EXT_OBJ): $(CXX) -c $(CXXFLAGS) $(CINCFLAGS) $(CPPFLAGS) \ -I'$(OCAMLLIBPATH)' \ $< $(CFLAG_O)$@ $(MLDEPDIR)/%.d: %.ml $(QUIET)if [ ! -d $(@D) ]; then mkdir -p $(@D); fi $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ if [ -z "$$pp" ]; then \ $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ $(DINCFLAGS) $< \> $@; \ $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ $(DINCFLAGS) $< > $@; \ else \ $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ -pp \"$$pp $(PPFLAGS)\" $(DINCFLAGS) $< \> $@; \ $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ -pp "$$pp $(PPFLAGS)" $(DINCFLAGS) $< > $@; \ fi $(BCDIDIR)/%.di $(NCDIDIR)/%.di: %.mli $(QUIET)if [ ! -d $(@D) ]; then mkdir -p $(@D); fi $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ if [ -z "$$pp" ]; then \ $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) $(DINCFLAGS) $< \> $@; \ $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) $(DINCFLAGS) $< > $@; \ else \ $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) \ -pp \"$$pp $(PPFLAGS)\" $(DINCFLAGS) $< \> $@; \ $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) \ -pp "$$pp $(PPFLAGS)" $(DINCFLAGS) $< > $@; \ fi $(DOC_DIR)/$(RESULT)/html: mkdir -p $@ $(DOC_DIR)/$(RESULT)/html/index.html: $(DOC_DIR)/$(RESULT)/html $(DOC_FILES) rm -rf $ #include #include #include #include #include #include /* For PDCurses we need to define the following so that global * variables are declared (in the header) with __dllspec(dllimport). */ #ifdef PDCURSES #define PDC_DLL_BUILD #undef CURSES_LIBRARY #endif #ifdef CURSES_HEADER #include CURSES_HEADER #else #include #endif #ifdef CURSES_TERM_H #include CURSES_TERM_H #else #include #endif #ifdef HAVE_WINDOWS_H #include #endif /* Du travail pour les esclaves de M$ */ #include #ifdef HAVE_TERMIOS_H #include #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #define AWB(x) caml__dummy_##x=caml__dummy_##x; /* anti-warning bugware */ #define r_unit(f) f; CAMLreturn(Val_unit); #define r_window(f) CAMLreturn((value)f) #define r_terminal(f) CAMLreturn((value)f) #define r_err(f) CAMLreturn(Val_bool((f)!=ERR)) #define r_int(f) CAMLreturn(Val_int(f)) #define r_char(f) CAMLreturn(Val_int((f)&255)) #define r_chtype(f) CAMLreturn(Val_int(f)) #define r_attr_t(f) CAMLreturn(Val_int(f)) #define r_bool(f) CAMLreturn(Val_bool(f)) #define r_int_int(x,y) \ { CAMLlocal1(ret); AWB(ret); \ ret=alloc_tuple(2); \ Store_field(ret,0,Val_int(x)); \ Store_field(ret,1,Val_int(y)); \ CAMLreturn(ret); } #define r_window_int(x,y) \ { CAMLlocal1(ret); AWB(ret); \ ret=alloc_tuple(2); \ Store_field(ret,0,(value)(x)); \ Store_field(ret,1,Val_int(y)); \ CAMLreturn(ret); } #define r_int_int_int(x,y,z) \ { CAMLlocal1(ret); AWB(ret); \ ret=alloc_tuple(3); \ Store_field(ret,0,Val_int(x)); \ Store_field(ret,1,Val_int(y)); \ Store_field(ret,2,Val_int(z)); \ CAMLreturn(ret); } #define r_string(f) \ { char *ret=f; \ if(ret==NULL) failwith("Null pointer"); \ CAMLreturn(copy_string(ret)); } #define a_window(a) ((WINDOW * )a) #define a_terminal(a) ((TERMINAL * )a) #define a_screen(a) ((SCREEN * )Field(a,2)) #define a_int(a) Int_val(a) #define a_bool(a) Bool_val(a) #define a_chtype(a) Int_val(a) #define a_attr_t(a) Int_val(a) #define a_string(a) String_val(a) #define RA0 CAMLparam0(); #define RA1 CAMLparam1(aa); AWB(aa); #define RA2 CAMLparam2(aa,ab); AWB(aa); #define RA3 CAMLparam3(aa,ab,ac); AWB(aa); #define RA4 CAMLparam4(aa,ab,ac,ad); AWB(aa); #define RA5 CAMLparam5(aa,ab,ac,ad,ae); AWB(aa); #define RA6 CAMLparam5(aa,ab,ac,ad,ae); CAMLxparam1(af); AWB(aa); AWB(af); #define RA7 CAMLparam5(aa,ab,ac,ad,ae); CAMLxparam2(af,ag); AWB(aa); AWB(af); #define RA8 CAMLparam5(aa,ab,ac,ad,ae); CAMLxparam3(af,ag,ah); AWB(aa); AWB(af); #define RA9 CAMLparam5(aa,ab,ac,ad,ae); CAMLxparam4(af,ag,ah,ai); AWB(aa); AWB(af); #define ML0(f,tr) \ value mlcurses_##f(void) \ { RA0 r_##tr(f()); } #define ML1(f,tr,ta) \ value mlcurses_##f(value aa) \ { RA1 r_##tr(f(a_##ta(aa))); } #define ML2(f,tr,ta,tb) \ value mlcurses_##f(value aa,value ab) \ { RA2 r_##tr(f(a_##ta(aa),a_##tb(ab))); } #define ML3(f,tr,ta,tb,tc) \ value mlcurses_##f(value aa,value ab,value ac) \ { RA3 r_##tr(f(a_##ta(aa),a_##tb(ab),a_##tc(ac))); } #define ML4(f,tr,ta,tb,tc,td) \ value mlcurses_##f(value aa,value ab,value ac,value ad) \ { RA4 r_##tr(f(a_##ta(aa),a_##tb(ab),a_##tc(ac),a_##td(ad))); } #define ML5(f,tr,ta,tb,tc,td,te) \ value mlcurses_##f(value aa,value ab,value ac,value ad,value ae) \ { RA5 r_##tr(f(a_##ta(aa),a_##tb(ab),a_##tc(ac),a_##td(ad),a_##te(ae))); } #define ML7(f,tr,ta,tb,tc,td,te,tf,tg) \ value mlcurses_##f##_bytecode(value *a,int n) \ { RA0 r_##tr(f(a_##ta(a[0]),a_##tb(a[1]),a_##tc(a[2]),a_##td(a[3]), \ a_##te(a[4]),a_##tf(a[5]),a_##tg(a[6]))); } \ value mlcurses_##f##_native(value aa,value ab,value ac,value ad, \ value ae,value af,value ag) \ { RA7 r_##tr(f(a_##ta(aa),a_##tb(ab),a_##tc(ac),a_##td(ad), \ a_##te(ae),a_##tf(af),a_##tg(ag))); } #define ML8(f,tr,ta,tb,tc,td,te,tf,tg,th) \ value mlcurses_##f##_bytecode(value *a,int n) \ { RA0 r_##tr(f(a_##ta(a[0]),a_##tb(a[1]),a_##tc(a[2]),a_##td(a[3]), \ a_##te(a[4]),a_##tf(a[5]),a_##tg(a[6]),a_##th(a[7]))); } \ value mlcurses_##f##_native(value aa,value ab,value ac,value ad, \ value ae,value af,value ag,value ah) \ { RA8 r_##tr(f(a_##ta(aa),a_##tb(ab),a_##tc(ac),a_##td(ad), \ a_##te(ae),a_##tf(af),a_##tg(ag),a_##th(ah))); } #define ML9(f,tr,ta,tb,tc,td,te,tf,tg,th,ti) \ value mlcurses_##f##_bytecode(value *a,int n) \ { RA0 r_##tr(f(a_##ta(a[0]),a_##tb(a[1]),a_##tc(a[2]),a_##td(a[3]),a_##te(a[4]), \ a_##tf(a[5]),a_##tg(a[6]),a_##th(a[7]),a_##ti(a[8]))); } \ value mlcurses_##f##_native(value aa,value ab,value ac,value ad,value ae, \ value af,value ag,value ah,value ai) \ { RA9 r_##tr(f(a_##ta(aa),a_##tb(ab),a_##tc(ac),a_##td(ad),a_##te(ae), \ a_##tf(af),a_##tg(ag),a_##th(ah),a_##ti(ai))); } #define ML0d(f,tr) value mlcurses_##f(void) #define ML1d(f,tr,ta) value mlcurses_##f(value aa) #define ML2d(f,tr,ta,tb) value mlcurses_##f(value aa,value ab) #define ML3d(f,tr,ta,tb,tc) value mlcurses_##f(value aa,value ab,value ac) #define ML4d(f,tr,ta,tb,tc,td) value mlcurses_##f(value aa,value ab,\ value ac,value ad) #define ML5d(f,tr,ta,tb,tc,td,te) value mlcurses_##f(value aa,value ab,\ value ac,value ad,value ae) #define ML6d(f,tr,ta,tb,tc,td,te,tf) value mlcurses_##f##_native(value,value,\ value,value,value,value); \ value mlcurses_##f##_bytecode(value *a,int n) \ { return(mlcurses_##f##_native(a[0],a[1],a[2],a[3],a[4],a[5])); } \ value mlcurses_##f##_native(value aa,value ab,value ac,value ad,value ae,value af) #define BEG0 { RA0 { #define BEG1 { RA1 { #define BEG2 { RA2 { #define BEG3 { RA3 { #define BEG4 { RA4 { #define BEG5 { RA5 { #define BEG6 { RA6 { #define BEG7 { RA7 { #define BEG8 { RA8 { #define BEG9 { RA9 { #define END }} /* RWMJ: Not implemented functions raise Invalid_argument * ("function_name"). This can happen for example when we are not * linked to real ncurses, particularly on Windows. */ #define ML0_notimpl(f,tr) \ value mlcurses_##f(void) BEG0 caml_invalid_argument (#f); CAMLnoreturn; END #define ML1_notimpl(f,tr,ta) \ value mlcurses_##f(value aa) BEG1 caml_invalid_argument (#f); CAMLnoreturn; END #define ML2_notimpl(f,tr,ta,tb) \ value mlcurses_##f(value aa, value ab) BEG2 caml_invalid_argument (#f); CAMLnoreturn; END static WINDOW *ripoff_w[5]; static int ripoff_l[5]; static int ripoff_niv=0; static int ripoff_callback(WINDOW *w,int l) { if(ripoff_niv==5) return(0); ripoff_w[ripoff_niv]=w; ripoff_l[ripoff_niv]=l; ripoff_niv++; return(0); } value putc_function; static int putc_callback(int c) { CAMLparam0(); CAMLlocal1(ret); AWB(ret); ret=callback_exn(putc_function,Val_int(c&255)); CAMLreturn(Is_exception_result(ret)?-1:0); } #ifndef WIN32 /* Du travail pour les esclaves de M$ */ static void winch_handler(int n) { signal(n,winch_handler); ungetch(KEY_RESIZE); } #endif #include "functions.c" #include "caml/signals.h" /* The following routines are special-cased to allow other threads to run * while getch() is blocking */ value mlcurses_getch(void) { CAMLparam0(); int ch; enter_blocking_section(); ch = getch(); leave_blocking_section(); CAMLreturn(Val_int(ch)); } value mlcurses_wgetch(value win) { CAMLparam1(win); int ch; WINDOW* w; caml__dummy_win = caml__dummy_win; w = (WINDOW *) win; enter_blocking_section(); ch = wgetch(w); leave_blocking_section(); CAMLreturn(Val_int(ch)); } ocaml-curses-1.0.3/test.ml0000664000076400007640000000433611110317706015020 0ustar rjonesrjonesopen Curses let () = ripoffline true let w = initscr () let (wd, ncol) = get_ripoff () (*let () = assert (start_color ()) let () = assert (init_pair 1 Color.red Color.white)*) let () = assert (cbreak ()) let () = assert (noecho ()) let () = assert (intrflush w false) let () = assert (keypad w true) let () = for i = 0 to 10 do assert (mvaddch i (i * 2) (A.color_pair 1 + 111)) done let () = border 0 0 0 0 0 0 0 0 let () = wborder w 0 0 0 0 0 0 0 0 let () = assert (refresh ()) let (c1, c2) = mousemask (-1) let () = assert (mvaddstr 3 1 "Bonjour") let () = assert (mvaddstr 4 2 (string_of_int c1)) let () = assert (mvaddstr 5 2 (string_of_int c2)) let t = Array.init 50 (fun x -> 64 + x) let () = assert (addchnstr t 10 3) let () = assert (mvaddnstr 8 40 "Bonjour" 1 3) let () = assert (mvinsstr 8 40 "toto ") let t = [|0; 0; 0; 0 |] let () = assert (inchnstr t 0 3) let () = try winch_handler_on () with Invalid_argument "winch_handler_on" -> () let () = try let kup = tigetstr "kcuu1" in assert (addstr kup) with Failure "tigetstr" -> () let acs = get_acs_codes () let () = assert (addch acs.Acs.ulcorner) let i = getch () let (nc, np, can) = (colors (), color_pairs (), can_change_color ()) let (c1, c2) = pair_content 1 let l = ref [] let () = assert (tputs "totoping" 1 (fun c -> l := (int_of_char c) :: !l)) let (tr, tc) = get_size () let () = endwin () let () = Array.iter (fun x -> print_int x; print_newline ()) t let () = print_string "key="; print_int i; print_newline () let () = print_int tr; print_string " "; print_int tc; print_newline () let () = print_int nc; print_string " " let () = print_int np; print_string " " let () = print_string (if can then "oui" else "non"); print_newline () let () = print_int c1; print_string " " let () = print_int c2; print_newline () let () = print_int ncol; print_newline () let () = List.iter (fun x -> print_int x; print_string " ") !l; print_newline () (*let i = ref 0 let () = while let (a, b, c) = str_terminfo_variable !i in (a <> "") && (print_string (a ^ "\t" ^ b ^ "\t" ^ c); print_newline (); true) do i := !i + 1 done*) (*let () = Hashtbl.iter (fun a (b,c) -> print_string (a ^ "\t" ^ b ^ "\t" ^ c); print_newline ()) str_terminfo_variables*) ocaml-curses-1.0.3/curses.mli0000664000076400007640000005252611010731420015512 0ustar rjonesrjones(** * Bindings to the ncurses library. * * Beware, all coordinates are passed [y] first, then [x]. * * Functions whose name start with a "w" take as first argument the window the * function applies to. * Functions whose name start with "mv" take as first two arguments the * coordinates [y] and [x] of the point to move the cursor to. For example * [mvaddch y x ch] is the same as [move y x; addch ch]. *) (** Windows. *) type window (** Screens. *) type screen (** Terminals. *) type terminal (** Characters. Usual characters can be converted from/to [chtype] using * [char_of_int] and [int_of_char]. See also [get_acs_codes] for characters * useful for drawing and the [Key] module for special input characters. *) type chtype = int (** Attributes are [lor]ings of flags which are defined in the [A] module. *) type attr_t = int (** A return value. [false] means that an error occured. *) type err = bool (** {2 Initialization functions} *) (** Initialize the curses library. *) val initscr : unit -> window (** Restore the terminal (should be called before exiting). *) val endwin : unit -> unit (** Has [endwin] been called without any subsequent call to [werefresh]? *) val isendwin : unit -> bool (** Create a new terminal. *) val newterm : string -> Unix.file_descr -> Unix.file_descr -> screen (** Switch terminal. *) val set_term : screen -> unit (** Delete a screen. *) val delscreen : screen -> unit val stdscr : unit -> window (** {2 Cursor} *) (** Get the current cursor position. *) val getyx : window -> int * int val getparyx : window -> int * int val getbegyx : window -> int * int val getmaxyx : window -> int * int (** Move the cursor. *) val move : int -> int -> err val wmove : window -> int -> int -> err (** {2 Operations on characters} *) (** Predefined characters. *) module Acs : sig type acs = { ulcorner : chtype; (** Upper left-hand corner (+). *) llcorner : chtype; (** Lower left-hand corner (+). *) urcorner : chtype; (** Upper right-hand corner (+). *) lrcorner : chtype; (** Lower right-hand corner (+). *) ltee : chtype; (** Left tee (+). *) rtee : chtype; (** Tight tee (+). *) btee : chtype; ttee : chtype; hline : chtype; (** Horizontal line (-). *) vline : chtype; (** Vertical line (|). *) plus : chtype; (** Plus (+). *) s1 : chtype; (** Scan line 1 (-). *) s9 : chtype; (** Scan line 9 (_). *) diamond : chtype; (** Diamond (+). *) ckboard : chtype; degree : chtype; (** Degree symbol ('). *) plminus : chtype; (** Plus/minus (#). *) bullet : chtype; larrow : chtype; (** Arrow pointing left (<). *) rarrow : chtype; (** Arrow pointing right (>). *) darrow : chtype; uarrow : chtype; (** Arrow pointing up (^). *) board : chtype; lantern : chtype; block : chtype; (** Solid square block (#). *) s3 : chtype; (** Scan line 3 (-). *) s7 : chtype; (** Scan line 7 (-). *) lequal : chtype; (** Less-than-or-equal-to (<). *) gequal : chtype; (** Greater-or-equal-to (>). *) pi : chtype; (** Greek pi ( * ). *) nequal : chtype; (** Not-equal (!). *) sterling : chtype; (** Pound-Sterling symbol (f). *) } val bssb : acs -> chtype val ssbb : acs -> chtype val bbss : acs -> chtype val sbbs : acs -> chtype val sbss : acs -> chtype val sssb : acs -> chtype val ssbs : acs -> chtype val bsss : acs -> chtype val bsbs : acs -> chtype val sbsb : acs -> chtype val ssss : acs -> chtype end (** Get the predefined characters. *) val get_acs_codes : unit -> Acs.acs (** {3 Displaying characters} *) (** Add a character at the current position, then advance the cursor. *) val addch : chtype -> err val waddch : window -> chtype -> err val mvaddch : int -> int -> chtype -> err val mvwaddch : window -> int -> int -> chtype -> err (** [echochar ch] is equivalent to [addch ch] followed by [refresh ()]. *) val echochar : chtype -> err val wechochar : window -> chtype -> err (** Add a sequence of characters at the current position. See also [addstr]. *) val addchstr : chtype array -> err val waddchstr : window -> chtype array -> err val mvaddchstr : int -> int -> chtype array -> err val mvwaddchstr : window -> int -> int -> chtype array -> err val addchnstr : chtype array -> int -> int -> err val waddchnstr : window -> chtype array -> int -> int -> err val mvaddchnstr : int -> int -> chtype array -> int -> int -> err val mvwaddchnstr : window -> int -> int -> chtype array -> int -> int -> err (** Add a string at the current position. *) val addstr : string -> err val waddstr : window -> string -> err val mvaddstr : int -> int -> string -> err val mvwaddstr : window -> int -> int -> string -> err val addnstr : string -> int -> int -> err val waddnstr : window -> string -> int -> int -> err val mvaddnstr : int -> int -> string -> int -> int -> err val mvwaddnstr : window -> int -> int -> string -> int -> int -> err (** Insert a character before cursor. *) val insch : chtype -> err val winsch : window -> chtype -> err val mvinsch : int -> int -> chtype -> err val mvwinsch : window -> int -> int -> chtype -> err (** Insert a string before cursor. *) val insstr : string -> err val winsstr : window -> string -> err val mvinsstr : int -> int -> string -> err val mvwinsstr : window -> int -> int -> string -> err val insnstr : string -> int -> int -> err val winsnstr : window -> string -> int -> int -> err val mvinsnstr : int -> int -> string -> int -> int -> err val mvwinsnstr : window -> int -> int -> string -> int -> int -> err (** Delete a character. *) val delch : unit -> err val wdelch : window -> err val mvdelch : int -> int -> err val mvwdelch : window -> int -> int -> err (** {3 Attributes} *) (** Attributes. *) module A : sig (** Normal display (no highlight). *) val normal : int val attributes : int (** Bit-mask to extract a character. *) val chartext : int val color : int (** Best highlighting mode of the terminal. *) val standout : int (** Underlining. *) val underline : int (** Reverse video. *) val reverse : int (** Blinking. *) val blink : int (** Half bright. *) val dim : int (** Extra bright or bold. *) val bold : int (** Alternate character set. *) val altcharset : int (** Invisible or blank mode. *) val invis : int (** Protected mode. *) val protect : int val horizontal : int val left : int val low : int val right : int val top : int val vertical : int val combine : int list -> int (** Color-pair number [n]. *) val color_pair : int -> int (** Get the pair number associated with the [color_pair n] attribute. *) val pair_number : int -> int end (** New series of highlight attributes. *) module WA : sig (** Normal display (no highlight). *) val normal : int val attributes : int val chartext : int val color : int (** Best highlighting mode of the terminal. Same as [attron A.standout]. *) val standout : int (** Underlining. *) val underline : int (** Reverse video. *) val reverse : int (** Blinking. *) val blink : int (** Half bright. *) val dim : int (** Extra bright or bold. *) val bold : int (** Alternate character set. *) val altcharset : int val invis : int val protect : int val horizontal : int val left : int val low : int val right : int val top : int val vertical : int val combine : int list -> int val color_pair : int -> int val pair_number : int -> int end (** Turn off the attributes given in argument (see the [A] module). *) val attroff : int -> unit val wattroff : window -> int -> unit (** Turn on the attributes given in argument. *) val attron : int -> unit val wattron : window -> int -> unit (** Set the attributes. *) val attrset : int -> unit val wattrset : window -> int -> unit val standend : unit -> unit val wstandend : window -> unit val standout : unit -> unit val wstandout : window -> unit (** Turn off the attributes given in argument (see the [WA] module). *) val attr_off : attr_t -> unit val wattr_off : window -> attr_t -> unit val attr_on : attr_t -> unit val wattr_on : window -> attr_t -> unit val attr_set : attr_t -> int -> unit val wattr_set : window -> attr_t -> int -> unit (** [chgat n attr color] changes the attributes of [n] characters. *) val chgat : int -> attr_t -> int -> unit val wchgat : window -> int -> attr_t -> int -> unit val mvchgat : int -> int -> int -> attr_t -> int -> unit val mvwchgat : window -> int -> int -> int -> attr_t -> int -> unit (** Get the attributes of the caracter at current position. *) val inch : unit -> chtype val winch : window -> chtype val mvinch : int -> int -> chtype val mvwinch : window -> int -> int -> chtype (** Get the attributes of a sequence of characters. *) val inchstr : chtype array -> err val winchstr : window -> chtype array -> err val mvinchstr : int -> int -> chtype array -> err val mvwinchstr : window -> int -> int -> chtype array -> err val inchnstr : chtype array -> int -> int -> err val winchnstr : window -> chtype array -> int -> int -> err val mvinchnstr : int -> int -> chtype array -> int -> int -> err val mvwinchnstr : window -> int -> int -> chtype array -> int -> int -> err (** Get the attributes of a string. *) val instr : string -> err val winstr : window -> string -> err val mvinstr : int -> int -> string -> err val mvwinstr : window -> int -> int -> string -> err val innstr : string -> int -> int -> err val winnstr : window -> string -> int -> int -> err val mvinnstr : int -> int -> string -> int -> int -> err val mvwinnstr : window -> int -> int -> string -> int -> int -> err (** {3 Background} *) (** Set the background of the current character. *) val bkgdset : chtype -> unit val wbkgdset : window -> chtype -> unit (** Set the background of every character. *) val bkgd : chtype -> unit val wbkgd : window -> chtype -> unit (** Get the current background. *) val getbkgd : window -> chtype (** {3 Operations on lines} *) (** Delete a line. *) val deleteln : unit -> err val wdeleteln : window -> err (** [insdelln n] inserts [n] lines above the current line if [n] is positive or * deletes [-n] lines if [n] is negative. *) val insdelln : int -> err val winsdelln : window -> int -> err (** Insert a blank line above the current line. *) val insertln : unit -> err val winsertln : window -> err (** {3 Characters input} *) (** Special keys. *) module Key : sig val code_yes : int val min : int val break : int val down : int val up : int val left : int val right : int val home : int val backspace : int val f0 : int val dl : int val il : int val dc : int val ic : int val eic : int val clear : int val eos : int val eol : int val sf : int val sr : int val npage : int val ppage : int val stab : int val ctab : int val catab : int val enter : int val sreset : int val reset : int val print : int val ll : int val a1 : int val a3 : int val b2 : int val c1 : int val c3 : int val btab : int val beg : int val cancel : int val close : int val command : int val copy : int val create : int val end_ : int val exit : int val find : int val help : int val mark : int val message : int val move : int val next : int val open_ : int val options : int val previous : int val redo : int val reference : int val refresh : int val replace : int val restart : int val resume : int val save : int val sbeg : int val scancel : int val scommand : int val scopy : int val screate : int val sdc : int val sdl : int val select : int val send : int val seol : int val sexit : int val sfind : int val shelp : int val shome : int val sic : int val sleft : int val smessage : int val smove : int val snext : int val soptions : int val sprevious : int val sprint : int val sredo : int val sreplace : int val sright : int val srsume : int val ssave : int val ssuspend : int val sundo : int val suspend : int val undo : int val mouse : int val resize : int val max : int val f : int -> int end (** Read a character in a window. *) val getch : unit -> int val wgetch : window -> int val mvgetch : int -> int -> int val mvwgetch : window -> int -> int -> int val ungetch : int -> err (** Read a string in a window. *) val getstr : string -> err val wgetstr : window -> string -> err val mvgetstr : int -> int -> string -> err val mvwgetstr : window -> int -> int -> string -> err val getnstr : string -> int -> int -> err val wgetnstr : window -> string -> int -> int -> err val mvgetnstr : int -> int -> string -> int -> int -> err val mvwgetnstr : window -> int -> int -> string -> int -> int -> err (** {2 Windows} *) (** {3 Window manipulations} *) (** [newwin l c y x] create a new window with [l] lines, [c] columns. The upper * left-hand corner is at ([x],[y]). *) val newwin : int -> int -> int -> int -> window (** Delete a window. *) val delwin : window -> err (** Move a window. *) val mvwin : window -> int -> int -> err (** [subwin l c y x] create a subwindow with [l] lines and [c] columns at * screen-relative position ([x],[y]). *) val subwin : window -> int -> int -> int -> int -> window (** Same as [subwin] excepting that the position ([x],[y]) is relative to the * parent window. *) val derwin : window -> int -> int -> int -> int -> window (** Move a derived windw. *) val mvderwin : window -> int -> int -> err (** Duplicate a window. *) val dupwin : window -> window val wsyncup : window -> unit (** If [syncok] is called with [true] as second argument, [wsyncup] is called * automatically whenever there is a change in the window. *) val syncok : window -> bool -> err val wcursyncup : window -> unit val wsyncdown : window -> unit val winch_handler_on : unit -> unit val winch_handler_off : unit -> unit val get_size : unit -> int * int val get_size_fd : Unix.file_descr -> int * int val null_window : window (** {3 Refresh control} *) (** Refresh windows. *) val refresh : unit -> err val wrefresh : window -> err val wnoutrefresh : window -> err val doupdate : unit -> err val redrawwin : window -> err val wredrawln : window -> int -> int -> err val wresize : window -> int -> int -> err val resizeterm : int -> int -> err val scroll : window -> err val scrl : int -> err val wscrl : window -> int -> err val touchwin : window -> err val touchline : window -> int -> int -> err val untouchwin : window -> err val wtouchln : window -> int -> int -> bool -> err val is_linetouched : window -> int -> int val is_wintouched : window -> bool (** Clear a window. *) val erase : unit -> unit val werase : window -> unit val clear : unit -> unit val wclear : window -> unit val clrtobot : unit -> unit val wclrtobot : window -> unit val clrtoeol : unit -> unit val wclrtoeol : window -> unit (** {3 Overlapped windows} *) (** [overlay srcwin dstwin] overlays [srcwin] on top of [dstwin]. *) val overlay : window -> window -> err val overwrite : window -> window -> err val copywin : window -> window -> int -> int -> int -> int -> int -> int -> bool -> err (** {3 Decorations} *) (** Draw a box around the edges of a window. *) val border : chtype -> chtype -> chtype -> chtype -> chtype -> chtype -> chtype -> chtype -> unit val wborder : window -> chtype -> chtype -> chtype -> chtype -> chtype -> chtype -> chtype -> chtype -> unit (** Draw a box. *) val box : window -> chtype -> chtype -> unit (** Draw an horizontal line. *) val hline : chtype -> int -> unit val whline : window -> chtype -> int -> unit val mvhline : int -> int -> chtype -> int -> unit val mvwhline : window -> int -> int -> chtype -> int -> unit (** Draw a vertical line. *) val vline : chtype -> int -> unit val wvline : window -> chtype -> int -> unit val mvvline : int -> int -> chtype -> int -> unit val mvwvline : window -> int -> int -> chtype -> int -> unit (** {3 Pads} *) (** A pad is like a window except that it is not restricted by the screen size, * and is not necessarily associated with a particular part of the screen.*) (** Create a new pad. *) val newpad : int -> int -> window val subpad : window -> int -> int -> int -> int -> window val prefresh : window -> int -> int -> int -> int -> int -> int -> err val pnoutrefresh : window -> int -> int -> int -> int -> int -> int -> err val pechochar : window -> chtype -> err (** {2 Colors} *) (** Colors. *) module Color : sig val black : int val red : int val green : int val yellow : int val blue : int val magenta : int val cyan : int val white : int end val start_color : unit -> err val use_default_colors : unit -> err val init_pair : int -> int -> int -> err val init_color : int -> int -> int -> int -> err val has_colors : unit -> bool val can_change_color : unit -> bool val color_content : int -> int * int * int val pair_content : int -> int * int val colors : unit -> int val color_pairs : unit -> int (** {2 Input/output options} *) (** {3 Input options} *) (** Disable line buffering. *) val cbreak : unit -> err (** Similar to [cbreak] but with delay. *) val halfdelay : int -> err (** Enable line buffering (waits for characters until newline is typed). *) val nocbreak : unit -> err (** Don't echo typed characters. *) val echo : unit -> err (** Echo typed characters. *) val noecho : unit -> err val intrflush : window -> bool -> err val keypad : window -> bool -> err val meta : window -> bool -> err val nodelay : window -> bool -> err val raw : unit -> err val noraw : unit -> err val noqiflush : unit -> unit val qiflush : unit -> unit val notimeout : window -> bool -> err val timeout : int -> unit val wtimeout : window -> int -> unit val typeahead : Unix.file_descr -> err val notypeahead : unit -> err (** {3 Output options} *) (** If called with [true] as second argument, the next call to [wrefresh] with * this window will clear the streen completely and redraw the entire screen * from scratch. *) val clearok : window -> bool -> unit val idlok : window -> bool -> unit val idcok : window -> bool -> unit val immedok : window -> bool -> unit val leaveok : window -> bool -> unit val setscrreg : int -> int -> err val wsetscrreg : window -> int -> int -> err val scrollok : window -> bool -> unit val nl : unit -> unit val nonl : unit -> unit (** {2 Soft-label keys} *) (** Initialize soft labels. *) val slk_init : int -> err val slk_set : int -> string -> int -> err val slk_refresh : unit -> err val slk_noutrefresh : unit -> err val slk_label : int -> string val slk_clear : unit -> err val slk_restore : unit -> err val slk_touch : unit -> err val slk_attron : attr_t -> err val slk_attroff : attr_t -> err val slk_attrset : attr_t -> err (** {2 Mouse} *) (** Sets the mouse mask. *) val mousemask : int -> int * int (** {2 Misc} *) (** Ring a bell. *) val beep : unit -> err (** Flash the screen. *) val flash : unit -> err val unctrl : chtype -> string val keyname : int -> string val filter : unit -> unit val use_env : bool -> unit val putwin : window -> Unix.file_descr -> err val getwin : Unix.file_descr -> window val delay_output : int -> err val flushinp : unit -> unit (** {2 Screen manipulation} *) (** Dump the current screen to a file. *) val scr_dump : string -> err val scr_restore : string -> err val scr_init : string -> err val scr_set : string -> err (** {2 Terminal} *) (** Get the speed of a terminal (in bits per second). *) val baudrate : unit -> int (** Get user's current erase character. *) val erasechar : unit -> char (** Has the terminal insert- and delete-character capabilites? *) val has_ic : unit -> bool (** Has the terminal insert- and delete-line capabilites? *) val has_il : unit -> bool (** Get user's current line kill character. *) val killchar : unit -> char (** Get a description of the terminal. *) val longname : unit -> string val termattrs : unit -> attr_t val termname : unit -> string val tgetent : string -> bool val tgetflag : string -> bool val tgetnum : string -> int val tgetstr : string -> bool val tgoto : string -> int -> int -> string val setupterm : string -> Unix.file_descr -> err val setterm : string -> err val cur_term : unit -> terminal val set_curterm : terminal -> terminal val del_curterm : terminal -> err val restartterm : string -> Unix.file_descr -> err val putp : string -> err val vidattr : chtype -> err val mvcur : int -> int -> int -> int -> err val tigetflag : string -> bool val tigetnum : string -> int val tigetstr : string -> string val tputs : string -> int -> (char -> unit) -> err val vidputs : chtype -> (char -> unit) -> err val tparm : string -> int array -> string val bool_terminfo_variable : int -> string * string * string val num_terminfo_variable : int -> string * string * string val str_terminfo_variable : int -> string * string * string val bool_terminfo_variables : (string, string * string) Hashtbl.t val num_terminfo_variables : (string, string * string) Hashtbl.t val str_terminfo_variables : (string, string * string) Hashtbl.t (** {2 Low-level curses routines} *) (** Save the current terminal modes as the "program" state for use by the * [reser_prog_mod] and [reset_shell_mode] functions. *) val def_prog_mode : unit -> unit val def_shell_mode : unit -> unit val reset_prog_mode : unit -> unit val reset_shell_mode : unit -> unit val resetty : unit -> unit val savetty : unit -> unit val getsyx : unit -> int * int val setsyx : int -> int -> unit val curs_set : int -> err val napms : int -> unit val ripoffline : bool -> unit val get_ripoff : unit -> window * int (** {2 Configuration} *) module Curses_config : sig (** If [Curses] has been linked against a curses library with wide * character support, then [wide_ncurses] is [true]. *) val wide_ncurses : bool end ocaml-curses-1.0.3/Makefile.in0000664000076400007640000000344111110320620015535 0ustar rjonesrjones# $Id: Makefile.in,v 1.2 2008/11/17 16:53:36 rwmj Exp $ PACKAGE = ocaml-curses VERSION = 1.0.3 CURSES = ncurses CLIBS = @CURSES_LIB_BASE@ DEFS = @DEFS@ RESULT = curses SOURCES = ml_curses.c keys.ml curses.mli curses.ml CC = @CC@ CFLAGS = -g -Wall $(DEFS) LDFLAGS = @LDFLAGS@ RANLIB = @RANLIB@ LIBINSTALL_FILES = $(wildcard *.mli *.cmi *.cma *.cmxa *.a *.so) OCAMLDOCFLAGS = -stars all: byte opt: ncl META $(RANLIB) *.a byte: bcl META $(RANLIB) *.a install: byte libinstall uninstall: libuninstall test: test.ml byte $(OCAMLC) -I . -o $@ curses.cma $< test.opt: test.ml opt $(OCAMLOPT) -I . -o $@ curses.cmxa $< META: META.in sed \ -e 's/@PACKAGE@/curses/' \ -e 's/@VERSION@/$(VERSION)/' \ -e 's/@CURSES@/$(CURSES)/' \ < $< > $@ doc: htdoc distclean: clean rm -rf doc/curses rm -rf autom4te.cache rm -f config.log config.status Makefile config.ml # Distribution. dist: $(MAKE) check-manifest rm -rf $(PACKAGE)-$(VERSION) mkdir $(PACKAGE)-$(VERSION) tar -cf - -T MANIFEST | tar -C $(PACKAGE)-$(VERSION) -xf - tar zcf $(PACKAGE)-$(VERSION).tar.gz $(PACKAGE)-$(VERSION) rm -rf $(PACKAGE)-$(VERSION) ls -l $(PACKAGE)-$(VERSION).tar.gz check-manifest: @for d in `find -type d -name CVS | grep -v '^\./debian/'`; \ do \ b=`dirname $$d`/; \ awk -F/ '$$1 != "D" {print $$2}' $$d/Entries | \ sed -e "s|^|$$b|" -e "s|^\./||"; \ done | grep -v \.cvsignore | sort > .check-manifest; \ sort MANIFEST > .orig-manifest; \ diff -u .orig-manifest .check-manifest; rv=$$?; \ rm -f .orig-manifest .check-manifest; \ exit $$r # Upload to Savannah. USER = $(shell whoami) upload: rm -f $(PACKAGE)-$(VERSION).tar.gz.sig gpg -b $(PACKAGE)-$(VERSION).tar.gz scp $(PACKAGE)-$(VERSION).tar.gz{,.sig} \ $(USER)@dl.sv.nongnu.org:/releases/ocaml-tmk include OCamlMakefile .PHONY: doc