pax_global_header00006660000000000000000000000064112566554620014526gustar00rootroot0000000000000052 comment=61faff71399854581d37d4ff07b05754b881e8c0 ocaml_dbus-0.29/000077500000000000000000000000001125665546200135705ustar00rootroot00000000000000ocaml_dbus-0.29/.gitignore000066400000000000000000000001241125665546200155550ustar00rootroot00000000000000*.o *.a *.orig *.cmo *.cmx *.cmi *.cma *.cmxa *.annot *.so *.opt *~ *.tar *.tar.bz2 ocaml_dbus-0.29/LICENSE000066400000000000000000000644161125665546200146100ustar00rootroot00000000000000The Library is distributed under the terms of the GNU Library General Public License version 2.1 (included below). As a special exception to the GNU Library General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed, or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. ------------ 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. TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. one line to give the library's name and an idea of what it does. Copyright (C) year name of author This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 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. signature of Ty Coon, 1 April 1990 Ty Coon, President of Vice That's all there is to it! ocaml_dbus-0.29/META000066400000000000000000000001041125665546200142340ustar00rootroot00000000000000version="0.29" archive(byte)="dBus.cma" archive(native)="dBus.cmxa" ocaml_dbus-0.29/Makefile000066400000000000000000000041151125665546200152310ustar00rootroot00000000000000DBUS_CFLAGS = -ccopt "$(shell pkg-config --cflags dbus-1)" OCAMLC ?= ocamlc OCAMLOPT ?= ocamlopt OCAMLMKLIB ?= ocamlmklib DBUS_LDFLAGS = -cclib "" $(shell pkg-config --libs dbus-1) OCAMLOPTFLAGS = OCAML_PKG_NAME = dbus OCAMLABI := $(shell $(OCAMLC) -version) OCAMLLIBDIR := $(shell $(OCAMLC) -where) OCAMLDESTDIR ?= $(OCAMLLIBDIR) OCAML_TEST_INC = -I `ocamlfind query oUnit` OCAML_TEST_LIB = `ocamlfind query oUnit`/oUnit.cmxa CHECK_PKGS = dbus-1 INTERFACES = dBus.cmi dBus.mli LIBS_NAT = dBus.cmxa LIBS_BYTE = dBus.cma LIBS = $(LIBS_BYTE) $(LIBS_NAT) PROGRAMS = test all: $(INTERFACES) $(LIBS_NAT) $(LIBS_BYTE) all-opt: all all-byte: $(INTERFACES) $(LIBS_BYTE) bins: $(PROGRAMS) libs: $(LIBS) dBus.cmxa: libdbus_stubs.a dbus_stubs.a dBus.cmx $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -cclib -ldbus_stubs -cclib -ldbus-1 -o $@ dBus.cmx dBus.cma: libdbus_stubs.a dBus.cmi dBus.cmo $(OCAMLC) -a -dllib dlldbus_stubs.so -cclib -ldbus_stubs -cclib -ldbus-1 -o $@ dBus.cmo dbus_stubs.a: libdbus_stubs.a libdbus_stubs.a: dbus_stubs.o $(OCAMLMKLIB) -o dbus_stubs $(DBUS_LDFLAGS) $+ %.cmo: %.ml $(OCAMLC) -c -o $@ $< %.cmi: %.mli $(OCAMLC) -c -o $@ $< %.cmx: %.ml $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $< %.o: %.c $(OCAMLC) $(DBUS_CFLAGS) -c -o $@ $< .PHONY: check check: $(foreach pkg, $(CHECK_PKGS), \ @pkg-config --modversion $(pkg) > /dev/null 2>&1 || \ (echo "$(pkg) package not found" > /dev/stderr && exit 1)) .PHONY: install install: $(LIBS) ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore $(OCAML_PKG_NAME) META $(INTERFACES) $(LIBS) *.a *.so *.cmx install-opt: install install-byte: all-byte ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore $(OCAML_PKG_NAME) META $(INTERFACES) $(LIBS_BYTE) *.a *.so uninstall: ocamlfind remove -destdir $(OCAMLDESTDIR) $(OCAML_PKG_NAME) test: dBus.cmxa test.ml $(OCAMLOPT) -o $@ -cclib -L. unix.cmxa $+ .PHONY: example example: dBus.cmxa example.ml $(OCAMLOPT) -o $@ -cclib -L. $+ example_avahi: dBus.cmxa example_avahi.ml $(OCAMLOPT) -o $@ -cclib -L. $+ clean: rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa $(LIBS) $(PROGRAMS) ocaml_dbus-0.29/THANKS000066400000000000000000000001771125665546200145100ustar00rootroot00000000000000Here's a list of people to thanks for various fixings in this package: - Alex Myltsev - Richard W. M. Jones - Sylvain Le Gall ocaml_dbus-0.29/dBus.ml000066400000000000000000000451051125665546200150240ustar00rootroot00000000000000(* * Copyright (C) 2006-2009 Vincent Hanquez * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation; version 2.1 only. with the special * exception on linking described in file LICENSE. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * Dbus binding *) exception Type_not_supported of string exception Internal_error of string exception Error of string * string type bus type message type pending_call type watch type timeout type service = string type interface = string type path = string type add_watch_fn = watch -> bool type rm_watch_fn = watch -> unit type toggle_watch_fn = watch -> unit type add_timeout_fn = timeout -> bool type rm_timeout_fn = timeout -> unit type toggle_timeout_fn = timeout -> unit type watch_fns = add_watch_fn * rm_watch_fn * (toggle_watch_fn option) type timeout_fns = add_timeout_fn * rm_timeout_fn * (toggle_timeout_fn option) type error_name = | ERR_FAILED | ERR_NO_MEMORY | ERR_SERVICE_UNKNOWN | ERR_NAME_HAS_NO_OWNER | ERR_NO_REPLY | ERR_IO_ERROR | ERR_BAD_ADDRESS | ERR_NOT_SUPPORTED | ERR_LIMITS_EXCEEDED | ERR_ACCESS_DENIED | ERR_AUTH_FAILED | ERR_NO_SERVER | ERR_TIMEOUT | ERR_NO_NETWORK | ERR_ADDRESS_IN_USE | ERR_DISCONNECTED | ERR_INVALID_ARGS | ERR_FILE_NOT_FOUND | ERR_FILE_EXISTS | ERR_UNKNOWN_METHOD | ERR_TIMED_OUT | ERR_MATCH_RULE_NOT_FOUND | ERR_MATCH_RULE_INVALID | ERR_SPAWN_EXEC_FAILED | ERR_SPAWN_FORK_FAILED | ERR_SPAWN_CHILD_EXITED | ERR_SPAWN_CHILD_SIGNALED | ERR_SPAWN_FAILED | ERR_SPAWN_SETUP_FAILED | ERR_SPAWN_CONFIG_INVALID | ERR_SPAWN_SERVICE_INVALID | ERR_SPAWN_SERVICE_NOT_FOUND | ERR_SPAWN_PERMISSIONS_INVALID | ERR_SPAWN_FILE_INVALID | ERR_SPAWN_NO_MEMORY | ERR_UNIX_PROCESS_ID_UNKNOWN | ERR_INVALID_SIGNATURE | ERR_INVALID_FILE_CONTENT | ERR_SELINUX_SECURITY_CONTEXT_UNKNOWN | ERR_ADT_AUDIT_DATA_UNKNOWN | ERR_OBJECT_PATH_IN_USE external string_of_error_name : error_name -> string = "stub_dbus_string_of_error_name" type ty_sig = | SigByte | SigBool | SigInt16 | SigUInt16 | SigInt32 | SigUInt32 | SigInt64 | SigUInt64 | SigDouble | SigString | SigObjectPath | SigVariant | SigArray of ty_sig | SigStruct of ty_sig list | SigDict of ty_sig * ty_sig type ty_array = | Unknowns | Bytes of char list | Bools of bool list | Int16s of int list | UInt16s of int list | Int32s of int32 list | UInt32s of int32 list | Int64s of int64 list | UInt64s of int64 list | Doubles of float list | Strings of string list | ObjectPaths of string list | Structs of ty_sig list * (ty list list) | Variants of ty list | Dicts of (ty_sig * ty_sig) * ((ty * ty) list) | Arrays of ty_sig * (ty_array list) and ty = | Unknown | Byte of char | Bool of bool | Int16 of int | UInt16 of int | Int32 of int32 | UInt32 of int32 | Int64 of int64 | UInt64 of int64 | Double of float | String of string | ObjectPath of string | Array of ty_array | Struct of ty list | Variant of ty let rec string_of_ty_array ty = match ty with | Unknowns -> [] | Bytes cs -> List.map (fun x -> Printf.sprintf "%C" x) cs | Bools bs -> List.map (fun x -> Printf.sprintf "%b" x) bs | Int16s is -> List.map (fun x -> Printf.sprintf "%d" x) is | UInt16s is -> List.map (fun x -> Printf.sprintf "%d" x) is | Int32s is -> List.map (fun x -> Printf.sprintf "%ld" x) is | UInt32s is -> List.map (fun x -> Printf.sprintf "%ld" x) is | Int64s is -> List.map (fun x -> Printf.sprintf "%Ld" x) is | UInt64s is -> List.map (fun x -> Printf.sprintf "%Ld" x) is | Doubles fs -> List.map (fun x -> Printf.sprintf "%g" x) fs | Strings ss -> List.map (fun x -> Printf.sprintf "%S" x) ss | ObjectPaths ss -> List.map (fun x -> Printf.sprintf "%S" x) ss | Structs (ssig, ss) -> List.map (fun x -> string_of_ty (Struct x)) ss | Variants (vs) -> List.map string_of_ty vs | Dicts ((ksig, vsig), ds) -> List.map (fun (k, v) -> Printf.sprintf "%s: %s" (string_of_ty k) (string_of_ty v)) ds | Arrays (asig, a) -> List.map (fun x -> "[" ^ (String.concat ", " (string_of_ty_array x)) ^ "]") a and string_of_ty ty = match ty with | Unknown -> "Unknown" | Byte c -> Printf.sprintf "Byte(%C)" c | Bool b -> Printf.sprintf "Bool(%b)" b | Int16 i -> Printf.sprintf "Int16(%d)" i | UInt16 i -> Printf.sprintf "UInt16(%d)" i | Int32 i -> Printf.sprintf "Int32(%ld)" i | UInt32 i -> Printf.sprintf "UInt32(%ld)" i | Int64 i -> Printf.sprintf "Int64(%Ld)" i | UInt64 i -> Printf.sprintf "UInt64(%Ld)" i | Double d -> Printf.sprintf "Double(%g)" d | String s -> Printf.sprintf "String(%S)" s | ObjectPath s -> Printf.sprintf "ObjectPath(%S)" s | Array Unknowns -> Printf.sprintf "Array[...]" | Array ty -> Printf.sprintf "Array[%s]" (String.concat ", " (string_of_ty_array ty)) | Struct tys -> Printf.sprintf "Struct{%s}" (String.concat ", " (List.map string_of_ty tys)) | Variant ty -> Printf.sprintf "Variant{%s}" (string_of_ty ty) (******************** BUS **********************) module Bus = struct type ty = Session | System | Starter type flags = Replace_existing type grab_flag = | AllowReplacement | ReplaceExisting | DoNotQueue type request_reply = PrimaryOwner | InQueue | Exists | AlreadyOwner | ReqUnknown of int type release_reply = Released | NonExistent | NotOwner | RelUnknown of int let int_of_grab_flag flag = match flag with | AllowReplacement -> 0x1 | ReplaceExisting -> 0x2 | DoNotQueue -> 0x4 let request_reply_of_int i = match i with | 1 -> PrimaryOwner | 2 -> InQueue | 3 -> Exists | 4 -> AlreadyOwner | _ -> ReqUnknown i let release_reply_of_int i = match i with | 1 -> Released | 2 -> NonExistent | 3 -> NotOwner | _ -> RelUnknown i external get : ty -> bus = "stub_dbus_bus_get" external get_private : ty -> bus = "stub_dbus_bus_get_private" external register : bus -> unit = "stub_dbus_bus_register" external set_unique_name : bus -> string -> bool = "stub_dbus_bus_set_unique_name" external get_unique_name : bus -> string = "stub_dbus_bus_get_unique_name" external _request_name : bus -> string -> int -> int = "stub_dbus_bus_request_name" let request_name bus name flags = let iflags = List.map int_of_grab_flag flags in let flagval = List.fold_left (fun acc i -> acc lor i) 0 iflags in request_reply_of_int (_request_name bus name flagval) external _release_name : bus -> string -> int = "stub_dbus_bus_release_name" let release_name bus name = release_reply_of_int (_release_name bus name) external has_owner : bus -> string -> bool = "stub_dbus_bus_has_owner" external add_match : bus -> string -> bool -> unit = "stub_dbus_bus_add_match" external remove_match : bus -> string -> bool -> unit = "stub_dbus_bus_remove_match" end (****************** MESSAGE ********************) module Message = struct type message_type = Invalid | Method_call | Method_return | Error | Signal type message_header = { serial: int32; ty: message_type; destination: service option; path: path option; interface: interface option; member: string option; error_name: error_name option; sender: string option; } let string_of_message_ty ty = match ty with | Invalid -> "invalid" | Method_call -> "method_call" | Method_return -> "method_return" | Error -> "error" | Signal -> "signal" external create : message_type -> message = "stub_dbus_message_create" (** [create message_type] create a new empty message with a specific type. recommended not to use this call but use new_* calls instead that prefil all the required field too. *) external new_method_call : service -> path -> interface -> string -> message = "stub_dbus_message_new_method_call" (** [new_method_call destination path interface method] create a new method message *) external new_method_return : message -> message = "stub_dbus_message_new_method_return" (** [new_method_return message] create a new method return message from a method message *) external new_signal : path -> interface -> string -> message = "stub_dbus_message_new_signal" (** [new_signal path interface method] create a new signal message *) external new_error : message -> error_name -> string -> message = "stub_dbus_message_new_error" (** [new_error original_message error_name error_message] create a new error message from another message *) external get_header : message -> message_header = "stub_dbus_message_get_header" (** [get_header message] returns message header in a more easy fashion than using the is_* and get_* interface *) external _append : message -> ty list -> unit = "stub_dbus_message_append" let append message tys = let raise_type_not_supported_s s = raise (Type_not_supported s) in let raise_type_not_supported ty = raise_type_not_supported_s (Printf.sprintf "cannot append: %s" (string_of_ty ty)) in let check_sig sigs ty = () in let is_basic_sig ty = match ty with (* supported basic types *) | SigByte _ | SigBool _ | SigInt16 _ | SigUInt16 _ | SigInt32 _ | SigUInt32 _ | SigInt64 _ | SigUInt64 _ | SigDouble _ | SigString _ | SigObjectPath _ -> true | _ -> false in let rec is_sig_value_matching s v = match (s, v) with (* normal byte *) | (SigByte, (Byte _)) | (SigBool, (Bool _)) | (SigInt16, (Int16 _)) | (SigUInt16, (UInt16 _)) | (SigInt32, (Int32 _)) | (SigUInt32, (UInt32 _)) | (SigInt64, (Int64 _)) | (SigUInt64, (UInt64 _)) | (SigDouble, (Double _)) | (SigString, (String _)) | (SigObjectPath, (ObjectPath _)) -> true (* array matching *) | (SigArray SigByte, (Array (Bytes _))) | (SigArray SigBool, (Array (Bools _))) | (SigArray SigInt16, (Array (Int16s _))) | (SigArray SigUInt16, (Array (UInt16s _))) | (SigArray SigInt32, (Array (Int32s _))) | (SigArray SigUInt32, (Array (UInt32s _))) | (SigArray SigInt64, (Array (Int64s _))) | (SigArray SigUInt64, (Array (UInt64s _))) | (SigArray SigDouble, (Array (Doubles _))) | (SigArray SigString, (Array (Strings _))) | (SigArray SigObjectPath, (Array (ObjectPaths _))) -> true (* other container *) | (SigStruct sigs, Struct tys) -> true | (SigDict (ksig, vsig), _) -> true (* fallback to not matching *) | _ -> false in let rec check_ty ty = match ty with (* supported basic types *) | Byte _ | Bool _ | Int16 _ | UInt16 _ | Int32 _ | UInt32 _ | Int64 _ | UInt64 _ | Double _ | String _ | ObjectPath _ -> () (* supported arrays *) | Array (Bytes _) | Array (Bools _) | Array (Int16s _) | Array (UInt16s _) | Array (Int32s _) | Array (UInt32s _) | Array (Int64s _) | Array (UInt64s _) | Array (Doubles _) | Array (Strings _) | Array (ObjectPaths _) -> () (* just for getting unknown type, not supported to append *) | Unknown | Array Unknowns -> raise_type_not_supported ty (* ...*) | Array (Structs (sigs, tys)) -> List.iter (check_sig sigs) tys | Array (Variants tys) -> () | Array (Dicts ((sk, sv), tys)) -> if not (is_basic_sig sk) then raise_type_not_supported_s "no container allowed in dict key"; () | Array (Arrays (s, tys)) -> () | Struct tyl -> () | Variant ty -> () in List.iter check_ty tys; _append message tys (** [append message parameters] appends dbus parameters to the message *) external get : message -> ty list = "stub_dbus_message_get" (** [get message] returns all parameters associated with the message *) external marshal : message -> string = "stub_dbus_message_marshal" external set_path : message -> path -> unit = "stub_dbus_message_set_path" external set_interface : message -> interface -> unit = "stub_dbus_message_set_interface" external set_member : message -> string -> unit = "stub_dbus_message_set_member" external set_error_name : message -> error_name -> unit = "stub_dbus_message_set_error_name" external set_destination : message -> service -> unit = "stub_dbus_message_set_destination" external set_sender : message -> string -> unit = "stub_dbus_message_set_sender" external set_reply_serial : message -> int32 -> unit = "stub_dbus_message_set_reply_serial" external set_auto_start : message -> bool -> unit = "stub_dbus_message_set_auto_start" external has_path : message -> path -> bool = "stub_dbus_message_has_path" external has_interface : message -> interface -> bool = "stub_dbus_message_has_interface" external has_member : message -> string -> bool = "stub_dbus_message_has_member" external has_destination : message -> service -> bool = "stub_dbus_message_has_destination" external has_sender : message -> string -> bool = "stub_dbus_message_has_sender" external has_signature : message -> string -> bool = "stub_dbus_message_has_signature" external get_type : message -> message_type = "stub_dbus_message_get_type" external get_path : message -> path option = "stub_dbus_message_get_path" external get_interface : message -> interface option = "stub_dbus_message_get_interface" external get_member : message -> string option = "stub_dbus_message_get_member" external get_error_name : message -> error_name option = "stub_dbus_message_get_error_name" external get_destination : message -> service option = "stub_dbus_message_get_destination" external get_sender : message -> string option = "stub_dbus_message_get_sender" external get_signature : message -> string option = "stub_dbus_message_get_signature" external get_serial : message -> int32 = "stub_dbus_message_get_serial" external get_reply_serial : message -> int32 = "stub_dbus_message_get_reply_serial" external get_auto_start : message -> bool = "stub_dbus_message_get_auto_start" external is_signal : message -> service -> string -> bool = "stub_dbus_message_is_signal" external is_method_call : message -> service -> string -> bool = "stub_dbus_message_is_method_call" external is_error : message -> string -> bool = "stub_dbus_message_is_error" end (**************** CONNECTION *******************) module Connection = struct type dispatch_status = Data_remains | Complete | Need_memory external send : bus -> message -> int32 = "stub_dbus_connection_send" external send_with_reply : bus -> message -> int -> pending_call = "stub_dbus_connection_send_with_reply" external send_with_reply_and_block : bus -> message -> int -> message = "stub_dbus_connection_send_with_reply_and_block" external add_filter : bus -> (bus -> message -> bool) -> unit = "stub_dbus_connection_add_filter" external flush : bus -> unit = "stub_dbus_connection_flush" external read_write : bus -> int -> bool = "stub_dbus_connection_read_write" (** [read_write bus timeout_millisecond] will block until it can read or write. return value indicates whether connection is still open *) external read_write_dispatch : bus -> int -> bool = "stub_dbus_connection_read_write_dispatch" (** [read_write_dispatch bus timeout_millisecond] will block until it can read or write. return value indicates whether disconnect message has been processed *) external pop_message : bus -> message option = "stub_dbus_connection_pop_message" external get_dispatch_status : bus -> dispatch_status = "stub_dbus_connection_get_dispatch_status" (** [get_dispatch_status bus] gets the current state of the incoming message queue. *) external dispatch : bus -> dispatch_status = "stub_dbus_connection_dispatch" (** [dispatch bus] Processes any incoming data. *) external get_fd : bus -> Unix.file_descr = "stub_dbus_connection_get_fd" external set_watch_functions : bus -> watch_fns -> unit = "stub_dbus_connection_set_watch_functions" (** [set_watch_function bus addfn rmfn togglefn] set the watch functions for the connection. *) external set_timeout_functions : bus -> timeout_fns -> unit = "stub_dbus_connection_set_timeout_functions" external get_max_message_size : bus -> int = "stub_dbus_connection_get_max_message_size" external set_max_message_size : bus -> int -> unit = "stub_dbus_connection_set_max_message_size" external get_max_received_size : bus -> int = "stub_dbus_connection_get_max_received_size" external set_max_received_size : bus -> int -> unit = "stub_dbus_connection_get_max_received_size" external get_outgoing_size : bus -> int = "stub_dbus_connection_get_outgoing_size" external set_allow_anonymous : bus -> bool -> unit = "stub_dbus_connection_set_allow_anonymous" end (***************** PENDING ********************) module PendingCall = struct external block : pending_call -> unit = "stub_dbus_pending_call_block" external cancel : pending_call -> unit = "stub_dbus_pending_call_cancel" external get_completed : pending_call -> bool = "stub_dbus_pending_call_get_completed" external steal_reply : pending_call -> message = "stub_dbus_pending_call_steal_reply" end module Watch = struct type flags = Readable | Writable external get_unix_fd : watch -> Unix.file_descr = "stub_dbus_watch_get_unix_fd" external get_enabled : watch -> bool = "stub_dbus_watch_get_enabled" external get_flags : watch -> flags list = "stub_dbus_watch_get_flags" external handle : watch -> flags list -> unit = "stub_dbus_watch_handle" end module Timeout = struct external get_interval : timeout -> int = "stub_dbus_timeout_get_interval" external get_enabled : timeout -> bool = "stub_dbus_timeout_get_enabled" external handle : timeout -> unit = "stub_dbus_timeout_handle" end module Helper = struct let dbus_dest = "org.freedesktop.DBus" let dbus_intf = "org.freedesktop.DBus" let new_message_request_name name flags = let iflags = List.map Bus.int_of_grab_flag flags in let flagval = List.fold_left (fun acc i -> acc lor i) 0 iflags in let msg = Message.new_method_call dbus_dest "/" dbus_intf "RequestName" in Message.append msg [ String name; UInt32 (Int32.of_int flagval) ]; msg let new_message_release_name name = let msg = Message.new_method_call dbus_dest "/" dbus_intf "ReleaseName" in Message.append msg [ String name; ]; msg end let _ = Callback.register_exception "dbus.error" (Error ("register_callback", "register_callback")) let _ = Callback.register_exception "dbus.internal_error" (Internal_error "register_callback") let _ = Callback.register_exception "dbus.type_not_supported" (Type_not_supported "register_callback") ocaml_dbus-0.29/dBus.mli000066400000000000000000000167471125665546200152070ustar00rootroot00000000000000(* * Copyright (C) 2006-2009 Vincent Hanquez * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation; version 2.1 only. with the special * exception on linking described in file LICENSE. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * Dbus binding *) exception Error of string * string type bus type message type pending_call type watch type timeout type service = string type interface = string type path = string type add_watch_fn = watch -> bool type rm_watch_fn = watch -> unit type toggle_watch_fn = watch -> unit type add_timeout_fn = timeout -> bool type rm_timeout_fn = timeout -> unit type toggle_timeout_fn = timeout -> unit type watch_fns = add_watch_fn * rm_watch_fn * (toggle_watch_fn option) type timeout_fns = add_timeout_fn * rm_timeout_fn * (toggle_timeout_fn option) type error_name = | ERR_FAILED | ERR_NO_MEMORY | ERR_SERVICE_UNKNOWN | ERR_NAME_HAS_NO_OWNER | ERR_NO_REPLY | ERR_IO_ERROR | ERR_BAD_ADDRESS | ERR_NOT_SUPPORTED | ERR_LIMITS_EXCEEDED | ERR_ACCESS_DENIED | ERR_AUTH_FAILED | ERR_NO_SERVER | ERR_TIMEOUT | ERR_NO_NETWORK | ERR_ADDRESS_IN_USE | ERR_DISCONNECTED | ERR_INVALID_ARGS | ERR_FILE_NOT_FOUND | ERR_FILE_EXISTS | ERR_UNKNOWN_METHOD | ERR_TIMED_OUT | ERR_MATCH_RULE_NOT_FOUND | ERR_MATCH_RULE_INVALID | ERR_SPAWN_EXEC_FAILED | ERR_SPAWN_FORK_FAILED | ERR_SPAWN_CHILD_EXITED | ERR_SPAWN_CHILD_SIGNALED | ERR_SPAWN_FAILED | ERR_SPAWN_SETUP_FAILED | ERR_SPAWN_CONFIG_INVALID | ERR_SPAWN_SERVICE_INVALID | ERR_SPAWN_SERVICE_NOT_FOUND | ERR_SPAWN_PERMISSIONS_INVALID | ERR_SPAWN_FILE_INVALID | ERR_SPAWN_NO_MEMORY | ERR_UNIX_PROCESS_ID_UNKNOWN | ERR_INVALID_SIGNATURE | ERR_INVALID_FILE_CONTENT | ERR_SELINUX_SECURITY_CONTEXT_UNKNOWN | ERR_ADT_AUDIT_DATA_UNKNOWN | ERR_OBJECT_PATH_IN_USE type ty_sig = | SigByte | SigBool | SigInt16 | SigUInt16 | SigInt32 | SigUInt32 | SigInt64 | SigUInt64 | SigDouble | SigString | SigObjectPath | SigVariant | SigArray of ty_sig | SigStruct of ty_sig list | SigDict of ty_sig * ty_sig type ty_array = | Unknowns | Bytes of char list | Bools of bool list | Int16s of int list | UInt16s of int list | Int32s of int32 list | UInt32s of int32 list | Int64s of int64 list | UInt64s of int64 list | Doubles of float list | Strings of string list | ObjectPaths of string list | Structs of ty_sig list * (ty list list) | Variants of ty list | Dicts of (ty_sig * ty_sig) * ((ty * ty) list) | Arrays of ty_sig * (ty_array list) and ty = | Unknown | Byte of char | Bool of bool | Int16 of int | UInt16 of int | Int32 of int32 | UInt32 of int32 | Int64 of int64 | UInt64 of int64 | Double of float | String of string | ObjectPath of string | Array of ty_array | Struct of ty list | Variant of ty val string_of_ty : ty -> string val string_of_error_name : error_name -> string module Bus : sig type ty = Session | System | Starter type flags = Replace_existing type grab_flag = AllowReplacement | ReplaceExisting | DoNotQueue type request_reply = PrimaryOwner | InQueue | Exists | AlreadyOwner | ReqUnknown of int type release_reply = Released | NonExistent | NotOwner | RelUnknown of int val get : ty -> bus val get_private : ty -> bus val register : bus -> unit val set_unique_name : bus -> string -> bool val get_unique_name : bus -> string val request_name : bus -> string -> grab_flag list -> request_reply val release_name : bus -> string -> release_reply val has_owner : bus -> string -> bool val add_match : bus -> string -> bool -> unit val remove_match : bus -> string -> bool -> unit end module Message : sig type message_type = | Invalid | Method_call | Method_return | Error | Signal type message_header = { serial: int32; ty: message_type; destination: service option; path: path option; interface: interface option; member: string option; error_name: error_name option; sender: string option; } val string_of_message_ty : message_type -> string val create : message_type -> message val new_method_call : service -> path -> interface -> string -> message val new_method_return : message -> message val new_signal : path -> interface -> string -> message val new_error : message -> error_name -> string -> message val get_header : message -> message_header val append : message -> ty list -> unit val get : message -> ty list val marshal : message -> string val set_path : message -> path -> unit val set_interface : message -> interface -> unit val set_member : message -> string -> unit val set_error_name : message -> error_name -> unit val set_destination : message -> service -> unit val set_sender : message -> string -> unit val set_reply_serial : message -> int32 -> unit val set_auto_start : message -> bool -> unit val has_path : message -> path -> bool val has_interface : message -> interface -> bool val has_member : message -> string -> bool val has_destination : message -> service -> bool val has_sender : message -> string -> bool val has_signature : message -> string -> bool val get_type : message -> message_type val get_path : message -> path option val get_interface : message -> interface option val get_member : message -> string option val get_error_name : message -> error_name option val get_destination : message -> service option val get_sender : message -> string option val get_signature : message -> string option val get_serial : message -> int32 val get_reply_serial : message -> int32 val get_auto_start : message -> bool val is_signal : message -> interface -> string -> bool val is_method_call : message -> interface -> string -> bool val is_error : message -> string -> bool end module Connection : sig type dispatch_status = Data_remains | Complete | Need_memory val send : bus -> message -> int32 val send_with_reply : bus -> message -> int -> pending_call val send_with_reply_and_block : bus -> message -> int -> message val add_filter : bus -> (bus -> message -> bool) -> unit val flush : bus -> unit val read_write : bus -> int -> bool val read_write_dispatch : bus -> int -> bool val pop_message : bus -> message option val get_dispatch_status : bus -> dispatch_status val dispatch : bus -> dispatch_status val get_fd : bus -> Unix.file_descr val set_watch_functions : bus -> watch_fns -> unit val set_timeout_functions : bus -> timeout_fns -> unit val get_max_message_size : bus -> int val set_max_message_size : bus -> int -> unit val get_max_received_size : bus -> int val set_max_received_size : bus -> int -> unit val get_outgoing_size : bus -> int val set_allow_anonymous : bus -> bool -> unit end module PendingCall : sig val block : pending_call -> unit val cancel : pending_call -> unit val get_completed : pending_call -> bool val steal_reply : pending_call -> message end module Watch : sig type flags = Readable | Writable val get_unix_fd : watch -> Unix.file_descr val get_enabled : watch -> bool val get_flags : watch -> flags list val handle : watch -> flags list -> unit end module Timeout : sig val get_interval : timeout -> int val get_enabled : timeout -> bool val handle : timeout -> unit end module Helper : sig val new_message_request_name : string -> Bus.grab_flag list -> message val new_message_release_name : string -> message end ocaml_dbus-0.29/dbus_stubs.c000066400000000000000000001405601125665546200161170ustar00rootroot00000000000000/* * Copyright (C) 2006-2009 Vincent Hanquez * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation; version 2.1 only. with the special * exception on linking described in file LICENSE. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * Dbus binding */ #include #include #define CAML_NAME_SPACE #include #include #include #include #include #include #include #if defined(DEBUG_APPEND_ENABLE) || defined(DEBUG_GET_ENABLE) || defined(DEBUG_SIG_ENABLE) #include #include #endif /* debug */ #ifdef DEBUG_APPEND_ENABLE #define DEBUG_APPEND(fmt, ...) fprintf(stderr, "debug: append: " fmt, ##__VA_ARGS__) #else #define DEBUG_APPEND(fmt, ...) ((void) 0) #endif #ifdef DEBUG_GET_ENABLE #define DEBUG_GET(fmt, ...) fprintf(stderr, "debug: get: " fmt, ##__VA_ARGS__) #else #define DEBUG_GET(fmt, ...) ((void) 0) #endif #ifdef DEBUG_SIG_ENABLE #define DEBUG_SIG(fmt, ...) fprintf(stderr, "debug: sig: " fmt, ##__VA_ARGS__) #else #define DEBUG_SIG(fmt, ...) ((void) 0) #endif #define Val_none (Val_int(0)) #define caml_alloc_variant(val, tag) \ do { val = Val_int(tag); } while (0) #define caml_alloc_variant_param(val, tag, p) \ do { val = caml_alloc_small(1, tag); Field(val, 0) = (p); } while (0) #define caml_alloc_variant_param2(val, tag, p1, p2) \ do { val = caml_alloc_small(2, tag); Field(val, 0) = (p1); Field(val, 1) = (p2); } while (0) #define caml_alloc_some(val, param) \ caml_alloc_variant_param(val, 0, param) #define caml_append_list(list, tmp, e) \ do { \ tmp = caml_alloc_small(2, Tag_cons); \ Field(tmp, 0) = (e); \ Field(tmp, 1) = list; \ list = tmp; \ } while (0) #define iterate_caml_list(list, tmp) \ (tmp = (list); tmp != Val_emptylist; tmp = Field(tmp, 1)) static value caml_list_rev(value list) { CAMLparam1(list); CAMLlocal3(tmp, tmprev, listrev); listrev = tmp = Val_emptylist; for iterate_caml_list(list, tmp) { caml_append_list(listrev, tmprev, Field(tmp, 0)); } CAMLreturn(listrev); } #define SIZEOF_FINALPTR (2 * sizeof (void *)) static int __messagetype_table[] = { DBUS_MESSAGE_TYPE_INVALID, DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR, DBUS_MESSAGE_TYPE_SIGNAL, -1 }; static int __dispatch_status_table[] = { DBUS_DISPATCH_DATA_REMAINS, DBUS_DISPATCH_COMPLETE, DBUS_DISPATCH_NEED_MEMORY, -1 }; static int __bustype_table[] = { DBUS_BUS_SESSION, DBUS_BUS_SYSTEM, DBUS_BUS_STARTER, -1 }; static char *__error_table[] = { DBUS_ERROR_FAILED, DBUS_ERROR_NO_MEMORY, DBUS_ERROR_SERVICE_UNKNOWN, DBUS_ERROR_NAME_HAS_NO_OWNER, DBUS_ERROR_NO_REPLY, DBUS_ERROR_IO_ERROR, DBUS_ERROR_BAD_ADDRESS, DBUS_ERROR_NOT_SUPPORTED, DBUS_ERROR_LIMITS_EXCEEDED, DBUS_ERROR_ACCESS_DENIED, DBUS_ERROR_AUTH_FAILED, DBUS_ERROR_NO_SERVER, DBUS_ERROR_TIMEOUT, DBUS_ERROR_NO_NETWORK, DBUS_ERROR_ADDRESS_IN_USE, DBUS_ERROR_DISCONNECTED, DBUS_ERROR_INVALID_ARGS, DBUS_ERROR_FILE_NOT_FOUND, DBUS_ERROR_FILE_EXISTS, DBUS_ERROR_UNKNOWN_METHOD, DBUS_ERROR_TIMED_OUT, DBUS_ERROR_MATCH_RULE_NOT_FOUND, DBUS_ERROR_MATCH_RULE_INVALID, DBUS_ERROR_SPAWN_EXEC_FAILED, DBUS_ERROR_SPAWN_FORK_FAILED, DBUS_ERROR_SPAWN_CHILD_EXITED, DBUS_ERROR_SPAWN_CHILD_SIGNALED, DBUS_ERROR_SPAWN_FAILED, DBUS_ERROR_SPAWN_SETUP_FAILED, DBUS_ERROR_SPAWN_CONFIG_INVALID, DBUS_ERROR_SPAWN_SERVICE_INVALID, DBUS_ERROR_SPAWN_SERVICE_NOT_FOUND, DBUS_ERROR_SPAWN_PERMISSIONS_INVALID, DBUS_ERROR_SPAWN_FILE_INVALID, DBUS_ERROR_SPAWN_NO_MEMORY, DBUS_ERROR_UNIX_PROCESS_ID_UNKNOWN, DBUS_ERROR_INVALID_SIGNATURE, DBUS_ERROR_INVALID_FILE_CONTENT, DBUS_ERROR_SELINUX_SECURITY_CONTEXT_UNKNOWN, DBUS_ERROR_ADT_AUDIT_DATA_UNKNOWN, DBUS_ERROR_OBJECT_PATH_IN_USE, NULL, }; static int __type_sig_table[] = { DBUS_TYPE_BYTE, DBUS_TYPE_BOOLEAN, DBUS_TYPE_INT16, DBUS_TYPE_UINT16, DBUS_TYPE_INT32, DBUS_TYPE_UINT32, DBUS_TYPE_INT64, DBUS_TYPE_UINT64, DBUS_TYPE_DOUBLE, DBUS_TYPE_STRING, DBUS_TYPE_OBJECT_PATH, DBUS_TYPE_VARIANT, DBUS_TYPE_ARRAY, DBUS_TYPE_STRUCT, DBUS_TYPE_DICT_ENTRY, -1 }; static int __type_array_table[] = { /* +1 */ DBUS_TYPE_BYTE, DBUS_TYPE_BOOLEAN, DBUS_TYPE_INT16, DBUS_TYPE_UINT16, DBUS_TYPE_INT32, DBUS_TYPE_UINT32, DBUS_TYPE_INT64, DBUS_TYPE_UINT64, DBUS_TYPE_DOUBLE, DBUS_TYPE_STRING, DBUS_TYPE_OBJECT_PATH, DBUS_TYPE_STRUCT, DBUS_TYPE_VARIANT, DBUS_TYPE_DICT_ENTRY, DBUS_TYPE_ARRAY, -1 }; static int __type_table[] = { /* +1 */ DBUS_TYPE_BYTE, DBUS_TYPE_BOOLEAN, DBUS_TYPE_INT16, DBUS_TYPE_UINT16, DBUS_TYPE_INT32, DBUS_TYPE_UINT32, DBUS_TYPE_INT64, DBUS_TYPE_UINT64, DBUS_TYPE_DOUBLE, DBUS_TYPE_STRING, DBUS_TYPE_OBJECT_PATH, DBUS_TYPE_ARRAY, DBUS_TYPE_STRUCT, DBUS_TYPE_VARIANT, -1 }; static int find_index_equal(int searched_value, int *table) { int i; for (i = 0; table[i] != -1; i++) if (table[i] == searched_value) return i; return -1; } static int find_index_string(const char *searched, char **table) { int i; for (i = 0; table[i] != NULL; i++) if (strcmp(table[i], searched) == 0) return i; return -1; } #define DBusConnection_val(v) (*((DBusConnection **) Data_custom_val(v))) #define DBusMessage_val(v) (*((DBusMessage **) Data_custom_val(v))) #define DBusError_val(v) (*((DBusError **) Data_custom_val(v))) #define DBusPendingCall_val(v) (*((DBusPendingCall **) Data_custom_val(v))) #define DBusWatch_val(v) (*((DBusWatch **) Data_custom_val(v))) #define DBusTimeout_val(v) (*((DBusTimeout **) Data_custom_val(v))) #define voidstar_alloc(o_con, c_con, final_fct) \ do { \ o_con = caml_alloc_final(SIZEOF_FINALPTR, final_fct, \ SIZEOF_FINALPTR, 10 * SIZEOF_FINALPTR);\ *((unsigned long *) Data_custom_val(o_con)) = (unsigned long) c_con; \ } while (0) void finalize_dbus_connection(value v) { dbus_connection_close(DBusConnection_val(v)); dbus_connection_unref(DBusConnection_val(v)); } void finalize_dbus_connection_unref(value v) { dbus_connection_unref(DBusConnection_val(v)); } void finalize_dbus_message(value v) { DBusMessage *msg = DBusMessage_val(v); dbus_message_unref(msg); } void finalize_dbus_pending_call(value v) { dbus_pending_call_unref(DBusPendingCall_val(v)); } void finalize_dbus_watch(value v) { /* empty */ } void finalize_dbus_timeout(value v) { /* empty */ } static void raise_dbus_error(DBusError *error) { static value *dbus_err = NULL; value args[2]; if (!dbus_err) dbus_err = caml_named_value("dbus.error"); args[0] = caml_copy_string(error->name ? error->name : ""); args[1] = caml_copy_string(error->message ? error->message : ""); caml_raise_with_args(*dbus_err, 2, args); } static void raise_dbus_internal_error(char *s) { static value *dbus_err = NULL; if (!dbus_err) dbus_err = caml_named_value("dbus.internal_error"); caml_raise_with_string(*dbus_err, s); } static void raise_dbus_type_not_supported(char *s) { static value *dbus_err = NULL; if (!dbus_err) dbus_err = caml_named_value("dbus.type_not_supported"); caml_raise_with_string(*dbus_err, s); } /****************** signature helpers ***********/ struct stub_dbus_sig { int offset; int error; char data[256]; }; static void signature_init(struct stub_dbus_sig *sig) { sig->offset = 0; sig->error = 0; memset(sig->data, 0, 256); } static void signature_append(struct stub_dbus_sig *sig, char c) { if (sig->offset == 256) { sig->error++; return; } sig->data[sig->offset++] = c; } static int signature_has_error(struct stub_dbus_sig *sig) { return sig->error; } static char * signature_data(struct stub_dbus_sig *sig) { return sig->data; } #define CHECK_SIG_ERROR(sig) \ if (signature_has_error(sig)) \ raise_dbus_type_not_supported("signature is too big"); /****************** RANDOM **********************/ value stub_dbus_string_of_error_name(value errname) { CAMLparam1(errname); CAMLlocal1(ret); ret = caml_copy_string(__error_table[Int_val(errname)]); CAMLreturn(ret); } /******************** BUS **********************/ value stub_dbus_bus_get(value type) { CAMLparam1(type); CAMLlocal1(con); DBusConnection *c_con; DBusError error; dbus_error_init(&error); c_con = dbus_bus_get(__bustype_table[Int_val(type)], &error); if (!c_con) raise_dbus_error(&error); voidstar_alloc(con, c_con, finalize_dbus_connection_unref); CAMLreturn(con); } value stub_dbus_bus_get_private(value type) { CAMLparam1(type); CAMLlocal1(con); DBusConnection *c_con; DBusError error; dbus_error_init(&error); c_con = dbus_bus_get_private(__bustype_table[Int_val(type)], &error); if (!c_con) raise_dbus_error(&error); voidstar_alloc(con, c_con, finalize_dbus_connection); CAMLreturn(con); } value stub_dbus_bus_register(value bus) { CAMLparam1(bus); DBusError error; int ret; dbus_error_init(&error); ret = dbus_bus_register(DBusConnection_val(bus), &error); if (ret != TRUE) raise_dbus_error(&error); CAMLreturn(Val_unit); } value stub_dbus_bus_set_unique_name(value bus, value name) { CAMLparam2(bus, name); int ret; ret = dbus_bus_set_unique_name(DBusConnection_val(bus), String_val(name)); CAMLreturn(Val_bool(ret)); } value stub_dbus_bus_get_unique_name(value bus) { CAMLparam1(bus); CAMLlocal1(ret); const char *s; s = dbus_bus_get_unique_name(DBusConnection_val(bus)); ret = caml_copy_string(s); CAMLreturn(ret); } value stub_dbus_bus_request_name(value bus, value name, value flags) { CAMLparam3(bus, name, flags); DBusError error; int ret; dbus_error_init(&error); ret = dbus_bus_request_name(DBusConnection_val(bus), String_val(name), Int_val(flags), &error); if (ret == -1) raise_dbus_error(&error); CAMLreturn(Val_int(ret)); } value stub_dbus_bus_release_name(value bus, value name) { CAMLparam2(bus, name); DBusError error; int ret; dbus_error_init(&error); ret = dbus_bus_release_name(DBusConnection_val(bus), String_val(name), &error); if (ret == -1) raise_dbus_error(&error); CAMLreturn(Val_int(ret)); } value stub_dbus_bus_has_owner(value bus, value name) { CAMLparam2(bus, name); DBusError error; int ret; dbus_error_init(&error); ret = dbus_bus_name_has_owner(DBusConnection_val(bus), String_val(name), &error); if (ret != TRUE && dbus_error_is_set(&error)) raise_dbus_error(&error); CAMLreturn(Val_bool(ret == TRUE)); } value stub_dbus_bus_add_match(value bus, value s, value blocking) { CAMLparam3(bus, s, blocking); DBusError error; dbus_error_init(&error); dbus_bus_add_match(DBusConnection_val(bus), String_val(s), (Bool_val(blocking) ? &error : NULL)); if (Bool_val(blocking) && dbus_error_is_set(&error)) raise_dbus_error(&error); CAMLreturn(Val_unit); } value stub_dbus_bus_remove_match(value bus, value s, value blocking) { CAMLparam3(bus, s, blocking); DBusError error; dbus_error_init(&error); dbus_bus_remove_match(DBusConnection_val(bus), String_val(s), (Bool_val(blocking) ? &error : NULL)); if (Bool_val(blocking) && dbus_error_is_set(&error)) raise_dbus_error(&error); CAMLreturn(Val_unit); } /**************** CONNECTION *******************/ value stub_dbus_connection_send(value bus, value message) { CAMLparam2(bus, message); CAMLlocal1(serial); unsigned int c_serial; dbus_connection_send(DBusConnection_val(bus), DBusMessage_val(message), &c_serial); serial = caml_copy_int32(c_serial); CAMLreturn(serial); } value stub_dbus_connection_send_with_reply(value bus, value message, value timeout) { CAMLparam3(bus, message, timeout); CAMLlocal1(pending); DBusPendingCall *c_pending; int ret; ret = dbus_connection_send_with_reply(DBusConnection_val(bus), DBusMessage_val(message), &c_pending, Int_val(timeout)); if (!ret) { free(c_pending); raise_dbus_internal_error("dbus_connection_send_with_reply"); } voidstar_alloc(pending, c_pending, finalize_dbus_pending_call); CAMLreturn(pending); } value stub_dbus_connection_send_with_reply_and_block(value bus, value message, value timeout) { CAMLparam3(bus, message, timeout); CAMLlocal1(rmsg); DBusMessage *c_rmsg; DBusError error; dbus_error_init(&error); c_rmsg = dbus_connection_send_with_reply_and_block( DBusConnection_val(bus), DBusMessage_val(message), Int_val (timeout), &error); if (!c_rmsg) raise_dbus_error(&error); voidstar_alloc(rmsg, c_rmsg, finalize_dbus_message); CAMLreturn(rmsg); } DBusHandlerResult add_filter_callback(DBusConnection *connection, DBusMessage *message, void *userdata) { CAMLparam0(); CAMLlocal2(conn, msg); int ret; dbus_connection_ref(connection); voidstar_alloc(conn, connection, finalize_dbus_connection_unref); dbus_message_ref(message); voidstar_alloc(msg, message, finalize_dbus_message); ret = Bool_val(caml_callback2(*((value *) userdata), conn, msg)); CAMLreturn ((ret) ? DBUS_HANDLER_RESULT_HANDLED : DBUS_HANDLER_RESULT_NOT_YET_HANDLED); } static void dbus_free_filter(void *_v) { value *v = _v; caml_remove_global_root(v); free(v); } value stub_dbus_connection_add_filter(value bus, value callback) { CAMLparam2(bus, callback); value *callbackp; callbackp = malloc(sizeof(value)); if (!callbackp) caml_raise_out_of_memory(); *callbackp = callback; caml_register_global_root(callbackp); dbus_connection_add_filter(DBusConnection_val(bus), add_filter_callback, callbackp, dbus_free_filter); CAMLreturn(Val_unit); } value stub_dbus_connection_flush(value bus) { CAMLparam1(bus); dbus_connection_flush(DBusConnection_val(bus)); CAMLreturn(Val_unit); } value stub_dbus_connection_read_write(value bus, value timeout) { CAMLparam2(bus, timeout); dbus_bool_t b; caml_enter_blocking_section(); b = dbus_connection_read_write(DBusConnection_val(bus), Int_val(timeout)); caml_leave_blocking_section(); CAMLreturn(Val_bool(b)); } value stub_dbus_connection_read_write_dispatch(value bus, value timeout) { CAMLparam2(bus, timeout); dbus_bool_t b; caml_enter_blocking_section(); b = dbus_connection_read_write_dispatch(DBusConnection_val(bus), Int_val(timeout)); caml_leave_blocking_section(); CAMLreturn(Val_bool(b)); } value stub_dbus_connection_pop_message(value bus) { CAMLparam1(bus); CAMLlocal2(msg_opt, msg); DBusMessage *c_msg; msg_opt = Val_none; msg = Val_unit; caml_enter_blocking_section(); c_msg = dbus_connection_pop_message(DBusConnection_val(bus)); caml_leave_blocking_section(); if (c_msg) { voidstar_alloc(msg, c_msg, finalize_dbus_message); caml_alloc_some(msg_opt, msg); } CAMLreturn(msg_opt); } value stub_dbus_connection_get_fd(value bus) { CAMLparam1(bus); int fd, ret; ret = dbus_connection_get_unix_fd(DBusConnection_val(bus), &fd); if (ret == 0) raise_dbus_internal_error("dbus_connection_get_fd"); CAMLreturn(Val_int(fd)); } value stub_dbus_connection_dispatch(value bus) { CAMLparam1(bus); CAMLlocal1(ret); DBusDispatchStatus status; status = dbus_connection_dispatch(DBusConnection_val(bus)); caml_alloc_variant(ret, Val_int(find_index_equal(status, __dispatch_status_table))); CAMLreturn(ret); } value stub_dbus_connection_get_dispatch_status(value bus) { CAMLparam1(bus); CAMLlocal1(ret); DBusDispatchStatus status; status = dbus_connection_get_dispatch_status(DBusConnection_val(bus)); caml_alloc_variant(ret, Val_int(find_index_equal(status, __dispatch_status_table))); CAMLreturn(ret); } static dbus_bool_t watch_add_cb(DBusWatch *c_watch, void *data) { CAMLparam0(); CAMLlocal2(watch, add_cb); value *fns = data; add_cb = Field(*fns, 0); int ret; voidstar_alloc(watch, c_watch, finalize_dbus_watch); ret = Bool_val(caml_callback(add_cb, watch)); CAMLreturn(ret); } static void watch_rm_cb(DBusWatch *c_watch, void *data) { CAMLparam0(); CAMLlocal2(watch, rm_cb); value *fns = data; rm_cb = Field(*fns, 1); voidstar_alloc(watch, c_watch, finalize_dbus_watch); caml_callback(rm_cb, watch); CAMLreturn0; } static void watch_toggle_cb(DBusWatch *c_watch, void *data) { CAMLparam0(); CAMLlocal2(watch, toggle_cb); value *fns = data; toggle_cb = Field(*fns, 2); if (toggle_cb != Val_none) { voidstar_alloc(watch, c_watch, finalize_dbus_watch); caml_callback(Field(toggle_cb, 0), watch); } CAMLreturn0; } static void watch_free_cb(void *data) { value *v = data; caml_remove_global_root(v); free(v); } value stub_dbus_connection_set_watch_functions(value bus, value fns) { CAMLparam2(bus, fns); value *callbackfns; int ret; callbackfns = malloc(sizeof(value)); if (!callbackfns) caml_raise_out_of_memory(); *callbackfns = fns; caml_register_global_root(callbackfns); ret = dbus_connection_set_watch_functions(DBusConnection_val(bus), watch_add_cb, watch_rm_cb, watch_toggle_cb, (void *) callbackfns, watch_free_cb); if (!ret) caml_raise_out_of_memory(); CAMLreturn(Val_unit); } static dbus_bool_t timeout_add_cb(DBusTimeout *c_timeout, void *data) { CAMLparam0(); CAMLlocal2(timeout, add_cb); value *fns = data; add_cb = Field(*fns, 0); int ret; voidstar_alloc(timeout, c_timeout, finalize_dbus_timeout); ret = Bool_val(caml_callback(add_cb, timeout)); CAMLreturn(ret); } static void timeout_rm_cb(DBusTimeout *c_timeout, void *data) { CAMLparam0(); CAMLlocal2(timeout, rm_cb); value *fns = data; rm_cb = Field(*fns, 1); voidstar_alloc(timeout, c_timeout, finalize_dbus_timeout); caml_callback(rm_cb, timeout); CAMLreturn0; } static void timeout_toggle_cb(DBusTimeout *c_timeout, void *data) { CAMLparam0(); CAMLlocal2(timeout, toggle_cb); value *fns = data; toggle_cb = Field(*fns, 2); if (toggle_cb != Val_none) { voidstar_alloc(timeout, c_timeout, finalize_dbus_timeout); caml_callback(Field(toggle_cb, 0), timeout); } CAMLreturn0; } static void timeout_free_cb(void *data) { value *v = data; caml_remove_global_root(v); free(v); } value stub_dbus_connection_set_timeout_functions(value bus, value fns) { CAMLparam2(bus, fns); value *callbackfns; int ret; callbackfns = malloc(sizeof(value)); if (!callbackfns) caml_raise_out_of_memory(); *callbackfns = fns; caml_register_global_root(callbackfns); ret = dbus_connection_set_timeout_functions(DBusConnection_val(bus), timeout_add_cb, timeout_rm_cb, timeout_toggle_cb, (void *) callbackfns, timeout_free_cb); if (!ret) caml_raise_out_of_memory(); CAMLreturn(Val_unit); } value stub_dbus_connection_set_max_message_size(value bus, value size) { CAMLparam2(bus, size); dbus_connection_set_max_message_size(DBusConnection_val(bus), Int_val(size)); CAMLreturn(Val_unit); } value stub_dbus_connection_get_max_message_size(value bus) { CAMLparam1(bus); long ret; ret = dbus_connection_get_max_message_size(DBusConnection_val(bus)); CAMLreturn(Val_int(ret)); } value stub_dbus_connection_set_max_received_size(value bus, value size) { CAMLparam2(bus, size); dbus_connection_set_max_received_size(DBusConnection_val(bus), Int_val(size)); CAMLreturn(Val_unit); } value stub_dbus_connection_get_max_received_size(value bus) { CAMLparam1(bus); long ret; ret = dbus_connection_get_max_received_size(DBusConnection_val(bus)); CAMLreturn(Val_int(ret)); } value stub_dbus_connection_get_outgoing_size(value bus) { CAMLparam1(bus); long ret; ret = dbus_connection_get_outgoing_size(DBusConnection_val(bus)); CAMLreturn(Val_int(ret)); } value stub_dbus_connection_set_allow_anonymous(value bus, value val) { CAMLparam2(bus, val); dbus_connection_set_allow_anonymous(DBusConnection_val(bus), Bool_val(val)); CAMLreturn(Val_unit); } /****************** MESSAGE ********************/ value stub_dbus_message_create(value message_type) { CAMLparam1(message_type); CAMLlocal1(msg); DBusMessage *c_msg; int c_message_type; c_message_type = __messagetype_table[Int_val(message_type)]; c_msg = dbus_message_new(c_message_type); if (!c_msg) raise_dbus_internal_error("message_create"); voidstar_alloc(msg, c_msg, finalize_dbus_message); CAMLreturn(msg); } value stub_dbus_message_new_method_call(value destination, value path, value interface, value method) { CAMLparam4(destination, path, interface, method); CAMLlocal1(msg); DBusMessage *c_msg; c_msg = dbus_message_new_method_call(String_val(destination), String_val(path), String_val(interface), String_val(method)); if (!c_msg) raise_dbus_internal_error("message_new_method_call"); voidstar_alloc(msg, c_msg, finalize_dbus_message); CAMLreturn(msg); } value stub_dbus_message_new_method_return(value message) { CAMLparam1(message); CAMLlocal1(new_message); DBusMessage *c_new_message; c_new_message = dbus_message_new_method_return(DBusMessage_val(message)); if (!c_new_message) raise_dbus_internal_error("message_new_method_call"); voidstar_alloc(new_message, c_new_message, finalize_dbus_message); CAMLreturn(new_message); } value stub_dbus_message_new_signal(value path, value interface, value method) { CAMLparam3(path, interface, method); CAMLlocal1(msg); DBusMessage *c_msg; c_msg = dbus_message_new_signal(String_val(path), String_val(interface), String_val(method)); if (!c_msg) raise_dbus_internal_error("message_new_signal"); voidstar_alloc(msg, c_msg, finalize_dbus_message); CAMLreturn(msg); } value stub_dbus_message_new_error(value reply_to, value error_name, value error_message) { CAMLparam3(reply_to, error_name, error_message); CAMLlocal1(msg); DBusMessage *c_msg; char *errname; errname = __error_table[Int_val(error_name)]; c_msg = dbus_message_new_error(DBusMessage_val(reply_to), errname, String_val(error_message)); if (!c_msg) raise_dbus_internal_error("message_new_error"); voidstar_alloc(msg, c_msg, finalize_dbus_message); CAMLreturn(msg); } value stub_dbus_message_get_type(value message) { CAMLparam1(message); CAMLlocal1(ret); int c_type; c_type = dbus_message_get_type(DBusMessage_val(message)); ret = Val_int(find_index_equal(c_type, __messagetype_table)); CAMLreturn(ret); } #define MESSAGE_GET_ACCESSOR(type) \ value stub_dbus_message_get_##type (value message) \ { \ CAMLparam1(message); \ CAMLlocal2(v, vfield); \ const char *c_v; \ c_v = dbus_message_get_##type (DBusMessage_val(message)); \ if (!c_v) \ CAMLreturn(Val_none); \ vfield = caml_copy_string(c_v); \ caml_alloc_some(v, vfield); \ CAMLreturn(v); \ } \ #define MESSAGE_SET_ACCESSOR(type) \ value stub_dbus_message_set_##type (value message, value v) \ { \ CAMLparam2(message, v); \ dbus_message_set_##type (DBusMessage_val(message), \ String_val(v)); \ CAMLreturn(Val_unit); \ } #define MESSAGE_HAS_ACCESSOR(type) \ value stub_dbus_message_has_##type (value message, value v) \ { \ CAMLparam2(message, v); \ int ret; \ ret = dbus_message_has_##type (DBusMessage_val(message),\ String_val(v)); \ CAMLreturn(Val_bool(ret)); \ } #define MESSAGE_ACCESSOR(type) \ MESSAGE_GET_ACCESSOR(type) \ MESSAGE_SET_ACCESSOR(type) \ MESSAGE_HAS_ACCESSOR(type) #define MESSAGE_ACCESSOR_NOHAS(type) \ MESSAGE_GET_ACCESSOR(type) \ MESSAGE_SET_ACCESSOR(type) MESSAGE_ACCESSOR(path) MESSAGE_ACCESSOR(interface) MESSAGE_ACCESSOR(member) MESSAGE_ACCESSOR(destination) MESSAGE_ACCESSOR(sender) MESSAGE_GET_ACCESSOR(signature) MESSAGE_HAS_ACCESSOR(signature) /* bool no_reply */ value stub_dbus_message_get_error_name(value message) { CAMLparam1(message); CAMLlocal1(error_name); const char *errname; errname = dbus_message_get_error_name(DBusMessage_val(message)); if (!errname) error_name = Val_none; else { int index = find_index_string(errname, __error_table); caml_alloc_some(error_name, Val_int(index)); } CAMLreturn(error_name); } value stub_dbus_message_set_error_name(value message, value error_name) { CAMLparam2(message, error_name); char *errname; errname = __error_table[Int_val(error_name)]; dbus_message_set_error_name(DBusMessage_val(message), errname); CAMLreturn(Val_unit); } value stub_dbus_message_get_serial(value message) { CAMLparam1(message); CAMLlocal1(serial); int c_serial; c_serial = dbus_message_get_serial(DBusMessage_val(message)); serial = caml_copy_int32(c_serial); CAMLreturn(serial); } value stub_dbus_message_get_reply_serial(value message) { CAMLparam1(message); CAMLlocal1(serial); int c_serial; c_serial = dbus_message_get_reply_serial(DBusMessage_val(message)); serial = caml_copy_int32(c_serial); CAMLreturn(serial); } value stub_dbus_message_set_reply_serial(value message, value serial) { CAMLparam2(message, serial); unsigned int c_serial = Int32_val(serial); dbus_message_set_reply_serial(DBusMessage_val(message), c_serial); CAMLreturn(Val_unit); } value stub_dbus_message_get_auto_start(value message) { CAMLparam1(message); int ret; ret = dbus_message_get_auto_start(DBusMessage_val(message)); CAMLreturn(Val_bool(ret)); } value stub_dbus_message_set_auto_start(value message, value v) { CAMLparam2(message, v); dbus_message_set_auto_start(DBusMessage_val(message), Bool_val(v)); CAMLreturn(Val_unit); } value stub_dbus_message_get_header(value message) { CAMLparam1(message); CAMLlocal2(ret, v); ret = caml_alloc_tuple(8); v = stub_dbus_message_get_serial(message); Store_field(ret, 0, v); v = stub_dbus_message_get_type(message); Store_field(ret, 1, v); v = stub_dbus_message_get_destination(message); Store_field(ret, 2, v); v = stub_dbus_message_get_path(message); Store_field(ret, 3, v); v = stub_dbus_message_get_interface(message); Store_field(ret, 4, v); v = stub_dbus_message_get_member(message); Store_field(ret, 5, v); v = stub_dbus_message_get_error_name(message); Store_field(ret, 6, v); v = stub_dbus_message_get_sender(message); Store_field(ret, 7, v); CAMLreturn(ret); } #define IS_BASIC(ty) \ ((ty) == DBUS_TYPE_BYTE || \ (ty) == DBUS_TYPE_BOOLEAN || \ (ty) == DBUS_TYPE_UINT16 || (ty) == DBUS_TYPE_INT16 || \ (ty) == DBUS_TYPE_UINT32 || (ty) == DBUS_TYPE_INT32 || \ (ty) == DBUS_TYPE_UINT64 || (ty) == DBUS_TYPE_INT64 || \ (ty) == DBUS_TYPE_DOUBLE || \ (ty) == DBUS_TYPE_OBJECT_PATH || \ (ty) == DBUS_TYPE_STRING) static void message_append_basic(DBusMessageIter *iter, int c_type, value v) { DEBUG_APPEND("basic: %c (%d)\n", c_type, c_type); switch (c_type) { case DBUS_TYPE_BYTE: { char x; x = Int_val(v); dbus_message_iter_append_basic(iter, c_type, &x); break; } case DBUS_TYPE_BOOLEAN: { int x; x = Bool_val(v); dbus_message_iter_append_basic(iter, c_type, &x); break; } case DBUS_TYPE_UINT16: case DBUS_TYPE_INT16: { int x; x = Int_val(v); dbus_message_iter_append_basic(iter, c_type, &x); break; } case DBUS_TYPE_UINT32: case DBUS_TYPE_INT32: { int x; x = Int32_val(v); dbus_message_iter_append_basic(iter, c_type, &x); break; } case DBUS_TYPE_UINT64: case DBUS_TYPE_INT64: { unsigned long long x; x = Int64_val(v); dbus_message_iter_append_basic(iter, c_type, &x); break; } case DBUS_TYPE_DOUBLE: { double d; d = Double_val(v); dbus_message_iter_append_basic(iter, c_type, &d); break; } case DBUS_TYPE_OBJECT_PATH: case DBUS_TYPE_STRING: { char *s = strdup(String_val(v)); dbus_message_iter_append_basic(iter, c_type, &s); break; } default: break; } } static void mk_signature_structs(value vstructs, struct stub_dbus_sig *sig); static void mk_signature_arrays(value arraysig, struct stub_dbus_sig *sig); static void mk_signature_sig(value sigval, struct stub_dbus_sig *sig) { if (Is_block(sigval)) { int c_type; c_type = __type_sig_table[Tag_val(sigval) + 12]; if (c_type == DBUS_TYPE_ARRAY) { signature_append(sig, DBUS_TYPE_ARRAY); mk_signature_sig(Field(sigval, 0), sig); } else if (c_type == DBUS_TYPE_STRUCT) { signature_append(sig, '('); value list = Field(sigval, 0); for iterate_caml_list(list, list) { mk_signature_sig(Field(list, 0), sig); } signature_append(sig, ')'); } else if (c_type == DBUS_TYPE_DICT_ENTRY) { value ksig = Field(sigval, 0); value vsig = Field(sigval, 1); signature_append(sig, 'a'); signature_append(sig, '{'); mk_signature_sig(ksig, sig); mk_signature_sig(vsig, sig); signature_append(sig, '}'); } } else { int vsig = __type_sig_table[Int_val(sigval)]; signature_append(sig, vsig); } } static void mk_signature_dict(value ksig, value vsig, struct stub_dbus_sig *sig) { signature_append(sig, '{'); mk_signature_sig(ksig, sig); mk_signature_sig(vsig, sig); signature_append(sig, '}'); DEBUG_SIG("dict: %s (offset=%d)\n", s, offset); } static void mk_signature_array(value ty, struct stub_dbus_sig *sig) { int array_c_type; signature_append(sig, DBUS_TYPE_ARRAY); array_c_type = __type_array_table[Tag_val(ty)]; if (IS_BASIC(array_c_type) || array_c_type == DBUS_TYPE_VARIANT) { signature_append(sig, array_c_type); } else if (array_c_type == DBUS_TYPE_DICT_ENTRY) { value sigtuple = Field(ty, 0); mk_signature_dict(Field(sigtuple, 0), Field(sigtuple, 1), sig); } else if (array_c_type == DBUS_TYPE_STRUCT) { mk_signature_structs(ty, sig); } else if (array_c_type == DBUS_TYPE_ARRAY) { mk_signature_arrays(Field(ty, 0), sig); } else { raise_dbus_type_not_supported("signature of array of unknown types"); } DEBUG_SIG("array: %s (offset=%d)\n", s, offset); } static void mk_signature_struct(value list, struct stub_dbus_sig *sig) { value v; signature_append(sig, '('); for iterate_caml_list(list, list) { int c_type; v = Field(list, 0); c_type = __type_table[Tag_val(v)]; if (IS_BASIC(c_type)) { signature_append(sig, c_type); } else { signature_append(sig, '#'); } } signature_append(sig, ')'); DEBUG_SIG("struct: %s (offset=%d)\n", s, offset); } static void mk_signature_structs(value vstructs, struct stub_dbus_sig *sig) { value list = Field(vstructs, 0); /* Structs signature */ signature_append(sig, '('); for iterate_caml_list(list, list) { mk_signature_sig(Field(list, 0), sig); } signature_append(sig, ')'); DEBUG_SIG("structs: %s (offset=%d)\n", s, offset); } static void mk_signature_arrays(value arraysig, struct stub_dbus_sig *sig) { signature_append(sig, 'a'); mk_signature_sig(arraysig, sig); DEBUG_SIG("arrays: %s (offset=%d)\n", s, offset); } static void mk_signature_variant(value ty, struct stub_dbus_sig *sig) { int c_sub_type; c_sub_type = __type_table[Tag_val(ty)]; DEBUG_APPEND("variant: %c (%d)\n", c_sub_type, c_sub_type); if (IS_BASIC(c_sub_type)) { signature_append(sig, c_sub_type); } else if (c_sub_type == DBUS_TYPE_ARRAY) { mk_signature_array(Field(ty, 0), sig); } else if (c_sub_type == DBUS_TYPE_STRUCT) { mk_signature_struct(Field(ty, 0), sig); } else { /* FIXME once we know howto generate complex signature out of dbus.ty this can be removed */ raise_dbus_type_not_supported("container type in variant"); } DEBUG_SIG("variant: %s (offset=%d)\n", s, offset); } /* forward declaration since we use them recursively in array, struct .. */ static value message_append_one(DBusMessageIter *iter, value v); static value message_append_list(DBusMessageIter *iter, value list); static value message_append_variant(DBusMessageIter *iter, value v); static value message_append_struct(DBusMessageIter *iter, value tylist); /** message_append array take the array values and append them to the iter */ static value message_append_array(DBusMessageIter *iter, value array) { CAMLparam1(array); CAMLlocal1(tmp); DBusMessageIter sub; int array_c_type; struct stub_dbus_sig sig; signature_init(&sig); array_c_type = __type_array_table[Tag_val(array)]; DEBUG_APPEND("array: %c (%d)\n", array_c_type, array_c_type); if (IS_BASIC(array_c_type)) { signature_append(&sig, array_c_type); CHECK_SIG_ERROR(&sig); dbus_message_iter_open_container(iter, DBUS_TYPE_ARRAY, signature_data(&sig), &sub); for iterate_caml_list(Field(array, 0), tmp) { message_append_basic(&sub, array_c_type, Field(tmp, 0)); } dbus_message_iter_close_container(iter, &sub); } else if (array_c_type == DBUS_TYPE_STRUCT) { /* ocaml representation: Structs of ty_sig list * (ty list list) */ mk_signature_structs(array, &sig); CHECK_SIG_ERROR(&sig); dbus_message_iter_open_container(iter, DBUS_TYPE_ARRAY, signature_data(&sig), &sub); for iterate_caml_list(Field(array, 1), tmp) { message_append_struct(&sub, Field(tmp, 0)); } dbus_message_iter_close_container(iter, &sub); } else if (array_c_type == DBUS_TYPE_VARIANT) { signature_append(&sig, 'v'); CHECK_SIG_ERROR(&sig); dbus_message_iter_open_container(iter, DBUS_TYPE_ARRAY, signature_data(&sig), &sub); for iterate_caml_list(Field(array, 0), tmp) { message_append_variant(&sub, Field(tmp, 0)); } dbus_message_iter_close_container(iter, &sub); } else if (array_c_type == DBUS_TYPE_DICT_ENTRY) { /* ocaml representation: Dicts of (ty_sig * ty_sig) * ((ty * ty) list) */ value sigtuple = Field(array, 0); if (Is_block(Field(sigtuple, 0))) raise_dbus_type_not_supported("dict entry key cannot be a container type"); mk_signature_dict(Field(sigtuple, 0), Field(sigtuple, 1), &sig); CHECK_SIG_ERROR(&sig); dbus_message_iter_open_container(iter, DBUS_TYPE_ARRAY, signature_data(&sig), &sub); for iterate_caml_list(Field(array, 1), tmp) { DBusMessageIter subitem; value tuple = Field(tmp, 0); dbus_message_iter_open_container(&sub, DBUS_TYPE_DICT_ENTRY, NULL, &subitem); message_append_one(&subitem, Field(tuple, 0)); message_append_one(&subitem, Field(tuple, 1)); dbus_message_iter_close_container(&sub, &subitem); } dbus_message_iter_close_container(iter, &sub); } else if (array_c_type == DBUS_TYPE_ARRAY) { /* ocaml representation: Arrays of ty_sig * ty_array list */ int sigty; mk_signature_arrays(Field(array, 0), &sig); CHECK_SIG_ERROR(&sig); dbus_message_iter_open_container(iter, DBUS_TYPE_ARRAY, signature_data(&sig), &sub); for iterate_caml_list(Field(array, 1), tmp) { message_append_array(&sub, Field(tmp, 0)); } dbus_message_iter_close_container(iter, &sub); } else raise_dbus_internal_error("append array: unknown type"); CAMLreturn(Val_unit); } static value message_append_variant(DBusMessageIter *iter, value v) { CAMLparam1(v); DBusMessageIter sub; struct stub_dbus_sig sig; signature_init(&sig); mk_signature_variant(v, &sig); CHECK_SIG_ERROR(&sig); dbus_message_iter_open_container(iter, DBUS_TYPE_VARIANT, signature_data(&sig), &sub); message_append_one(&sub, v); dbus_message_iter_close_container(iter, &sub); CAMLreturn(Val_unit); } static value message_append_struct(DBusMessageIter *iter, value tylist) { CAMLparam1(tylist); DBusMessageIter sub; dbus_message_iter_open_container(iter, DBUS_TYPE_STRUCT, NULL, &sub); message_append_list(&sub, tylist); dbus_message_iter_close_container(iter, &sub); CAMLreturn(Val_unit); } /** message_append_one take ony DBus.ty and append it to the iterator */ static value message_append_one(DBusMessageIter *iter, value v) { CAMLparam1(v); int c_type; c_type = __type_table[Tag_val(v)]; DEBUG_APPEND("one: %c (%d)\n", c_type, c_type); v = Field(v, 0); /* after this point v represent the contents of the ocaml variant type */ if (IS_BASIC(c_type)) { message_append_basic(iter, c_type, v); } else if (c_type == DBUS_TYPE_ARRAY) { message_append_array(iter, v); } else if (c_type == DBUS_TYPE_STRUCT) { message_append_struct(iter, v); } else if (c_type == DBUS_TYPE_VARIANT) { message_append_variant(iter, v); } else { /*printf("c_type: %c (%d)\n", c_type, c_type); */ raise_dbus_internal_error("appending fail: unknown type"); } CAMLreturn(Val_unit); } /** message_append_list take a list of DBus.ty and append them to the iterator */ static value message_append_list(DBusMessageIter *iter, value list) { CAMLparam1(list); CAMLlocal2(tmp, v); DEBUG_APPEND("list\n"); for iterate_caml_list(list, tmp) { v = Field(tmp, 0); message_append_one(iter, v); } CAMLreturn(Val_unit); } value stub_dbus_message_append(value message, value list) { CAMLparam2(message, list); DBusMessage *c_msg; DBusMessageIter iter; c_msg = DBusMessage_val(message); dbus_message_iter_init_append(c_msg, &iter); message_append_list(&iter, list); CAMLreturn(Val_unit); } static value message_get_one(DBusMessageIter *iter, int *subtype); static value message_get_list(DBusMessageIter *iter, int initial_has_next, int alloc_variant); static value message_get_array(DBusMessageIter *iter, int array_c_type, int initial_has_next); static value message_get_basic(DBusMessageIter *iter, int c_type) { CAMLparam0(); CAMLlocal1(v); DEBUG_GET("basic: %c (%d)\n", c_type, c_type); switch (c_type) { case DBUS_TYPE_BYTE: { char c; dbus_message_iter_get_basic(iter, &c); v = Val_int(c); break; } case DBUS_TYPE_BOOLEAN: { int i; dbus_message_iter_get_basic(iter, &i); v = Val_bool(i); break; } case DBUS_TYPE_UINT16: case DBUS_TYPE_INT16: { int i; dbus_message_iter_get_basic(iter, &i); v = Val_int(i); break; } case DBUS_TYPE_UINT32: case DBUS_TYPE_INT32: { int i; dbus_message_iter_get_basic(iter, &i); v = caml_copy_int32(i); break; } case DBUS_TYPE_UINT64: case DBUS_TYPE_INT64: { unsigned long long ld; dbus_message_iter_get_basic(iter, &ld); v = caml_copy_int64(ld); break; } case DBUS_TYPE_OBJECT_PATH: case DBUS_TYPE_STRING: { char *s; dbus_message_iter_get_basic(iter, &s); v = caml_copy_string(s); break; } case DBUS_TYPE_DOUBLE: { double d; dbus_message_iter_get_basic(iter, &d); v = caml_copy_double(d); break; } default: v = Val_int(0); break; } CAMLreturn(v); } static value message_get_array_struct(DBusMessageIter *iter) { CAMLparam0(); CAMLlocal3(tmp, list, v); int has_next; DEBUG_GET("array_struct\n"); list = tmp = Val_emptylist; has_next = dbus_message_iter_get_arg_type(iter) != DBUS_TYPE_INVALID; while (has_next) { DBusMessageIter sub; dbus_message_iter_recurse(iter, &sub); v = message_get_list(&sub, 1, 1); caml_append_list(list, tmp, v); has_next = dbus_message_iter_next(iter); } list = caml_list_rev(list); CAMLreturn(list); } static value message_get_array_array(DBusMessageIter *iter) { CAMLparam0(); CAMLlocal3(tmp, list, v); int has_next; DEBUG_GET("array_array\n"); list = tmp = Val_emptylist; has_next = dbus_message_iter_get_arg_type(iter) != DBUS_TYPE_INVALID; while (has_next) { DBusMessageIter sub; int element_ty; element_ty = dbus_message_iter_get_element_type(iter); dbus_message_iter_recurse(iter, &sub); v = message_get_array(&sub, element_ty, 1); caml_append_list(list, tmp, v); has_next = dbus_message_iter_next(iter); } list = caml_list_rev(list); CAMLreturn(list); } static value message_get_array_dict(DBusMessageIter *iter) { CAMLparam0(); CAMLlocal5(tmp, list, v, r, tuple); int has_next; DEBUG_GET("array_dict\n"); list = tmp = Val_emptylist; has_next = dbus_message_iter_get_arg_type(iter) != DBUS_TYPE_INVALID; while (has_next) { DBusMessageIter sub; int subtype; /* alloc empty tuple */ tuple = caml_alloc_tuple(2); Field(tuple, 0) = Val_unit; Field(tuple, 1) = Val_unit; dbus_message_iter_recurse(iter, &sub); v = message_get_one(&sub, &subtype); caml_alloc_variant_param(r, subtype, v); Store_field(tuple, 0, r); dbus_message_iter_next(&sub); v = message_get_one(&sub, &subtype); caml_alloc_variant_param(r, subtype, v); Store_field(tuple, 1, r); caml_append_list(list, tmp, tuple); has_next = dbus_message_iter_next(iter); } list = caml_list_rev(list); CAMLreturn(list); } /* iter is on the values of the array */ static value message_get_array(DBusMessageIter *iter, int array_c_type, int initial_has_next) { CAMLparam0(); CAMLlocal2(v, r); int type; DEBUG_GET("array: %c (%d)\n", array_c_type, array_c_type); type = find_index_equal(array_c_type, __type_array_table); if (IS_BASIC(array_c_type)) { /* basic are all in the form : BASIC of list */ v = message_get_list(iter, dbus_message_iter_get_arg_type(iter) != DBUS_TYPE_INVALID, 0); caml_alloc_variant_param(r, type, v); } else if (array_c_type == DBUS_TYPE_DICT_ENTRY) { #if 0 /* create the signature */ dbus_message_iter_recurse(iter, &sub); do { int c_type, type; c_type = dbus_message_iter_get_arg_type(&sub); if (IS_BASIC(c_type) || c_type == DBUS_TYPE_VARIANT) type = find_index_equal(c_type, __type_sig_table); else caml_failwith("dict entry are container ?"); if (offset > 1) continue; Field(sig, offset) = Val_int(type); offset++; } while (dbus_message_iter_next(&sub)); #endif v = message_get_array_dict(iter); caml_alloc_variant_param2(r, type, Val_unit, v); /* XXX: the signature generated is useless, the type are self sufficient to determine the signature. should be fixed someday for completeness. */ v = caml_alloc_tuple(2); Field(v, 0) = Val_int(0); /* FIXME */ Field(v, 1) = Val_int(0); /* FIXME */ Store_field(r, 0, v); } else if (array_c_type == DBUS_TYPE_VARIANT) { v = message_get_list(iter, dbus_message_iter_get_arg_type(iter) != DBUS_TYPE_INVALID, 1); caml_alloc_variant_param(r, type, v); } else if (array_c_type == DBUS_TYPE_STRUCT) { v = message_get_array_struct(iter); caml_alloc_variant_param2(r, type, Val_emptylist, v); /* Structs of ([], v) */ } else if (array_c_type == DBUS_TYPE_ARRAY) { v = message_get_array_array(iter); caml_alloc_variant_param2(r, type, Val_int(0), v); } else { /*printf("array_c_type: unknown %c (%d)\n", array_c_type, array_c_type); */ caml_alloc_variant(r, 0); /* r = Dbus.Ty(Unknown) */ } CAMLreturn(r); } static value message_get_struct(DBusMessageIter *iter, int initial_has_next) { CAMLparam0(); value v; DEBUG_GET("struct\n"); v = message_get_list(iter, 1, 1); CAMLreturn(v); } /** dbus_ty_one_from_c returns one value beeing the raw representation of * the type. meaning it's not tagged for use as an ocaml variant type. */ static value message_get_one(DBusMessageIter *iter, int *subtype) { CAMLparam0(); CAMLlocal1(v); int c_type, type; c_type = dbus_message_iter_get_arg_type(iter); DEBUG_GET("one: %c (%d)\n", c_type, c_type); type = find_index_equal(c_type, __type_table); v = Val_unit; if (IS_BASIC(c_type)) { v = message_get_basic(iter, c_type); } else if (c_type == DBUS_TYPE_ARRAY) { DBusMessageIter sub; dbus_message_iter_recurse(iter, &sub); v = message_get_array(&sub, dbus_message_iter_get_element_type(iter), 1); } else if (c_type == DBUS_TYPE_STRUCT) { DBusMessageIter sub; dbus_message_iter_recurse(iter, &sub); v = message_get_struct(&sub, 1); } else if (c_type == DBUS_TYPE_VARIANT) { DBusMessageIter sub; int subtype; value r; dbus_message_iter_recurse(iter, &sub); v = message_get_one(&sub, &subtype); caml_alloc_variant_param(r, subtype, v); v = r; } else { caml_alloc_variant(v, 0); } if (subtype) *subtype = type; CAMLreturn(v); } /** dbus_ty_list_from_c returns a caml list of value. * if alloc_variant is true, then we allocated the ocaml variant-type tag. List of Dbus.ty * otherwise, we allocate a raw list of values. List of string, List of int, etc */ static value message_get_list(DBusMessageIter *iter, int initial_has_next, int alloc_variant) { CAMLparam0(); CAMLlocal4(tmp, list, v, r); int has_next; DEBUG_GET("list: alloc_variant=%d\n", alloc_variant); /* initialize local caml values */ tmp = list = Val_emptylist; r = Val_unit; v = Val_unit; has_next = initial_has_next; while (has_next) { int subtype; v = message_get_one(iter, &subtype); if (alloc_variant) { caml_alloc_variant_param(r, subtype, v); } caml_append_list(list, tmp, (alloc_variant ? r : v)); has_next = dbus_message_iter_next(iter); } list = caml_list_rev(list); CAMLreturn(list); } value stub_dbus_message_get(value message) { CAMLparam1(message); CAMLlocal1(v); DBusMessage *c_msg; DBusMessageIter args; int has_next; c_msg = DBusMessage_val(message); has_next = dbus_message_iter_init(c_msg, &args); v = message_get_list(&args, has_next, 1); CAMLreturn(v); } value stub_dbus_message_is_signal(value message, value interface, value signal_name) { CAMLparam3(message, interface, signal_name); int ret; ret = dbus_message_is_signal(DBusMessage_val(message), String_val(interface), String_val(signal_name)); CAMLreturn(Val_bool(ret)); } value stub_dbus_message_is_method_call(value message, value interface, value method_name) { CAMLparam3(message, interface, method_name); int ret; ret = dbus_message_is_method_call(DBusMessage_val(message), String_val(interface), String_val(method_name)); CAMLreturn(Val_bool(ret)); } value stub_dbus_message_is_error(value message, value error_name) { CAMLparam2(message, error_name); int ret; ret = dbus_message_is_error(DBusMessage_val(message), String_val(error_name)); CAMLreturn(Val_bool(ret)); } value stub_dbus_message_marshal(value message) { CAMLparam1(message); CAMLlocal1(msgstr); char *c_msgstr; int c_msglen; if (!dbus_message_marshal(DBusMessage_val(message), &c_msgstr, &c_msglen)) caml_raise_out_of_memory(); msgstr = caml_alloc_string(c_msglen); memcpy(String_val(msgstr), c_msgstr, c_msglen); CAMLreturn(msgstr); } /**************** PENDING CALL ******************/ value stub_dbus_pending_call_block(value pending) { CAMLparam1(pending); dbus_pending_call_block(DBusPendingCall_val(pending)); CAMLreturn(Val_unit); } value stub_dbus_pending_call_cancel(value pending) { CAMLparam1(pending); dbus_pending_call_cancel(DBusPendingCall_val(pending)); CAMLreturn(Val_unit); } value stub_dbus_pending_call_get_completed(value pending) { CAMLparam1(pending); int ret; ret = dbus_pending_call_get_completed(DBusPendingCall_val(pending)); CAMLreturn(Val_bool(ret)); } value stub_dbus_pending_call_steal_reply(value pending) { CAMLparam1(pending); CAMLlocal1(message); DBusMessage *c_message; c_message = dbus_pending_call_steal_reply(DBusPendingCall_val(pending)); if (!c_message) raise_dbus_internal_error("dbus_pending_call_steal_reply"); voidstar_alloc(message, c_message, finalize_dbus_message); CAMLreturn(message); } value stub_dbus_watch_get_unix_fd(value watch) { CAMLparam1(watch); int c_fd; c_fd = dbus_watch_get_unix_fd(DBusWatch_val(watch)); CAMLreturn(Val_int(c_fd)); } value stub_dbus_watch_get_enabled(value watch) { CAMLparam1(watch); int ret; ret = dbus_watch_get_enabled(DBusWatch_val(watch)); CAMLreturn(Val_bool(ret)); } value stub_dbus_watch_get_flags(value watch) { CAMLparam1(watch); CAMLlocal2(flags, tmp); unsigned int c_flags; flags = Val_emptylist; c_flags = dbus_watch_get_flags(DBusWatch_val(watch)); if (c_flags & DBUS_WATCH_READABLE) { caml_append_list(flags, tmp, Val_int(0)); } if (c_flags & DBUS_WATCH_WRITABLE) { caml_append_list(flags, tmp, Val_int(1)); } CAMLreturn(flags); } value stub_dbus_watch_handle(value watch, value flags) { CAMLparam2(watch, flags); unsigned int c_flags; for (c_flags = 0; flags != Val_emptylist; flags = Field(flags, 1)) { switch (Int_val(Field(flags, 0))) { case 0: c_flags |= DBUS_WATCH_READABLE; break; case 1: c_flags |= DBUS_WATCH_WRITABLE; break; default: /* ouphfm */ break; } } dbus_watch_handle(DBusWatch_val(watch), c_flags); CAMLreturn(Val_unit); } value stub_dbus_timeout_get_interval(value timeout) { CAMLparam1(timeout); int ret; ret = dbus_timeout_get_interval(DBusTimeout_val(timeout)); CAMLreturn(Val_int(ret)); } value stub_dbus_timeout_handle(value timeout) { CAMLparam1(timeout); int ret; ret = dbus_timeout_handle(DBusTimeout_val(timeout)); CAMLreturn(Val_bool(ret)); } value stub_dbus_timeout_get_enabled(value timeout) { CAMLparam1(timeout); int ret; ret = dbus_timeout_get_enabled(DBusTimeout_val(timeout)); CAMLreturn(Val_bool(ret)); } ocaml_dbus-0.29/example.ml000066400000000000000000000164461125665546200155700ustar00rootroot00000000000000let nm_interface = "org.freedesktop.NetworkManager" let nm_interface_device = "org.freedesktop.NetworkManager.Device" let nm_name = nm_interface let nm_path = "/org/freedesktop/NetworkManager" let notif_interface = "org.freedesktop.Notifications" let notif_name = notif_interface let notif_path = "/org/freedesktop/Notifications" let print_dbus_ty_list l = List.iter (fun o -> Printf.printf "%s\n" (DBus.string_of_ty o)) l let send_msg ~bus ~destination ~path ~intf ~serv ~params = let msg = DBus.Message.new_method_call destination path intf serv in DBus.Message.append msg params; (*print_dbus_ty_list (DBus.Message.get msg);*) let r = DBus.Connection.send_with_reply_and_block bus msg (-1) in let l = DBus.Message.get r in l (*****************************************************************************) (****************** NetworkManager daemon ************************************) (*****************************************************************************) let send_nm_msg = send_msg ~destination:nm_name ~path:nm_path ~intf:nm_interface let send_nm_device_msg ~dev ~intf = send_msg ~destination:nm_name ~path:dev ~intf let example_nm () = let bus = DBus.Bus.get DBus.Bus.System in let devices = send_nm_msg ~bus ~serv:"GetDevices" ~params:[] in match devices with | [ DBus.Array (DBus.ObjectPaths devs) ] -> List.iter (fun dev -> Printf.printf "device: %s\n" dev; let intf = "org.freedesktop.DBus.Properties" in let params1 = [ DBus.String "org.freedesktop.NetworkManager.Device"; DBus.String "HwAddress"; ] in let params2 = [ DBus.String "org.freedesktop.NetworkManager.Device"; DBus.String "Interface"; ] in let ret1 = send_nm_device_msg ~bus ~dev ~intf ~serv:"Get" ~params:params1 in let ret2 = send_nm_device_msg ~bus ~dev ~intf ~serv:"Get" ~params:params2 in print_dbus_ty_list ret1; print_dbus_ty_list ret2; ) devs; () | _ -> Printf.eprintf "unexpected reply from GetDevices"; exit 1 (*****************************************************************************) (****************** Notifications daemon *************************************) (*****************************************************************************) let send_notif_msg = send_msg ~destination:notif_name ~path:notif_path ~intf:notif_interface let example_notification () = let bus = DBus.Bus.get DBus.Bus.Session in let params = [ DBus.String "y"; DBus.UInt32 1l; DBus.String "x"; DBus.String "z"; DBus.String "w"; DBus.Array (DBus.Strings []); DBus.Array (DBus.Dicts ((DBus.SigString, DBus.SigVariant), [])); DBus.Int32 4000l; ] in let r = send_notif_msg ~bus ~serv:"Notify" ~params in print_dbus_ty_list r; () (*****************************************************************************) (****************** Test Packets *********************************************) (*****************************************************************************) let test () = Printf.printf "########## test 1 ########\n%!"; let msg = DBus.Message.new_method_call notif_name notif_path notif_interface "X" in let params = [ DBus.String "abc"; DBus.Array (DBus.Strings [ "abc"; "def" ]); DBus.Variant (DBus.Int32 1l); DBus.Struct [ DBus.String "abc"; DBus.Int64 10L ]; DBus.Array (DBus.ObjectPaths [ "/abc"; "/def"; ]); DBus.Array (DBus.Variants [ DBus.String "abc"; DBus.Int32 400l ]); DBus.Array (DBus.Arrays (DBus.SigString, [ DBus.Strings [ "x" ]; DBus.Strings [ "y"; "z" ] ])); DBus.Array (DBus.Arrays (DBus.SigInt64, [ DBus.Int64s [ 10L; 24L ]; DBus.Int64s [ 54L; 12L ]; ])); DBus.Array (DBus.Dicts ((DBus.SigString, DBus.SigString), [ DBus.String "abc", DBus.String "def"; DBus.String "2k", DBus.String "2v" ])); DBus.Array (DBus.Structs ([ DBus.SigString; DBus.SigString; DBus.SigInt32 ], [ [ DBus.String "abc"; DBus.String "def"; DBus.Int32 10l ]; [ DBus.String "xxx"; DBus.String "yzy"; DBus.Int32 2901l ]; ])) ] in DBus.Message.append msg params; print_dbus_ty_list (DBus.Message.get msg); Printf.printf "########## test 2 ########\n%!"; let msg = DBus.Message.new_method_call notif_name notif_path notif_interface "X" in let params = [ DBus.Array (DBus.Strings [ "abc" ]); DBus.Array (DBus.Dicts ((DBus.SigString, DBus.SigString), [ (DBus.String "key", DBus.String "value") ])); DBus.Array (DBus.Variants [ DBus.String "abc" ]); DBus.Variant (DBus.Array (DBus.Strings [ "abc" ])); DBus.Variant (DBus.Struct [ DBus.String "abc"; DBus.Int64 10L ]); DBus.Array (DBus.Structs ([ DBus.SigString ], [ [ DBus.String "x" ]; [ DBus.String "y" ] ])); DBus.Array (DBus.Dicts ((DBus.SigString, DBus.SigArray DBus.SigString), [ (DBus.String "x", DBus.Array (DBus.Strings [ "abc"; "def" ]) ) ] )); ] in DBus.Message.append msg params; print_dbus_ty_list (DBus.Message.get msg); Printf.printf "########## test 3 ########\n%!"; let msg = DBus.Message.new_method_call notif_name notif_path notif_interface "X" in let indictsig = (DBus.SigString, DBus.SigBool) in let outdictsig = (DBus.SigString, DBus.SigDict (fst indictsig, snd indictsig)) in let structsig = [ DBus.SigString; DBus.SigInt32 ] in let params = [ DBus.Array (DBus.Dicts (outdictsig, [ (DBus.String "x", DBus.Array (DBus.Dicts (indictsig, [ (DBus.String "x", DBus.Bool true) ]))) ])); DBus.Variant (DBus.Array (DBus.Dicts (outdictsig, [ (DBus.String "x", DBus.Array (DBus.Dicts (indictsig, [ (DBus.String "x", DBus.Bool true) ]))) ]))); DBus.Variant (DBus.Array (DBus.Variants [ DBus.String "abc"; DBus.Int32 23l ])); DBus.Variant (DBus.Array (DBus.Arrays (DBus.SigString, [ DBus.Strings [ "a"; "b"; "c" ]; DBus.Strings [ "x"; "y"; "z" ] ]))); DBus.Array (DBus.Arrays (DBus.SigStruct structsig, [ DBus.Structs (structsig, [ [ DBus.String "lollilol"; DBus.Int32 2901l ] ]) ] )); ] in DBus.Message.append msg params; print_dbus_ty_list (DBus.Message.get msg); () (*****************************************************************************) (****************** Request Name *********************************************) (*****************************************************************************) let service () = let bus = DBus.Bus.get DBus.Bus.Session in let serv = "org.test.dbus.ocaml.bindings" in let rep = DBus.Bus.request_name bus serv [ DBus.Bus.DoNotQueue ] in let repstr = match rep with | DBus.Bus.PrimaryOwner -> "primary ownwer" | DBus.Bus.InQueue -> "in queue" | DBus.Bus.Exists -> "exists" | DBus.Bus.AlreadyOwner -> "already owner" | DBus.Bus.ReqUnknown i -> Printf.sprintf "unknown %d" i in Printf.printf "grabbing %s : %s\n" serv repstr; let rep = DBus.Bus.release_name bus serv in let repstr = match rep with | DBus.Bus.Released -> "released" | DBus.Bus.NonExistent -> "non existent" | DBus.Bus.NotOwner -> "not owner" | DBus.Bus.RelUnknown i -> Printf.sprintf "unknown %d" i in Printf.printf "releasing %s : %s\n" serv repstr; () (*****************************************************************************) (*****************************************************************************) (*****************************************************************************) let () = match Sys.argv.(1) with | "nm" -> example_nm (); | "notification" -> example_notification (); | "avahi" -> () | "test" -> test () | "service" -> service () | _ -> () ocaml_dbus-0.29/example_avahi.ml000066400000000000000000000136701125665546200167340ustar00rootroot00000000000000(* Browse the local network for ssh services using Avahi and D-Bus. * There is *zero* documentation for this. I examined a lot of code * to do this, and the following page was also very helpful: * http://www.amk.ca/diary/2007/04/rough_notes_python_and_dbus.html * See also the DBus API reference: * http://dbus.freedesktop.org/doc/dbus/api/html/index.html * See also Dan Berrange's Perl bindings: * http://search.cpan.org/src/DANBERR/Net-DBus-0.33.5/lib/Net/ * * By Richard W.M. Jones or . * PUBLIC DOMAIN example code. *) open Printf open DBus let debug = true let service = "_ssh._tcp" let rec print_msg msg = (match Message.get_type msg with | Message.Invalid -> printf "Invalid"; | Message.Method_call -> printf "Method_call"; | Message.Method_return -> printf "Method_return"; | Message.Error -> printf "Error"; | Message.Signal -> printf "Signal"); let print_opt f name = match f msg with | None -> () | Some value -> printf " %s=%S" name value in print_opt Message.get_member "member"; print_opt Message.get_path "path"; print_opt Message.get_interface "interface"; print_opt Message.get_sender "sender"; let fields = Message.get msg in printf "("; print_fields fields; printf ")\n%!"; and print_fields fields = printf "%s" (String.concat ", " (List.map string_of_ty fields)) (* Perform a synchronous call to an object method. *) let call_method ~bus ~name ~path ~interface ~methd args = (* Create the method_call message. *) let msg = Message.new_method_call name path interface methd in Message.append msg args; (* Send the message, get reply. *) let r = Connection.send_with_reply_and_block bus msg (-1) in Message.get r (* A service has appeared on the network. Resolve its IP address, etc. *) let resolve_service bus sb_path msg = let fields = Message.get msg in match fields with (* match fields in the ItemNew message from ServiceBrowser. *) | [(Int32 _) as interface; (Int32 _) as protocol; (String _) as name; (String _) as service; (String _) as domain; _ (* flags *)] -> (* Create a new ServiceResolver object which is used to resolve * the actual locations of network services found by the ServiceBrowser. *) let sr = call_method ~bus ~name:"org.freedesktop.Avahi" ~path:"/" ~interface:"org.freedesktop.Avahi.Server" ~methd:"ServiceResolverNew" [ interface; protocol; name; service; domain; Int32 (-1_l); (* AVAHI_PROTO_UNSPEC *) UInt32 0_l; (* flags *) ] in let sr_path = match sr with | [ ObjectPath path ] -> path | _ -> assert false in if debug then eprintf "ServiceResolver path = %S\n%!" sr_path; (* Add a match rule so we see these all signals of interest. *) Bus.add_match bus (String.concat "," [ "type='signal'"; "sender='org.freedesktop.Avahi.ServiceResolver'"; "path='" ^ sr_path ^ "'"; ]) true; () | _ -> prerr_endline "warning: unexpected message contents of ItemNew signal"; () (* This is called when we get a message/signal. Could be from the * (global) ServiceBrowser or any of the ServiceResolver objects. *) let got_message bus sb_path msg = if debug then print_msg msg; let typ = Message.get_type msg in let member = match Message.get_member msg with None -> "" | Some m -> m in let interface = match Message.get_interface msg with None -> "" | Some m -> m in if typ = Message.Signal then ( match interface, member with | "org.freedesktop.Avahi.ServiceBrowser", "CacheExhausted" -> () | "org.freedesktop.Avahi.ServiceBrowser", "ItemNew" -> (* New service has appeared, start to resolve it. *) resolve_service bus sb_path msg | "org.freedesktop.Avahi.ServiceBrowser", "ItemRemove" -> (* XXX Service has disappeared. *) () | "org.freedesktop.Avahi.ServiceBrowser", "AllForNow" -> () | "org.freedesktop.Avahi.ServiceResolver", "Found" -> (* Resolver has resolved the name of a previously appearing service. *) (* XXX *) () | "org.freedesktop.DBus", _ -> () | interface, member -> eprintf "warning: ignored unknown message %s from %s\n%!" member interface ); true (* Store the connection bus. However don't bother * connecting to D-Bus at all until the user opens the connection * dialog for the first time. *) let connection = ref None (* Create system bus object, and create the service * browser. XXX Probably not robust if the daemon restarts. *) let connect () = match !connection with | Some bus -> (bus, false) | None -> let bus = Bus.get Bus.System in (* Create a new ServiceBrowser object which emits a signal whenever * a new network service of the type specified is found on the network. *) let sb = call_method ~bus ~name:"org.freedesktop.Avahi" ~path:"/" ~interface:"org.freedesktop.Avahi.Server" ~methd:"ServiceBrowserNew" [ Int32 (-1_l); (* interface, -1=AVAHI_IF_UNSPEC *) Int32 0_l; (* 0=IPv4, 1=IPv6 *) String service; (* service type *) String ""; (* XXX call GetDomainName() *) UInt32 0_l; (* flags *) ] in let sb_path = match sb with | [ ObjectPath path ] -> path | _ -> assert false in if debug then eprintf "ServiceBrowser path = %S\n%!" sb_path; (* Register a callback to accept the signals. *) (* XXX This leaks memory because it is never freed. *) Connection.add_filter bus ( fun bus msg -> got_message bus sb_path msg ); (* Add a match rule so we see these all signals of interest. *) Bus.add_match bus (String.concat "," [ "type='signal'"; "sender='org.freedesktop.Avahi.ServiceBrowser'"; "path='" ^ sb_path ^ "'"; ]) true; connection := Some (bus); (bus, true) let () = let bus, just_connected = connect () in (* Wait for incoming signals. *) while Connection.read_write_dispatch bus (-1) do () done ocaml_dbus-0.29/test.ml000066400000000000000000000071361125665546200151100ustar00rootroot00000000000000(* * Copyright (C) 2006-2009 Vincent Hanquez * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation; version 2.1 only. with the special * exception on linking described in file LICENSE. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * Dbus example *) open Printf let client bus = let msg = DBus.Message.new_signal "/test/signal/Object" "test.signal.Type" "Test" in DBus.Message.append msg [ (DBus.String "Ping!!"); (DBus.Bool false) ]; let serial = DBus.Connection.send bus msg in printf "client serial: %ld\n" serial; DBus.Connection.flush bus let server bus = let match_s = "type='signal',interface='test.signal.Type'" in DBus.Bus.add_match bus match_s false; DBus.Connection.flush bus; DBus.Connection.add_filter bus (fun bus msg -> true); while true do DBus.Connection.read_write bus 0; let msg = DBus.Connection.pop_message bus in match msg with | None -> Unix.sleep 1; () | Some msg -> if DBus.Message.is_signal msg "test.signal.Type" "Test" then ( let params = DBus.Message.get msg in let show p = match p with | DBus.String s -> printf "S: %s\n%!" s; | DBus.Int32 i -> printf "I: %ld\n%!" i; | DBus.Bool b -> printf "B: %b\n%!" b; | _ -> printf "other type\n"; in List.iter show params ) else if DBus.Message.is_method_call msg "test.method.Type" "Method" then ( printf "method call\n%!"; ) else printf "other call\n%!" done let server2 bus = let match_s = "type='signal',interface='test.signal.Type'" in DBus.Bus.add_match bus match_s false; DBus.Connection.flush bus; DBus.Connection.add_filter bus (fun bus msg -> true); let rset = ref [] in let wset = ref [] in let addfn watch = let flags = DBus.Watch.get_flags watch in printf "added watch\n"; let x = String.concat ", " (List.map (fun flag -> match flag with | DBus.Watch.Readable -> "readable" | DBus.Watch.Writable -> "writable" ) flags) in let fd = DBus.Watch.get_unix_fd watch in List.iter (fun flag -> match flag with | DBus.Watch.Readable -> rset := fd :: !rset; | DBus.Watch.Writable -> wset := fd :: !wset; ) flags; printf "added watch (%s)\n" x; true in let rmfn watch = printf "rmed watch\n" in let togglefn watch = printf "toggled watch\n" in DBus.Connection.set_watch_functions bus (addfn, rmfn, Some togglefn); DBus.Connection.flush bus; let rset = !rset and wset = !wset in while true do let r, w, _ = Unix.select rset [] [] (1.1) in if r <> [] || w <> [] then ( if r <> [] then printf "something to read\n%!"; DBus.Connection.read_write bus 0; let msg = DBus.Connection.pop_message bus in match msg with | None -> Unix.sleep 1; () | Some msg -> let params = DBus.Message.get msg in let show p = match p with | DBus.String s -> printf "S: %s\n%!" s; | DBus.Int32 i -> printf "I: %ld\n%!" i; | DBus.Bool b -> printf "B: %b\n%!" b; | _ -> printf "other type\n"; in List.iter show params ) done let _ = if (Array.length Sys.argv) < 2 then ( eprintf "usage: test [server|client]\n"; exit 1 ); let bus = DBus.Bus.get DBus.Bus.System in match Sys.argv.(1) with | "server" -> server2 bus | "client" -> client bus | _ -> eprintf "unknown command\n";